1!Copyright (c) 1992-2017 The University of Tennessee and The University 2! of Tennessee Research Foundation. All rights 3! reserved. 4!Copyright (c) 2000-2017 The University of California Berkeley. All 5! rights reserved. 6!Copyright (c) 2006-2017 The University of Colorado Denver. All rights 7! reserved. 8! 9!$COPYRIGHT$ 10! 11!Additional copyrights may follow 12! 13!$HEADER$ 14! 15!Redistribution and use in source and binary forms, with or without 16!modification, are permitted provided that the following conditions are 17!met: 18! 19!- Redistributions of source code must retain the above copyright 20! notice, this list of conditions and the following disclaimer. 21! 22!- Redistributions in binary form must reproduce the above copyright 23! notice, this list of conditions and the following disclaimer listed 24! in this license in the documentation and/or other materials 25! provided with the distribution. 26! 27!- Neither the name of the copyright holders nor the names of its 28! contributors may be used to endorse or promote products derived from 29! this software without specific prior written permission. 30! 31!The copyright holders provide no reassurances that the source code 32!provided does not infringe any patent, copyright, or any other 33!intellectual property rights of third parties. The copyright holders 34!disclaim any liability to any recipient for claims brought against 35!recipient by any third party for infringement of that parties 36!intellectual property rights. 37! 38!THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 39!"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 40!LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 41!A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 42!OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 43!SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 44!LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 45!DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 46!THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 47!(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 48!OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 49! SOURCE-FILE = /home/nicpa/LA/lapack/INSTALL/dlamch.f 50 DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) 51 CHARACTER CMACH 52 DOUBLE PRECISION ONE, ZERO 53 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 54 DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH 55 LOGICAL LSAME 56 EXTERNAL LSAME 57 INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, 58 $ MINEXPONENT, RADIX, TINY 59 RND = ONE 60 IF( ONE.EQ.RND ) THEN 61 EPS = EPSILON(ZERO) * 0.5 62 ELSE 63 EPS = EPSILON(ZERO) 64 END IF 65 IF( LSAME( CMACH, 'E' ) ) THEN 66 RMACH = EPS 67 ELSE IF( LSAME( CMACH, 'S' ) ) THEN 68 SFMIN = TINY(ZERO) 69 SMALL = ONE / HUGE(ZERO) 70 IF( SMALL.GE.SFMIN ) THEN 71 SFMIN = SMALL*( ONE+EPS ) 72 END IF 73 RMACH = SFMIN 74 ELSE IF( LSAME( CMACH, 'B' ) ) THEN 75 RMACH = RADIX(ZERO) 76 ELSE IF( LSAME( CMACH, 'P' ) ) THEN 77 RMACH = EPS * RADIX(ZERO) 78 ELSE IF( LSAME( CMACH, 'N' ) ) THEN 79 RMACH = DIGITS(ZERO) 80 ELSE IF( LSAME( CMACH, 'R' ) ) THEN 81 RMACH = RND 82 ELSE IF( LSAME( CMACH, 'M' ) ) THEN 83 RMACH = MINEXPONENT(ZERO) 84 ELSE IF( LSAME( CMACH, 'U' ) ) THEN 85 RMACH = tiny(zero) 86 ELSE IF( LSAME( CMACH, 'L' ) ) THEN 87 RMACH = MAXEXPONENT(ZERO) 88 ELSE IF( LSAME( CMACH, 'O' ) ) THEN 89 RMACH = HUGE(ZERO) 90 ELSE 91 RMACH = ZERO 92 END IF 93 DLAMCH = RMACH 94 RETURN 95 END 96 DOUBLE PRECISION FUNCTION DLAMC3( A, B ) 97 DOUBLE PRECISION A, B 98 DLAMC3 = A + B 99 RETURN 100 END 101! SOURCE-FILE = /home/nicpa/LA/lapack/INSTALL/slamch.f 102 REAL FUNCTION SLAMCH( CMACH ) 103 CHARACTER CMACH 104 REAL ONE, ZERO 105 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 106 REAL RND, EPS, SFMIN, SMALL, RMACH 107 LOGICAL LSAME 108 EXTERNAL LSAME 109 INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, 110 $ MINEXPONENT, RADIX, TINY 111 RND = ONE 112 IF( ONE.EQ.RND ) THEN 113 EPS = EPSILON(ZERO) * 0.5 114 ELSE 115 EPS = EPSILON(ZERO) 116 END IF 117 IF( LSAME( CMACH, 'E' ) ) THEN 118 RMACH = EPS 119 ELSE IF( LSAME( CMACH, 'S' ) ) THEN 120 SFMIN = TINY(ZERO) 121 SMALL = ONE / HUGE(ZERO) 122 IF( SMALL.GE.SFMIN ) THEN 123 SFMIN = SMALL*( ONE+EPS ) 124 END IF 125 RMACH = SFMIN 126 ELSE IF( LSAME( CMACH, 'B' ) ) THEN 127 RMACH = RADIX(ZERO) 128 ELSE IF( LSAME( CMACH, 'P' ) ) THEN 129 RMACH = EPS * RADIX(ZERO) 130 ELSE IF( LSAME( CMACH, 'N' ) ) THEN 131 RMACH = DIGITS(ZERO) 132 ELSE IF( LSAME( CMACH, 'R' ) ) THEN 133 RMACH = RND 134 ELSE IF( LSAME( CMACH, 'M' ) ) THEN 135 RMACH = MINEXPONENT(ZERO) 136 ELSE IF( LSAME( CMACH, 'U' ) ) THEN 137 RMACH = tiny(zero) 138 ELSE IF( LSAME( CMACH, 'L' ) ) THEN 139 RMACH = MAXEXPONENT(ZERO) 140 ELSE IF( LSAME( CMACH, 'O' ) ) THEN 141 RMACH = HUGE(ZERO) 142 ELSE 143 RMACH = ZERO 144 END IF 145 SLAMCH = RMACH 146 RETURN 147 END 148 REAL FUNCTION SLAMC3( A, B ) 149 REAL A, B 150 SLAMC3 = A + B 151 RETURN 152 END 153! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cgbtrs.f 154 SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, 155 $ INFO ) 156 CHARACTER TRANS 157 INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS 158 INTEGER IPIV( * ) 159 COMPLEX AB( LDAB, * ), B( LDB, * ) 160 COMPLEX ONE 161 PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) 162 LOGICAL LNOTI, NOTRAN 163 INTEGER I, J, KD, L, LM 164 LOGICAL LSAME 165 EXTERNAL LSAME 166 EXTERNAL CGEMV, CGERU, CLACGV, CSWAP, CTBSV, XERBLA 167 INTRINSIC MAX, MIN 168 INFO = 0 169 NOTRAN = LSAME( TRANS, 'N' ) 170 IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. 171 $ LSAME( TRANS, 'C' ) ) THEN 172 INFO = -1 173 ELSE IF( N.LT.0 ) THEN 174 INFO = -2 175 ELSE IF( KL.LT.0 ) THEN 176 INFO = -3 177 ELSE IF( KU.LT.0 ) THEN 178 INFO = -4 179 ELSE IF( NRHS.LT.0 ) THEN 180 INFO = -5 181 ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN 182 INFO = -7 183 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 184 INFO = -10 185 END IF 186 IF( INFO.NE.0 ) THEN 187 CALL XERBLA( 'CGBTRS', -INFO ) 188 RETURN 189 END IF 190 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 191 $ RETURN 192 KD = KU + KL + 1 193 LNOTI = KL.GT.0 194 IF( NOTRAN ) THEN 195 IF( LNOTI ) THEN 196 DO 10 J = 1, N - 1 197 LM = MIN( KL, N-J ) 198 L = IPIV( J ) 199 IF( L.NE.J ) 200 $ CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 201 CALL CGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), 202 $ LDB, B( J+1, 1 ), LDB ) 203 10 CONTINUE 204 END IF 205 DO 20 I = 1, NRHS 206 CALL CTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, 207 $ AB, LDAB, B( 1, I ), 1 ) 208 20 CONTINUE 209 ELSE IF( LSAME( TRANS, 'T' ) ) THEN 210 DO 30 I = 1, NRHS 211 CALL CTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, 212 $ LDAB, B( 1, I ), 1 ) 213 30 CONTINUE 214 IF( LNOTI ) THEN 215 DO 40 J = N - 1, 1, -1 216 LM = MIN( KL, N-J ) 217 CALL CGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), 218 $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) 219 L = IPIV( J ) 220 IF( L.NE.J ) 221 $ CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 222 40 CONTINUE 223 END IF 224 ELSE 225 DO 50 I = 1, NRHS 226 CALL CTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N, 227 $ KL+KU, AB, LDAB, B( 1, I ), 1 ) 228 50 CONTINUE 229 IF( LNOTI ) THEN 230 DO 60 J = N - 1, 1, -1 231 LM = MIN( KL, N-J ) 232 CALL CLACGV( NRHS, B( J, 1 ), LDB ) 233 CALL CGEMV( 'Conjugate transpose', LM, NRHS, -ONE, 234 $ B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE, 235 $ B( J, 1 ), LDB ) 236 CALL CLACGV( NRHS, B( J, 1 ), LDB ) 237 L = IPIV( J ) 238 IF( L.NE.J ) 239 $ CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 240 60 CONTINUE 241 END IF 242 END IF 243 RETURN 244 END 245! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cgetrs.f 246 SUBROUTINE CGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 247 CHARACTER TRANS 248 INTEGER INFO, LDA, LDB, N, NRHS 249 INTEGER IPIV( * ) 250 COMPLEX A( LDA, * ), B( LDB, * ) 251 COMPLEX ONE 252 PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) 253 LOGICAL NOTRAN 254 LOGICAL LSAME 255 EXTERNAL LSAME 256 EXTERNAL CLASWP, CTRSM, XERBLA 257 INTRINSIC MAX 258 INFO = 0 259 NOTRAN = LSAME( TRANS, 'N' ) 260 IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. 261 $ LSAME( TRANS, 'C' ) ) THEN 262 INFO = -1 263 ELSE IF( N.LT.0 ) THEN 264 INFO = -2 265 ELSE IF( NRHS.LT.0 ) THEN 266 INFO = -3 267 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 268 INFO = -5 269 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 270 INFO = -8 271 END IF 272 IF( INFO.NE.0 ) THEN 273 CALL XERBLA( 'CGETRS', -INFO ) 274 RETURN 275 END IF 276 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 277 $ RETURN 278 IF( NOTRAN ) THEN 279 CALL CLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) 280 CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, 281 $ ONE, A, LDA, B, LDB ) 282 CALL CTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, 283 $ NRHS, ONE, A, LDA, B, LDB ) 284 ELSE 285 CALL CTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, 286 $ A, LDA, B, LDB ) 287 CALL CTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, 288 $ LDA, B, LDB ) 289 CALL CLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) 290 END IF 291 RETURN 292 END 293! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/chetrs.f 294 SUBROUTINE CHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 295 CHARACTER UPLO 296 INTEGER INFO, LDA, LDB, N, NRHS 297 INTEGER IPIV( * ) 298 COMPLEX A( LDA, * ), B( LDB, * ) 299 COMPLEX ONE 300 PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) 301 LOGICAL UPPER 302 INTEGER J, K, KP 303 REAL S 304 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM 305 LOGICAL LSAME 306 EXTERNAL LSAME 307 EXTERNAL CGEMV, CGERU, CLACGV, CSSCAL, CSWAP, XERBLA 308 INTRINSIC CONJG, MAX, REAL 309 INFO = 0 310 UPPER = LSAME( UPLO, 'U' ) 311 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 312 INFO = -1 313 ELSE IF( N.LT.0 ) THEN 314 INFO = -2 315 ELSE IF( NRHS.LT.0 ) THEN 316 INFO = -3 317 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 318 INFO = -5 319 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 320 INFO = -8 321 END IF 322 IF( INFO.NE.0 ) THEN 323 CALL XERBLA( 'CHETRS', -INFO ) 324 RETURN 325 END IF 326 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 327 $ RETURN 328 IF( UPPER ) THEN 329 K = N 330 10 CONTINUE 331 IF( K.LT.1 ) 332 $ GO TO 30 333 IF( IPIV( K ).GT.0 ) THEN 334 KP = IPIV( K ) 335 IF( KP.NE.K ) 336 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 337 CALL CGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 338 $ B( 1, 1 ), LDB ) 339 S = REAL( ONE ) / REAL( A( K, K ) ) 340 CALL CSSCAL( NRHS, S, B( K, 1 ), LDB ) 341 K = K - 1 342 ELSE 343 KP = -IPIV( K ) 344 IF( KP.NE.K-1 ) 345 $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) 346 CALL CGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 347 $ B( 1, 1 ), LDB ) 348 CALL CGERU( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), 349 $ LDB, B( 1, 1 ), LDB ) 350 AKM1K = A( K-1, K ) 351 AKM1 = A( K-1, K-1 ) / AKM1K 352 AK = A( K, K ) / CONJG( AKM1K ) 353 DENOM = AKM1*AK - ONE 354 DO 20 J = 1, NRHS 355 BKM1 = B( K-1, J ) / AKM1K 356 BK = B( K, J ) / CONJG( AKM1K ) 357 B( K-1, J ) = ( AK*BKM1-BK ) / DENOM 358 B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM 359 20 CONTINUE 360 K = K - 2 361 END IF 362 GO TO 10 363 30 CONTINUE 364 K = 1 365 40 CONTINUE 366 IF( K.GT.N ) 367 $ GO TO 50 368 IF( IPIV( K ).GT.0 ) THEN 369 IF( K.GT.1 ) THEN 370 CALL CLACGV( NRHS, B( K, 1 ), LDB ) 371 CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, 372 $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) 373 CALL CLACGV( NRHS, B( K, 1 ), LDB ) 374 END IF 375 KP = IPIV( K ) 376 IF( KP.NE.K ) 377 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 378 K = K + 1 379 ELSE 380 IF( K.GT.1 ) THEN 381 CALL CLACGV( NRHS, B( K, 1 ), LDB ) 382 CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, 383 $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) 384 CALL CLACGV( NRHS, B( K, 1 ), LDB ) 385 CALL CLACGV( NRHS, B( K+1, 1 ), LDB ) 386 CALL CGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, 387 $ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) 388 CALL CLACGV( NRHS, B( K+1, 1 ), LDB ) 389 END IF 390 KP = -IPIV( K ) 391 IF( KP.NE.K ) 392 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 393 K = K + 2 394 END IF 395 GO TO 40 396 50 CONTINUE 397 ELSE 398 K = 1 399 60 CONTINUE 400 IF( K.GT.N ) 401 $ GO TO 80 402 IF( IPIV( K ).GT.0 ) THEN 403 KP = IPIV( K ) 404 IF( KP.NE.K ) 405 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 406 IF( K.LT.N ) 407 $ CALL CGERU( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), 408 $ LDB, B( K+1, 1 ), LDB ) 409 S = REAL( ONE ) / REAL( A( K, K ) ) 410 CALL CSSCAL( NRHS, S, B( K, 1 ), LDB ) 411 K = K + 1 412 ELSE 413 KP = -IPIV( K ) 414 IF( KP.NE.K+1 ) 415 $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) 416 IF( K.LT.N-1 ) THEN 417 CALL CGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), 418 $ LDB, B( K+2, 1 ), LDB ) 419 CALL CGERU( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, 420 $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) 421 END IF 422 AKM1K = A( K+1, K ) 423 AKM1 = A( K, K ) / CONJG( AKM1K ) 424 AK = A( K+1, K+1 ) / AKM1K 425 DENOM = AKM1*AK - ONE 426 DO 70 J = 1, NRHS 427 BKM1 = B( K, J ) / CONJG( AKM1K ) 428 BK = B( K+1, J ) / AKM1K 429 B( K, J ) = ( AK*BKM1-BK ) / DENOM 430 B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM 431 70 CONTINUE 432 K = K + 2 433 END IF 434 GO TO 60 435 80 CONTINUE 436 K = N 437 90 CONTINUE 438 IF( K.LT.1 ) 439 $ GO TO 100 440 IF( IPIV( K ).GT.0 ) THEN 441 IF( K.LT.N ) THEN 442 CALL CLACGV( NRHS, B( K, 1 ), LDB ) 443 CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, 444 $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE, 445 $ B( K, 1 ), LDB ) 446 CALL CLACGV( NRHS, B( K, 1 ), LDB ) 447 END IF 448 KP = IPIV( K ) 449 IF( KP.NE.K ) 450 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 451 K = K - 1 452 ELSE 453 IF( K.LT.N ) THEN 454 CALL CLACGV( NRHS, B( K, 1 ), LDB ) 455 CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, 456 $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE, 457 $ B( K, 1 ), LDB ) 458 CALL CLACGV( NRHS, B( K, 1 ), LDB ) 459 CALL CLACGV( NRHS, B( K-1, 1 ), LDB ) 460 CALL CGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, 461 $ B( K+1, 1 ), LDB, A( K+1, K-1 ), 1, ONE, 462 $ B( K-1, 1 ), LDB ) 463 CALL CLACGV( NRHS, B( K-1, 1 ), LDB ) 464 END IF 465 KP = -IPIV( K ) 466 IF( KP.NE.K ) 467 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 468 K = K - 2 469 END IF 470 GO TO 90 471 100 CONTINUE 472 END IF 473 RETURN 474 END 475! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/chla_transtype.f 476 CHARACTER*1 FUNCTION CHLA_TRANSTYPE( TRANS ) 477 INTEGER TRANS 478 INTEGER BLAS_NO_TRANS, BLAS_TRANS, BLAS_CONJ_TRANS 479 PARAMETER ( BLAS_NO_TRANS = 111, BLAS_TRANS = 112, 480 $ BLAS_CONJ_TRANS = 113 ) 481 IF( TRANS.EQ.BLAS_NO_TRANS ) THEN 482 CHLA_TRANSTYPE = 'N' 483 ELSE IF( TRANS.EQ.BLAS_TRANS ) THEN 484 CHLA_TRANSTYPE = 'T' 485 ELSE IF( TRANS.EQ.BLAS_CONJ_TRANS ) THEN 486 CHLA_TRANSTYPE = 'C' 487 ELSE 488 CHLA_TRANSTYPE = 'X' 489 END IF 490 RETURN 491 END 492! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_gbrcond_c.f 493 REAL FUNCTION CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, 494 $ LDAFB, IPIV, C, CAPPLY, INFO, WORK, 495 $ RWORK ) 496 CHARACTER TRANS 497 LOGICAL CAPPLY 498 INTEGER N, KL, KU, KD, KE, LDAB, LDAFB, INFO 499 INTEGER IPIV( * ) 500 COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ) 501 REAL C( * ), RWORK( * ) 502 LOGICAL NOTRANS 503 INTEGER KASE, I, J 504 REAL AINVNM, ANORM, TMP 505 COMPLEX ZDUM 506 INTEGER ISAVE( 3 ) 507 LOGICAL LSAME 508 EXTERNAL LSAME 509 EXTERNAL CLACN2, CGBTRS, XERBLA 510 INTRINSIC ABS, MAX 511 REAL CABS1 512 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 513 CLA_GBRCOND_C = 0.0E+0 514 INFO = 0 515 NOTRANS = LSAME( TRANS, 'N' ) 516 IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. 517 $ LSAME( TRANS, 'C' ) ) THEN 518 INFO = -1 519 ELSE IF( N.LT.0 ) THEN 520 INFO = -2 521 ELSE IF( KL.LT.0 .OR. KL.GT.N-1 ) THEN 522 INFO = -3 523 ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN 524 INFO = -4 525 ELSE IF( LDAB.LT.KL+KU+1 ) THEN 526 INFO = -6 527 ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN 528 INFO = -8 529 END IF 530 IF( INFO.NE.0 ) THEN 531 CALL XERBLA( 'CLA_GBRCOND_C', -INFO ) 532 RETURN 533 END IF 534 ANORM = 0.0E+0 535 KD = KU + 1 536 KE = KL + 1 537 IF ( NOTRANS ) THEN 538 DO I = 1, N 539 TMP = 0.0E+0 540 IF ( CAPPLY ) THEN 541 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 542 TMP = TMP + CABS1( AB( KD+I-J, J ) ) / C( J ) 543 END DO 544 ELSE 545 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 546 TMP = TMP + CABS1( AB( KD+I-J, J ) ) 547 END DO 548 END IF 549 RWORK( I ) = TMP 550 ANORM = MAX( ANORM, TMP ) 551 END DO 552 ELSE 553 DO I = 1, N 554 TMP = 0.0E+0 555 IF ( CAPPLY ) THEN 556 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 557 TMP = TMP + CABS1( AB( KE-I+J, I ) ) / C( J ) 558 END DO 559 ELSE 560 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 561 TMP = TMP + CABS1( AB( KE-I+J, I ) ) 562 END DO 563 END IF 564 RWORK( I ) = TMP 565 ANORM = MAX( ANORM, TMP ) 566 END DO 567 END IF 568 IF( N.EQ.0 ) THEN 569 CLA_GBRCOND_C = 1.0E+0 570 RETURN 571 ELSE IF( ANORM .EQ. 0.0E+0 ) THEN 572 RETURN 573 END IF 574 AINVNM = 0.0E+0 575 KASE = 0 576 10 CONTINUE 577 CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 578 IF( KASE.NE.0 ) THEN 579 IF( KASE.EQ.2 ) THEN 580 DO I = 1, N 581 WORK( I ) = WORK( I ) * RWORK( I ) 582 END DO 583 IF ( NOTRANS ) THEN 584 CALL CGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 585 $ IPIV, WORK, N, INFO ) 586 ELSE 587 CALL CGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, 588 $ LDAFB, IPIV, WORK, N, INFO ) 589 ENDIF 590 IF ( CAPPLY ) THEN 591 DO I = 1, N 592 WORK( I ) = WORK( I ) * C( I ) 593 END DO 594 END IF 595 ELSE 596 IF ( CAPPLY ) THEN 597 DO I = 1, N 598 WORK( I ) = WORK( I ) * C( I ) 599 END DO 600 END IF 601 IF ( NOTRANS ) THEN 602 CALL CGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, 603 $ LDAFB, IPIV, WORK, N, INFO ) 604 ELSE 605 CALL CGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 606 $ IPIV, WORK, N, INFO ) 607 END IF 608 DO I = 1, N 609 WORK( I ) = WORK( I ) * RWORK( I ) 610 END DO 611 END IF 612 GO TO 10 613 END IF 614 IF( AINVNM .NE. 0.0E+0 ) 615 $ CLA_GBRCOND_C = 1.0E+0 / AINVNM 616 RETURN 617 END 618! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_gbrcond_x.f 619 REAL FUNCTION CLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, 620 $ LDAFB, IPIV, X, INFO, WORK, RWORK ) 621 CHARACTER TRANS 622 INTEGER N, KL, KU, KD, KE, LDAB, LDAFB, INFO 623 INTEGER IPIV( * ) 624 COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), 625 $ X( * ) 626 REAL RWORK( * ) 627 LOGICAL NOTRANS 628 INTEGER KASE, I, J 629 REAL AINVNM, ANORM, TMP 630 COMPLEX ZDUM 631 INTEGER ISAVE( 3 ) 632 LOGICAL LSAME 633 EXTERNAL LSAME 634 EXTERNAL CLACN2, CGBTRS, XERBLA 635 INTRINSIC ABS, MAX 636 REAL CABS1 637 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 638 CLA_GBRCOND_X = 0.0E+0 639 INFO = 0 640 NOTRANS = LSAME( TRANS, 'N' ) 641 IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') .AND. .NOT. 642 $ LSAME( TRANS, 'C' ) ) THEN 643 INFO = -1 644 ELSE IF( N.LT.0 ) THEN 645 INFO = -2 646 ELSE IF( KL.LT.0 .OR. KL.GT.N-1 ) THEN 647 INFO = -3 648 ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN 649 INFO = -4 650 ELSE IF( LDAB.LT.KL+KU+1 ) THEN 651 INFO = -6 652 ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN 653 INFO = -8 654 END IF 655 IF( INFO.NE.0 ) THEN 656 CALL XERBLA( 'CLA_GBRCOND_X', -INFO ) 657 RETURN 658 END IF 659 KD = KU + 1 660 KE = KL + 1 661 ANORM = 0.0 662 IF ( NOTRANS ) THEN 663 DO I = 1, N 664 TMP = 0.0E+0 665 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 666 TMP = TMP + CABS1( AB( KD+I-J, J) * X( J ) ) 667 END DO 668 RWORK( I ) = TMP 669 ANORM = MAX( ANORM, TMP ) 670 END DO 671 ELSE 672 DO I = 1, N 673 TMP = 0.0E+0 674 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 675 TMP = TMP + CABS1( AB( KE-I+J, I ) * X( J ) ) 676 END DO 677 RWORK( I ) = TMP 678 ANORM = MAX( ANORM, TMP ) 679 END DO 680 END IF 681 IF( N.EQ.0 ) THEN 682 CLA_GBRCOND_X = 1.0E+0 683 RETURN 684 ELSE IF( ANORM .EQ. 0.0E+0 ) THEN 685 RETURN 686 END IF 687 AINVNM = 0.0E+0 688 KASE = 0 689 10 CONTINUE 690 CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 691 IF( KASE.NE.0 ) THEN 692 IF( KASE.EQ.2 ) THEN 693 DO I = 1, N 694 WORK( I ) = WORK( I ) * RWORK( I ) 695 END DO 696 IF ( NOTRANS ) THEN 697 CALL CGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 698 $ IPIV, WORK, N, INFO ) 699 ELSE 700 CALL CGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, 701 $ LDAFB, IPIV, WORK, N, INFO ) 702 ENDIF 703 DO I = 1, N 704 WORK( I ) = WORK( I ) / X( I ) 705 END DO 706 ELSE 707 DO I = 1, N 708 WORK( I ) = WORK( I ) / X( I ) 709 END DO 710 IF ( NOTRANS ) THEN 711 CALL CGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, 712 $ LDAFB, IPIV, WORK, N, INFO ) 713 ELSE 714 CALL CGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 715 $ IPIV, WORK, N, INFO ) 716 END IF 717 DO I = 1, N 718 WORK( I ) = WORK( I ) * RWORK( I ) 719 END DO 720 END IF 721 GO TO 10 722 END IF 723 IF( AINVNM .NE. 0.0E+0 ) 724 $ CLA_GBRCOND_X = 1.0E+0 / AINVNM 725 RETURN 726 END 727! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_gbrpvgrw.f 728 REAL FUNCTION CLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, 729 $ LDAFB ) 730 INTEGER N, KL, KU, NCOLS, LDAB, LDAFB 731 COMPLEX AB( LDAB, * ), AFB( LDAFB, * ) 732 INTEGER I, J, KD 733 REAL AMAX, UMAX, RPVGRW 734 COMPLEX ZDUM 735 INTRINSIC ABS, MAX, MIN, REAL, AIMAG 736 REAL CABS1 737 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 738 RPVGRW = 1.0 739 KD = KU + 1 740 DO J = 1, NCOLS 741 AMAX = 0.0 742 UMAX = 0.0 743 DO I = MAX( J-KU, 1 ), MIN( J+KL, N ) 744 AMAX = MAX( CABS1( AB( KD+I-J, J ) ), AMAX ) 745 END DO 746 DO I = MAX( J-KU, 1 ), J 747 UMAX = MAX( CABS1( AFB( KD+I-J, J ) ), UMAX ) 748 END DO 749 IF ( UMAX /= 0.0 ) THEN 750 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 751 END IF 752 END DO 753 CLA_GBRPVGRW = RPVGRW 754 END 755! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_gercond_c.f 756 REAL FUNCTION CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C, 757 $ CAPPLY, INFO, WORK, RWORK ) 758 CHARACTER TRANS 759 LOGICAL CAPPLY 760 INTEGER N, LDA, LDAF, INFO 761 INTEGER IPIV( * ) 762 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) 763 REAL C( * ), RWORK( * ) 764 LOGICAL NOTRANS 765 INTEGER KASE, I, J 766 REAL AINVNM, ANORM, TMP 767 COMPLEX ZDUM 768 INTEGER ISAVE( 3 ) 769 LOGICAL LSAME 770 EXTERNAL LSAME 771 EXTERNAL CLACN2, CGETRS, XERBLA 772 INTRINSIC ABS, MAX, REAL, AIMAG 773 REAL CABS1 774 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 775 CLA_GERCOND_C = 0.0E+0 776 INFO = 0 777 NOTRANS = LSAME( TRANS, 'N' ) 778 IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. 779 $ LSAME( TRANS, 'C' ) ) THEN 780 INFO = -1 781 ELSE IF( N.LT.0 ) THEN 782 INFO = -2 783 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 784 INFO = -4 785 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 786 INFO = -6 787 END IF 788 IF( INFO.NE.0 ) THEN 789 CALL XERBLA( 'CLA_GERCOND_C', -INFO ) 790 RETURN 791 END IF 792 ANORM = 0.0E+0 793 IF ( NOTRANS ) THEN 794 DO I = 1, N 795 TMP = 0.0E+0 796 IF ( CAPPLY ) THEN 797 DO J = 1, N 798 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 799 END DO 800 ELSE 801 DO J = 1, N 802 TMP = TMP + CABS1( A( I, J ) ) 803 END DO 804 END IF 805 RWORK( I ) = TMP 806 ANORM = MAX( ANORM, TMP ) 807 END DO 808 ELSE 809 DO I = 1, N 810 TMP = 0.0E+0 811 IF ( CAPPLY ) THEN 812 DO J = 1, N 813 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 814 END DO 815 ELSE 816 DO J = 1, N 817 TMP = TMP + CABS1( A( J, I ) ) 818 END DO 819 END IF 820 RWORK( I ) = TMP 821 ANORM = MAX( ANORM, TMP ) 822 END DO 823 END IF 824 IF( N.EQ.0 ) THEN 825 CLA_GERCOND_C = 1.0E+0 826 RETURN 827 ELSE IF( ANORM .EQ. 0.0E+0 ) THEN 828 RETURN 829 END IF 830 AINVNM = 0.0E+0 831 KASE = 0 832 10 CONTINUE 833 CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 834 IF( KASE.NE.0 ) THEN 835 IF( KASE.EQ.2 ) THEN 836 DO I = 1, N 837 WORK( I ) = WORK( I ) * RWORK( I ) 838 END DO 839 IF (NOTRANS) THEN 840 CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 841 $ WORK, N, INFO ) 842 ELSE 843 CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, 844 $ WORK, N, INFO ) 845 ENDIF 846 IF ( CAPPLY ) THEN 847 DO I = 1, N 848 WORK( I ) = WORK( I ) * C( I ) 849 END DO 850 END IF 851 ELSE 852 IF ( CAPPLY ) THEN 853 DO I = 1, N 854 WORK( I ) = WORK( I ) * C( I ) 855 END DO 856 END IF 857 IF ( NOTRANS ) THEN 858 CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, 859 $ WORK, N, INFO ) 860 ELSE 861 CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 862 $ WORK, N, INFO ) 863 END IF 864 DO I = 1, N 865 WORK( I ) = WORK( I ) * RWORK( I ) 866 END DO 867 END IF 868 GO TO 10 869 END IF 870 IF( AINVNM .NE. 0.0E+0 ) 871 $ CLA_GERCOND_C = 1.0E+0 / AINVNM 872 RETURN 873 END 874! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_gercond_x.f 875 REAL FUNCTION CLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, 876 $ INFO, WORK, RWORK ) 877 CHARACTER TRANS 878 INTEGER N, LDA, LDAF, INFO 879 INTEGER IPIV( * ) 880 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) 881 REAL RWORK( * ) 882 LOGICAL NOTRANS 883 INTEGER KASE 884 REAL AINVNM, ANORM, TMP 885 INTEGER I, J 886 COMPLEX ZDUM 887 INTEGER ISAVE( 3 ) 888 LOGICAL LSAME 889 EXTERNAL LSAME 890 EXTERNAL CLACN2, CGETRS, XERBLA 891 INTRINSIC ABS, MAX, REAL, AIMAG 892 REAL CABS1 893 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 894 CLA_GERCOND_X = 0.0E+0 895 INFO = 0 896 NOTRANS = LSAME( TRANS, 'N' ) 897 IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. 898 $ LSAME( TRANS, 'C' ) ) THEN 899 INFO = -1 900 ELSE IF( N.LT.0 ) THEN 901 INFO = -2 902 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 903 INFO = -4 904 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 905 INFO = -6 906 END IF 907 IF( INFO.NE.0 ) THEN 908 CALL XERBLA( 'CLA_GERCOND_X', -INFO ) 909 RETURN 910 END IF 911 ANORM = 0.0 912 IF ( NOTRANS ) THEN 913 DO I = 1, N 914 TMP = 0.0E+0 915 DO J = 1, N 916 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 917 END DO 918 RWORK( I ) = TMP 919 ANORM = MAX( ANORM, TMP ) 920 END DO 921 ELSE 922 DO I = 1, N 923 TMP = 0.0E+0 924 DO J = 1, N 925 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 926 END DO 927 RWORK( I ) = TMP 928 ANORM = MAX( ANORM, TMP ) 929 END DO 930 END IF 931 IF( N.EQ.0 ) THEN 932 CLA_GERCOND_X = 1.0E+0 933 RETURN 934 ELSE IF( ANORM .EQ. 0.0E+0 ) THEN 935 RETURN 936 END IF 937 AINVNM = 0.0E+0 938 KASE = 0 939 10 CONTINUE 940 CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 941 IF( KASE.NE.0 ) THEN 942 IF( KASE.EQ.2 ) THEN 943 DO I = 1, N 944 WORK( I ) = WORK( I ) * RWORK( I ) 945 END DO 946 IF ( NOTRANS ) THEN 947 CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 948 $ WORK, N, INFO ) 949 ELSE 950 CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, 951 $ WORK, N, INFO ) 952 ENDIF 953 DO I = 1, N 954 WORK( I ) = WORK( I ) / X( I ) 955 END DO 956 ELSE 957 DO I = 1, N 958 WORK( I ) = WORK( I ) / X( I ) 959 END DO 960 IF ( NOTRANS ) THEN 961 CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, 962 $ WORK, N, INFO ) 963 ELSE 964 CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 965 $ WORK, N, INFO ) 966 END IF 967 DO I = 1, N 968 WORK( I ) = WORK( I ) * RWORK( I ) 969 END DO 970 END IF 971 GO TO 10 972 END IF 973 IF( AINVNM .NE. 0.0E+0 ) 974 $ CLA_GERCOND_X = 1.0E+0 / AINVNM 975 RETURN 976 END 977! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_gerpvgrw.f 978 REAL FUNCTION CLA_GERPVGRW( N, NCOLS, A, LDA, AF, LDAF ) 979 INTEGER N, NCOLS, LDA, LDAF 980 COMPLEX A( LDA, * ), AF( LDAF, * ) 981 INTEGER I, J 982 REAL AMAX, UMAX, RPVGRW 983 COMPLEX ZDUM 984 INTRINSIC MAX, MIN, ABS, REAL, AIMAG 985 REAL CABS1 986 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 987 RPVGRW = 1.0 988 DO J = 1, NCOLS 989 AMAX = 0.0 990 UMAX = 0.0 991 DO I = 1, N 992 AMAX = MAX( CABS1( A( I, J ) ), AMAX ) 993 END DO 994 DO I = 1, J 995 UMAX = MAX( CABS1( AF( I, J ) ), UMAX ) 996 END DO 997 IF ( UMAX /= 0.0 ) THEN 998 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 999 END IF 1000 END DO 1001 CLA_GERPVGRW = RPVGRW 1002 END 1003! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_hercond_c.f 1004 REAL FUNCTION CLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, 1005 $ CAPPLY, INFO, WORK, RWORK ) 1006 CHARACTER UPLO 1007 LOGICAL CAPPLY 1008 INTEGER N, LDA, LDAF, INFO 1009 INTEGER IPIV( * ) 1010 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) 1011 REAL C ( * ), RWORK( * ) 1012 INTEGER KASE, I, J 1013 REAL AINVNM, ANORM, TMP 1014 LOGICAL UP, UPPER 1015 COMPLEX ZDUM 1016 INTEGER ISAVE( 3 ) 1017 LOGICAL LSAME 1018 EXTERNAL LSAME 1019 EXTERNAL CLACN2, CHETRS, XERBLA 1020 INTRINSIC ABS, MAX 1021 REAL CABS1 1022 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 1023 CLA_HERCOND_C = 0.0E+0 1024 INFO = 0 1025 UPPER = LSAME( UPLO, 'U' ) 1026 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 1027 INFO = -1 1028 ELSE IF( N.LT.0 ) THEN 1029 INFO = -2 1030 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 1031 INFO = -4 1032 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 1033 INFO = -6 1034 END IF 1035 IF( INFO.NE.0 ) THEN 1036 CALL XERBLA( 'CLA_HERCOND_C', -INFO ) 1037 RETURN 1038 END IF 1039 UP = .FALSE. 1040 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 1041 ANORM = 0.0E+0 1042 IF ( UP ) THEN 1043 DO I = 1, N 1044 TMP = 0.0E+0 1045 IF ( CAPPLY ) THEN 1046 DO J = 1, I 1047 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 1048 END DO 1049 DO J = I+1, N 1050 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 1051 END DO 1052 ELSE 1053 DO J = 1, I 1054 TMP = TMP + CABS1( A( J, I ) ) 1055 END DO 1056 DO J = I+1, N 1057 TMP = TMP + CABS1( A( I, J ) ) 1058 END DO 1059 END IF 1060 RWORK( I ) = TMP 1061 ANORM = MAX( ANORM, TMP ) 1062 END DO 1063 ELSE 1064 DO I = 1, N 1065 TMP = 0.0E+0 1066 IF ( CAPPLY ) THEN 1067 DO J = 1, I 1068 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 1069 END DO 1070 DO J = I+1, N 1071 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 1072 END DO 1073 ELSE 1074 DO J = 1, I 1075 TMP = TMP + CABS1( A( I, J ) ) 1076 END DO 1077 DO J = I+1, N 1078 TMP = TMP + CABS1( A( J, I ) ) 1079 END DO 1080 END IF 1081 RWORK( I ) = TMP 1082 ANORM = MAX( ANORM, TMP ) 1083 END DO 1084 END IF 1085 IF( N.EQ.0 ) THEN 1086 CLA_HERCOND_C = 1.0E+0 1087 RETURN 1088 ELSE IF( ANORM .EQ. 0.0E+0 ) THEN 1089 RETURN 1090 END IF 1091 AINVNM = 0.0E+0 1092 KASE = 0 1093 10 CONTINUE 1094 CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 1095 IF( KASE.NE.0 ) THEN 1096 IF( KASE.EQ.2 ) THEN 1097 DO I = 1, N 1098 WORK( I ) = WORK( I ) * RWORK( I ) 1099 END DO 1100 IF ( UP ) THEN 1101 CALL CHETRS( 'U', N, 1, AF, LDAF, IPIV, 1102 $ WORK, N, INFO ) 1103 ELSE 1104 CALL CHETRS( 'L', N, 1, AF, LDAF, IPIV, 1105 $ WORK, N, INFO ) 1106 ENDIF 1107 IF ( CAPPLY ) THEN 1108 DO I = 1, N 1109 WORK( I ) = WORK( I ) * C( I ) 1110 END DO 1111 END IF 1112 ELSE 1113 IF ( CAPPLY ) THEN 1114 DO I = 1, N 1115 WORK( I ) = WORK( I ) * C( I ) 1116 END DO 1117 END IF 1118 IF ( UP ) THEN 1119 CALL CHETRS( 'U', N, 1, AF, LDAF, IPIV, 1120 $ WORK, N, INFO ) 1121 ELSE 1122 CALL CHETRS( 'L', N, 1, AF, LDAF, IPIV, 1123 $ WORK, N, INFO ) 1124 END IF 1125 DO I = 1, N 1126 WORK( I ) = WORK( I ) * RWORK( I ) 1127 END DO 1128 END IF 1129 GO TO 10 1130 END IF 1131 IF( AINVNM .NE. 0.0E+0 ) 1132 $ CLA_HERCOND_C = 1.0E+0 / AINVNM 1133 RETURN 1134 END 1135! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_hercond_x.f 1136 REAL FUNCTION CLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, 1137 $ INFO, WORK, RWORK ) 1138 CHARACTER UPLO 1139 INTEGER N, LDA, LDAF, INFO 1140 INTEGER IPIV( * ) 1141 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) 1142 REAL RWORK( * ) 1143 INTEGER KASE, I, J 1144 REAL AINVNM, ANORM, TMP 1145 LOGICAL UP, UPPER 1146 COMPLEX ZDUM 1147 INTEGER ISAVE( 3 ) 1148 LOGICAL LSAME 1149 EXTERNAL LSAME 1150 EXTERNAL CLACN2, CHETRS, XERBLA 1151 INTRINSIC ABS, MAX 1152 REAL CABS1 1153 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 1154 CLA_HERCOND_X = 0.0E+0 1155 INFO = 0 1156 UPPER = LSAME( UPLO, 'U' ) 1157 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 1158 INFO = -1 1159 ELSE IF ( N.LT.0 ) THEN 1160 INFO = -2 1161 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 1162 INFO = -4 1163 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 1164 INFO = -6 1165 END IF 1166 IF( INFO.NE.0 ) THEN 1167 CALL XERBLA( 'CLA_HERCOND_X', -INFO ) 1168 RETURN 1169 END IF 1170 UP = .FALSE. 1171 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 1172 ANORM = 0.0 1173 IF ( UP ) THEN 1174 DO I = 1, N 1175 TMP = 0.0E+0 1176 DO J = 1, I 1177 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 1178 END DO 1179 DO J = I+1, N 1180 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 1181 END DO 1182 RWORK( I ) = TMP 1183 ANORM = MAX( ANORM, TMP ) 1184 END DO 1185 ELSE 1186 DO I = 1, N 1187 TMP = 0.0E+0 1188 DO J = 1, I 1189 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 1190 END DO 1191 DO J = I+1, N 1192 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 1193 END DO 1194 RWORK( I ) = TMP 1195 ANORM = MAX( ANORM, TMP ) 1196 END DO 1197 END IF 1198 IF( N.EQ.0 ) THEN 1199 CLA_HERCOND_X = 1.0E+0 1200 RETURN 1201 ELSE IF( ANORM .EQ. 0.0E+0 ) THEN 1202 RETURN 1203 END IF 1204 AINVNM = 0.0E+0 1205 KASE = 0 1206 10 CONTINUE 1207 CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 1208 IF( KASE.NE.0 ) THEN 1209 IF( KASE.EQ.2 ) THEN 1210 DO I = 1, N 1211 WORK( I ) = WORK( I ) * RWORK( I ) 1212 END DO 1213 IF ( UP ) THEN 1214 CALL CHETRS( 'U', N, 1, AF, LDAF, IPIV, 1215 $ WORK, N, INFO ) 1216 ELSE 1217 CALL CHETRS( 'L', N, 1, AF, LDAF, IPIV, 1218 $ WORK, N, INFO ) 1219 ENDIF 1220 DO I = 1, N 1221 WORK( I ) = WORK( I ) / X( I ) 1222 END DO 1223 ELSE 1224 DO I = 1, N 1225 WORK( I ) = WORK( I ) / X( I ) 1226 END DO 1227 IF ( UP ) THEN 1228 CALL CHETRS( 'U', N, 1, AF, LDAF, IPIV, 1229 $ WORK, N, INFO ) 1230 ELSE 1231 CALL CHETRS( 'L', N, 1, AF, LDAF, IPIV, 1232 $ WORK, N, INFO ) 1233 END IF 1234 DO I = 1, N 1235 WORK( I ) = WORK( I ) * RWORK( I ) 1236 END DO 1237 END IF 1238 GO TO 10 1239 END IF 1240 IF( AINVNM .NE. 0.0E+0 ) 1241 $ CLA_HERCOND_X = 1.0E+0 / AINVNM 1242 RETURN 1243 END 1244! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_herpvgrw.f 1245 REAL FUNCTION CLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, 1246 $ WORK ) 1247 CHARACTER*1 UPLO 1248 INTEGER N, INFO, LDA, LDAF 1249 INTEGER IPIV( * ) 1250 COMPLEX A( LDA, * ), AF( LDAF, * ) 1251 REAL WORK( * ) 1252 INTEGER NCOLS, I, J, K, KP 1253 REAL AMAX, UMAX, RPVGRW, TMP 1254 LOGICAL UPPER, LSAME 1255 COMPLEX ZDUM 1256 EXTERNAL LSAME 1257 INTRINSIC ABS, REAL, AIMAG, MAX, MIN 1258 REAL CABS1 1259 CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) ) 1260 UPPER = LSAME( 'Upper', UPLO ) 1261 IF ( INFO.EQ.0 ) THEN 1262 IF (UPPER) THEN 1263 NCOLS = 1 1264 ELSE 1265 NCOLS = N 1266 END IF 1267 ELSE 1268 NCOLS = INFO 1269 END IF 1270 RPVGRW = 1.0 1271 DO I = 1, 2*N 1272 WORK( I ) = 0.0 1273 END DO 1274 IF ( UPPER ) THEN 1275 DO J = 1, N 1276 DO I = 1, J 1277 WORK( N+I ) = MAX( CABS1( A( I,J ) ), WORK( N+I ) ) 1278 WORK( N+J ) = MAX( CABS1( A( I,J ) ), WORK( N+J ) ) 1279 END DO 1280 END DO 1281 ELSE 1282 DO J = 1, N 1283 DO I = J, N 1284 WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) 1285 WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) 1286 END DO 1287 END DO 1288 END IF 1289 IF ( UPPER ) THEN 1290 K = N 1291 DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) 1292 IF ( IPIV( K ).GT.0 ) THEN 1293 KP = IPIV( K ) 1294 IF ( KP .NE. K ) THEN 1295 TMP = WORK( N+K ) 1296 WORK( N+K ) = WORK( N+KP ) 1297 WORK( N+KP ) = TMP 1298 END IF 1299 DO I = 1, K 1300 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 1301 END DO 1302 K = K - 1 1303 ELSE 1304 KP = -IPIV( K ) 1305 TMP = WORK( N+K-1 ) 1306 WORK( N+K-1 ) = WORK( N+KP ) 1307 WORK( N+KP ) = TMP 1308 DO I = 1, K-1 1309 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 1310 WORK( K-1 ) = 1311 $ MAX( CABS1( AF( I, K-1 ) ), WORK( K-1 ) ) 1312 END DO 1313 WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) 1314 K = K - 2 1315 END IF 1316 END DO 1317 K = NCOLS 1318 DO WHILE ( K .LE. N ) 1319 IF ( IPIV( K ).GT.0 ) THEN 1320 KP = IPIV( K ) 1321 IF ( KP .NE. K ) THEN 1322 TMP = WORK( N+K ) 1323 WORK( N+K ) = WORK( N+KP ) 1324 WORK( N+KP ) = TMP 1325 END IF 1326 K = K + 1 1327 ELSE 1328 KP = -IPIV( K ) 1329 TMP = WORK( N+K ) 1330 WORK( N+K ) = WORK( N+KP ) 1331 WORK( N+KP ) = TMP 1332 K = K + 2 1333 END IF 1334 END DO 1335 ELSE 1336 K = 1 1337 DO WHILE ( K .LE. NCOLS ) 1338 IF ( IPIV( K ).GT.0 ) THEN 1339 KP = IPIV( K ) 1340 IF ( KP .NE. K ) THEN 1341 TMP = WORK( N+K ) 1342 WORK( N+K ) = WORK( N+KP ) 1343 WORK( N+KP ) = TMP 1344 END IF 1345 DO I = K, N 1346 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 1347 END DO 1348 K = K + 1 1349 ELSE 1350 KP = -IPIV( K ) 1351 TMP = WORK( N+K+1 ) 1352 WORK( N+K+1 ) = WORK( N+KP ) 1353 WORK( N+KP ) = TMP 1354 DO I = K+1, N 1355 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 1356 WORK( K+1 ) = 1357 $ MAX( CABS1( AF( I, K+1 ) ) , WORK( K+1 ) ) 1358 END DO 1359 WORK(K) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) 1360 K = K + 2 1361 END IF 1362 END DO 1363 K = NCOLS 1364 DO WHILE ( K .GE. 1 ) 1365 IF ( IPIV( K ).GT.0 ) THEN 1366 KP = IPIV( K ) 1367 IF ( KP .NE. K ) THEN 1368 TMP = WORK( N+K ) 1369 WORK( N+K ) = WORK( N+KP ) 1370 WORK( N+KP ) = TMP 1371 END IF 1372 K = K - 1 1373 ELSE 1374 KP = -IPIV( K ) 1375 TMP = WORK( N+K ) 1376 WORK( N+K ) = WORK( N+KP ) 1377 WORK( N+KP ) = TMP 1378 K = K - 2 1379 ENDIF 1380 END DO 1381 END IF 1382 IF ( UPPER ) THEN 1383 DO I = NCOLS, N 1384 UMAX = WORK( I ) 1385 AMAX = WORK( N+I ) 1386 IF ( UMAX /= 0.0 ) THEN 1387 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 1388 END IF 1389 END DO 1390 ELSE 1391 DO I = 1, NCOLS 1392 UMAX = WORK( I ) 1393 AMAX = WORK( N+I ) 1394 IF ( UMAX /= 0.0 ) THEN 1395 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 1396 END IF 1397 END DO 1398 END IF 1399 CLA_HERPVGRW = RPVGRW 1400 END 1401! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_porcond_c.f 1402 REAL FUNCTION CLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, 1403 $ INFO, WORK, RWORK ) 1404 CHARACTER UPLO 1405 LOGICAL CAPPLY 1406 INTEGER N, LDA, LDAF, INFO 1407 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) 1408 REAL C( * ), RWORK( * ) 1409 INTEGER KASE 1410 REAL AINVNM, ANORM, TMP 1411 INTEGER I, J 1412 LOGICAL UP, UPPER 1413 COMPLEX ZDUM 1414 INTEGER ISAVE( 3 ) 1415 LOGICAL LSAME 1416 EXTERNAL LSAME 1417 EXTERNAL CLACN2, CPOTRS, XERBLA 1418 INTRINSIC ABS, MAX, REAL, AIMAG 1419 REAL CABS1 1420 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 1421 CLA_PORCOND_C = 0.0E+0 1422 INFO = 0 1423 UPPER = LSAME( UPLO, 'U' ) 1424 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 1425 INFO = -1 1426 ELSE IF( N.LT.0 ) THEN 1427 INFO = -2 1428 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 1429 INFO = -4 1430 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 1431 INFO = -6 1432 END IF 1433 IF( INFO.NE.0 ) THEN 1434 CALL XERBLA( 'CLA_PORCOND_C', -INFO ) 1435 RETURN 1436 END IF 1437 UP = .FALSE. 1438 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 1439 ANORM = 0.0E+0 1440 IF ( UP ) THEN 1441 DO I = 1, N 1442 TMP = 0.0E+0 1443 IF ( CAPPLY ) THEN 1444 DO J = 1, I 1445 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 1446 END DO 1447 DO J = I+1, N 1448 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 1449 END DO 1450 ELSE 1451 DO J = 1, I 1452 TMP = TMP + CABS1( A( J, I ) ) 1453 END DO 1454 DO J = I+1, N 1455 TMP = TMP + CABS1( A( I, J ) ) 1456 END DO 1457 END IF 1458 RWORK( I ) = TMP 1459 ANORM = MAX( ANORM, TMP ) 1460 END DO 1461 ELSE 1462 DO I = 1, N 1463 TMP = 0.0E+0 1464 IF ( CAPPLY ) THEN 1465 DO J = 1, I 1466 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 1467 END DO 1468 DO J = I+1, N 1469 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 1470 END DO 1471 ELSE 1472 DO J = 1, I 1473 TMP = TMP + CABS1( A( I, J ) ) 1474 END DO 1475 DO J = I+1, N 1476 TMP = TMP + CABS1( A( J, I ) ) 1477 END DO 1478 END IF 1479 RWORK( I ) = TMP 1480 ANORM = MAX( ANORM, TMP ) 1481 END DO 1482 END IF 1483 IF( N.EQ.0 ) THEN 1484 CLA_PORCOND_C = 1.0E+0 1485 RETURN 1486 ELSE IF( ANORM .EQ. 0.0E+0 ) THEN 1487 RETURN 1488 END IF 1489 AINVNM = 0.0E+0 1490 KASE = 0 1491 10 CONTINUE 1492 CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 1493 IF( KASE.NE.0 ) THEN 1494 IF( KASE.EQ.2 ) THEN 1495 DO I = 1, N 1496 WORK( I ) = WORK( I ) * RWORK( I ) 1497 END DO 1498 IF ( UP ) THEN 1499 CALL CPOTRS( 'U', N, 1, AF, LDAF, 1500 $ WORK, N, INFO ) 1501 ELSE 1502 CALL CPOTRS( 'L', N, 1, AF, LDAF, 1503 $ WORK, N, INFO ) 1504 ENDIF 1505 IF ( CAPPLY ) THEN 1506 DO I = 1, N 1507 WORK( I ) = WORK( I ) * C( I ) 1508 END DO 1509 END IF 1510 ELSE 1511 IF ( CAPPLY ) THEN 1512 DO I = 1, N 1513 WORK( I ) = WORK( I ) * C( I ) 1514 END DO 1515 END IF 1516 IF ( UP ) THEN 1517 CALL CPOTRS( 'U', N, 1, AF, LDAF, 1518 $ WORK, N, INFO ) 1519 ELSE 1520 CALL CPOTRS( 'L', N, 1, AF, LDAF, 1521 $ WORK, N, INFO ) 1522 END IF 1523 DO I = 1, N 1524 WORK( I ) = WORK( I ) * RWORK( I ) 1525 END DO 1526 END IF 1527 GO TO 10 1528 END IF 1529 IF( AINVNM .NE. 0.0E+0 ) 1530 $ CLA_PORCOND_C = 1.0E+0 / AINVNM 1531 RETURN 1532 END 1533! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_porcond_x.f 1534 REAL FUNCTION CLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, 1535 $ WORK, RWORK ) 1536 CHARACTER UPLO 1537 INTEGER N, LDA, LDAF, INFO 1538 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) 1539 REAL RWORK( * ) 1540 INTEGER KASE, I, J 1541 REAL AINVNM, ANORM, TMP 1542 LOGICAL UP, UPPER 1543 COMPLEX ZDUM 1544 INTEGER ISAVE( 3 ) 1545 LOGICAL LSAME 1546 EXTERNAL LSAME 1547 EXTERNAL CLACN2, CPOTRS, XERBLA 1548 INTRINSIC ABS, MAX, REAL, AIMAG 1549 REAL CABS1 1550 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 1551 CLA_PORCOND_X = 0.0E+0 1552 INFO = 0 1553 UPPER = LSAME( UPLO, 'U' ) 1554 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 1555 INFO = -1 1556 ELSE IF ( N.LT.0 ) THEN 1557 INFO = -2 1558 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 1559 INFO = -4 1560 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 1561 INFO = -6 1562 END IF 1563 IF( INFO.NE.0 ) THEN 1564 CALL XERBLA( 'CLA_PORCOND_X', -INFO ) 1565 RETURN 1566 END IF 1567 UP = .FALSE. 1568 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 1569 ANORM = 0.0 1570 IF ( UP ) THEN 1571 DO I = 1, N 1572 TMP = 0.0E+0 1573 DO J = 1, I 1574 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 1575 END DO 1576 DO J = I+1, N 1577 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 1578 END DO 1579 RWORK( I ) = TMP 1580 ANORM = MAX( ANORM, TMP ) 1581 END DO 1582 ELSE 1583 DO I = 1, N 1584 TMP = 0.0E+0 1585 DO J = 1, I 1586 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 1587 END DO 1588 DO J = I+1, N 1589 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 1590 END DO 1591 RWORK( I ) = TMP 1592 ANORM = MAX( ANORM, TMP ) 1593 END DO 1594 END IF 1595 IF( N.EQ.0 ) THEN 1596 CLA_PORCOND_X = 1.0E+0 1597 RETURN 1598 ELSE IF( ANORM .EQ. 0.0E+0 ) THEN 1599 RETURN 1600 END IF 1601 AINVNM = 0.0E+0 1602 KASE = 0 1603 10 CONTINUE 1604 CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 1605 IF( KASE.NE.0 ) THEN 1606 IF( KASE.EQ.2 ) THEN 1607 DO I = 1, N 1608 WORK( I ) = WORK( I ) * RWORK( I ) 1609 END DO 1610 IF ( UP ) THEN 1611 CALL CPOTRS( 'U', N, 1, AF, LDAF, 1612 $ WORK, N, INFO ) 1613 ELSE 1614 CALL CPOTRS( 'L', N, 1, AF, LDAF, 1615 $ WORK, N, INFO ) 1616 ENDIF 1617 DO I = 1, N 1618 WORK( I ) = WORK( I ) / X( I ) 1619 END DO 1620 ELSE 1621 DO I = 1, N 1622 WORK( I ) = WORK( I ) / X( I ) 1623 END DO 1624 IF ( UP ) THEN 1625 CALL CPOTRS( 'U', N, 1, AF, LDAF, 1626 $ WORK, N, INFO ) 1627 ELSE 1628 CALL CPOTRS( 'L', N, 1, AF, LDAF, 1629 $ WORK, N, INFO ) 1630 END IF 1631 DO I = 1, N 1632 WORK( I ) = WORK( I ) * RWORK( I ) 1633 END DO 1634 END IF 1635 GO TO 10 1636 END IF 1637 IF( AINVNM .NE. 0.0E+0 ) 1638 $ CLA_PORCOND_X = 1.0E+0 / AINVNM 1639 RETURN 1640 END 1641! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_porpvgrw.f 1642 REAL FUNCTION CLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK ) 1643 CHARACTER*1 UPLO 1644 INTEGER NCOLS, LDA, LDAF 1645 COMPLEX A( LDA, * ), AF( LDAF, * ) 1646 REAL WORK( * ) 1647 INTEGER I, J 1648 REAL AMAX, UMAX, RPVGRW 1649 LOGICAL UPPER 1650 COMPLEX ZDUM 1651 EXTERNAL LSAME 1652 LOGICAL LSAME 1653 INTRINSIC ABS, MAX, MIN, REAL, AIMAG 1654 REAL CABS1 1655 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 1656 UPPER = LSAME( 'Upper', UPLO ) 1657 RPVGRW = 1.0 1658 DO I = 1, 2*NCOLS 1659 WORK( I ) = 0.0 1660 END DO 1661 IF ( UPPER ) THEN 1662 DO J = 1, NCOLS 1663 DO I = 1, J 1664 WORK( NCOLS+J ) = 1665 $ MAX( CABS1( A( I, J ) ), WORK( NCOLS+J ) ) 1666 END DO 1667 END DO 1668 ELSE 1669 DO J = 1, NCOLS 1670 DO I = J, NCOLS 1671 WORK( NCOLS+J ) = 1672 $ MAX( CABS1( A( I, J ) ), WORK( NCOLS+J ) ) 1673 END DO 1674 END DO 1675 END IF 1676 IF ( LSAME( 'Upper', UPLO ) ) THEN 1677 DO J = 1, NCOLS 1678 DO I = 1, J 1679 WORK( J ) = MAX( CABS1( AF( I, J ) ), WORK( J ) ) 1680 END DO 1681 END DO 1682 ELSE 1683 DO J = 1, NCOLS 1684 DO I = J, NCOLS 1685 WORK( J ) = MAX( CABS1( AF( I, J ) ), WORK( J ) ) 1686 END DO 1687 END DO 1688 END IF 1689 IF ( LSAME( 'Upper', UPLO ) ) THEN 1690 DO I = 1, NCOLS 1691 UMAX = WORK( I ) 1692 AMAX = WORK( NCOLS+I ) 1693 IF ( UMAX /= 0.0 ) THEN 1694 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 1695 END IF 1696 END DO 1697 ELSE 1698 DO I = 1, NCOLS 1699 UMAX = WORK( I ) 1700 AMAX = WORK( NCOLS+I ) 1701 IF ( UMAX /= 0.0 ) THEN 1702 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 1703 END IF 1704 END DO 1705 END IF 1706 CLA_PORPVGRW = RPVGRW 1707 END 1708! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_syrcond_c.f 1709 REAL FUNCTION CLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, 1710 $ CAPPLY, INFO, WORK, RWORK ) 1711 CHARACTER UPLO 1712 LOGICAL CAPPLY 1713 INTEGER N, LDA, LDAF, INFO 1714 INTEGER IPIV( * ) 1715 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) 1716 REAL C( * ), RWORK( * ) 1717 INTEGER KASE 1718 REAL AINVNM, ANORM, TMP 1719 INTEGER I, J 1720 LOGICAL UP, UPPER 1721 COMPLEX ZDUM 1722 INTEGER ISAVE( 3 ) 1723 LOGICAL LSAME 1724 EXTERNAL LSAME 1725 EXTERNAL CLACN2, CSYTRS, XERBLA 1726 INTRINSIC ABS, MAX 1727 REAL CABS1 1728 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 1729 CLA_SYRCOND_C = 0.0E+0 1730 INFO = 0 1731 UPPER = LSAME( UPLO, 'U' ) 1732 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 1733 INFO = -1 1734 ELSE IF( N.LT.0 ) THEN 1735 INFO = -2 1736 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 1737 INFO = -4 1738 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 1739 INFO = -6 1740 END IF 1741 IF( INFO.NE.0 ) THEN 1742 CALL XERBLA( 'CLA_SYRCOND_C', -INFO ) 1743 RETURN 1744 END IF 1745 UP = .FALSE. 1746 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 1747 ANORM = 0.0E+0 1748 IF ( UP ) THEN 1749 DO I = 1, N 1750 TMP = 0.0E+0 1751 IF ( CAPPLY ) THEN 1752 DO J = 1, I 1753 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 1754 END DO 1755 DO J = I+1, N 1756 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 1757 END DO 1758 ELSE 1759 DO J = 1, I 1760 TMP = TMP + CABS1( A( J, I ) ) 1761 END DO 1762 DO J = I+1, N 1763 TMP = TMP + CABS1( A( I, J ) ) 1764 END DO 1765 END IF 1766 RWORK( I ) = TMP 1767 ANORM = MAX( ANORM, TMP ) 1768 END DO 1769 ELSE 1770 DO I = 1, N 1771 TMP = 0.0E+0 1772 IF ( CAPPLY ) THEN 1773 DO J = 1, I 1774 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 1775 END DO 1776 DO J = I+1, N 1777 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 1778 END DO 1779 ELSE 1780 DO J = 1, I 1781 TMP = TMP + CABS1( A( I, J ) ) 1782 END DO 1783 DO J = I+1, N 1784 TMP = TMP + CABS1( A( J, I ) ) 1785 END DO 1786 END IF 1787 RWORK( I ) = TMP 1788 ANORM = MAX( ANORM, TMP ) 1789 END DO 1790 END IF 1791 IF( N.EQ.0 ) THEN 1792 CLA_SYRCOND_C = 1.0E+0 1793 RETURN 1794 ELSE IF( ANORM .EQ. 0.0E+0 ) THEN 1795 RETURN 1796 END IF 1797 AINVNM = 0.0E+0 1798 KASE = 0 1799 10 CONTINUE 1800 CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 1801 IF( KASE.NE.0 ) THEN 1802 IF( KASE.EQ.2 ) THEN 1803 DO I = 1, N 1804 WORK( I ) = WORK( I ) * RWORK( I ) 1805 END DO 1806 IF ( UP ) THEN 1807 CALL CSYTRS( 'U', N, 1, AF, LDAF, IPIV, 1808 $ WORK, N, INFO ) 1809 ELSE 1810 CALL CSYTRS( 'L', N, 1, AF, LDAF, IPIV, 1811 $ WORK, N, INFO ) 1812 ENDIF 1813 IF ( CAPPLY ) THEN 1814 DO I = 1, N 1815 WORK( I ) = WORK( I ) * C( I ) 1816 END DO 1817 END IF 1818 ELSE 1819 IF ( CAPPLY ) THEN 1820 DO I = 1, N 1821 WORK( I ) = WORK( I ) * C( I ) 1822 END DO 1823 END IF 1824 IF ( UP ) THEN 1825 CALL CSYTRS( 'U', N, 1, AF, LDAF, IPIV, 1826 $ WORK, N, INFO ) 1827 ELSE 1828 CALL CSYTRS( 'L', N, 1, AF, LDAF, IPIV, 1829 $ WORK, N, INFO ) 1830 END IF 1831 DO I = 1, N 1832 WORK( I ) = WORK( I ) * RWORK( I ) 1833 END DO 1834 END IF 1835 GO TO 10 1836 END IF 1837 IF( AINVNM .NE. 0.0E+0 ) 1838 $ CLA_SYRCOND_C = 1.0E+0 / AINVNM 1839 RETURN 1840 END 1841! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_syrcond_x.f 1842 REAL FUNCTION CLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, 1843 $ INFO, WORK, RWORK ) 1844 CHARACTER UPLO 1845 INTEGER N, LDA, LDAF, INFO 1846 INTEGER IPIV( * ) 1847 COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) 1848 REAL RWORK( * ) 1849 INTEGER KASE 1850 REAL AINVNM, ANORM, TMP 1851 INTEGER I, J 1852 LOGICAL UP, UPPER 1853 COMPLEX ZDUM 1854 INTEGER ISAVE( 3 ) 1855 LOGICAL LSAME 1856 EXTERNAL LSAME 1857 EXTERNAL CLACN2, CSYTRS, XERBLA 1858 INTRINSIC ABS, MAX 1859 REAL CABS1 1860 CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) 1861 CLA_SYRCOND_X = 0.0E+0 1862 INFO = 0 1863 UPPER = LSAME( UPLO, 'U' ) 1864 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 1865 INFO = -1 1866 ELSE IF ( N.LT.0 ) THEN 1867 INFO = -2 1868 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 1869 INFO = -4 1870 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 1871 INFO = -6 1872 END IF 1873 IF( INFO.NE.0 ) THEN 1874 CALL XERBLA( 'CLA_SYRCOND_X', -INFO ) 1875 RETURN 1876 END IF 1877 UP = .FALSE. 1878 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 1879 ANORM = 0.0 1880 IF ( UP ) THEN 1881 DO I = 1, N 1882 TMP = 0.0E+0 1883 DO J = 1, I 1884 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 1885 END DO 1886 DO J = I+1, N 1887 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 1888 END DO 1889 RWORK( I ) = TMP 1890 ANORM = MAX( ANORM, TMP ) 1891 END DO 1892 ELSE 1893 DO I = 1, N 1894 TMP = 0.0E+0 1895 DO J = 1, I 1896 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 1897 END DO 1898 DO J = I+1, N 1899 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 1900 END DO 1901 RWORK( I ) = TMP 1902 ANORM = MAX( ANORM, TMP ) 1903 END DO 1904 END IF 1905 IF( N.EQ.0 ) THEN 1906 CLA_SYRCOND_X = 1.0E+0 1907 RETURN 1908 ELSE IF( ANORM .EQ. 0.0E+0 ) THEN 1909 RETURN 1910 END IF 1911 AINVNM = 0.0E+0 1912 KASE = 0 1913 10 CONTINUE 1914 CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 1915 IF( KASE.NE.0 ) THEN 1916 IF( KASE.EQ.2 ) THEN 1917 DO I = 1, N 1918 WORK( I ) = WORK( I ) * RWORK( I ) 1919 END DO 1920 IF ( UP ) THEN 1921 CALL CSYTRS( 'U', N, 1, AF, LDAF, IPIV, 1922 $ WORK, N, INFO ) 1923 ELSE 1924 CALL CSYTRS( 'L', N, 1, AF, LDAF, IPIV, 1925 $ WORK, N, INFO ) 1926 ENDIF 1927 DO I = 1, N 1928 WORK( I ) = WORK( I ) / X( I ) 1929 END DO 1930 ELSE 1931 DO I = 1, N 1932 WORK( I ) = WORK( I ) / X( I ) 1933 END DO 1934 IF ( UP ) THEN 1935 CALL CSYTRS( 'U', N, 1, AF, LDAF, IPIV, 1936 $ WORK, N, INFO ) 1937 ELSE 1938 CALL CSYTRS( 'L', N, 1, AF, LDAF, IPIV, 1939 $ WORK, N, INFO ) 1940 END IF 1941 DO I = 1, N 1942 WORK( I ) = WORK( I ) * RWORK( I ) 1943 END DO 1944 END IF 1945 GO TO 10 1946 END IF 1947 IF( AINVNM .NE. 0.0E+0 ) 1948 $ CLA_SYRCOND_X = 1.0E+0 / AINVNM 1949 RETURN 1950 END 1951! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cla_syrpvgrw.f 1952 REAL FUNCTION CLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, 1953 $ WORK ) 1954 CHARACTER*1 UPLO 1955 INTEGER N, INFO, LDA, LDAF 1956 COMPLEX A( LDA, * ), AF( LDAF, * ) 1957 REAL WORK( * ) 1958 INTEGER IPIV( * ) 1959 INTEGER NCOLS, I, J, K, KP 1960 REAL AMAX, UMAX, RPVGRW, TMP 1961 LOGICAL UPPER 1962 COMPLEX ZDUM 1963 INTRINSIC ABS, REAL, AIMAG, MAX, MIN 1964 EXTERNAL LSAME 1965 LOGICAL LSAME 1966 REAL CABS1 1967 CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) ) 1968 UPPER = LSAME( 'Upper', UPLO ) 1969 IF ( INFO.EQ.0 ) THEN 1970 IF ( UPPER ) THEN 1971 NCOLS = 1 1972 ELSE 1973 NCOLS = N 1974 END IF 1975 ELSE 1976 NCOLS = INFO 1977 END IF 1978 RPVGRW = 1.0 1979 DO I = 1, 2*N 1980 WORK( I ) = 0.0 1981 END DO 1982 IF ( UPPER ) THEN 1983 DO J = 1, N 1984 DO I = 1, J 1985 WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) 1986 WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) 1987 END DO 1988 END DO 1989 ELSE 1990 DO J = 1, N 1991 DO I = J, N 1992 WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) 1993 WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) 1994 END DO 1995 END DO 1996 END IF 1997 IF ( UPPER ) THEN 1998 K = N 1999 DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) 2000 IF ( IPIV( K ).GT.0 ) THEN 2001 KP = IPIV( K ) 2002 IF ( KP .NE. K ) THEN 2003 TMP = WORK( N+K ) 2004 WORK( N+K ) = WORK( N+KP ) 2005 WORK( N+KP ) = TMP 2006 END IF 2007 DO I = 1, K 2008 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 2009 END DO 2010 K = K - 1 2011 ELSE 2012 KP = -IPIV( K ) 2013 TMP = WORK( N+K-1 ) 2014 WORK( N+K-1 ) = WORK( N+KP ) 2015 WORK( N+KP ) = TMP 2016 DO I = 1, K-1 2017 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 2018 WORK( K-1 ) = 2019 $ MAX( CABS1( AF( I, K-1 ) ), WORK( K-1 ) ) 2020 END DO 2021 WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) 2022 K = K - 2 2023 END IF 2024 END DO 2025 K = NCOLS 2026 DO WHILE ( K .LE. N ) 2027 IF ( IPIV( K ).GT.0 ) THEN 2028 KP = IPIV( K ) 2029 IF ( KP .NE. K ) THEN 2030 TMP = WORK( N+K ) 2031 WORK( N+K ) = WORK( N+KP ) 2032 WORK( N+KP ) = TMP 2033 END IF 2034 K = K + 1 2035 ELSE 2036 KP = -IPIV( K ) 2037 TMP = WORK( N+K ) 2038 WORK( N+K ) = WORK( N+KP ) 2039 WORK( N+KP ) = TMP 2040 K = K + 2 2041 END IF 2042 END DO 2043 ELSE 2044 K = 1 2045 DO WHILE ( K .LE. NCOLS ) 2046 IF ( IPIV( K ).GT.0 ) THEN 2047 KP = IPIV( K ) 2048 IF ( KP .NE. K ) THEN 2049 TMP = WORK( N+K ) 2050 WORK( N+K ) = WORK( N+KP ) 2051 WORK( N+KP ) = TMP 2052 END IF 2053 DO I = K, N 2054 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 2055 END DO 2056 K = K + 1 2057 ELSE 2058 KP = -IPIV( K ) 2059 TMP = WORK( N+K+1 ) 2060 WORK( N+K+1 ) = WORK( N+KP ) 2061 WORK( N+KP ) = TMP 2062 DO I = K+1, N 2063 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 2064 WORK( K+1 ) = 2065 $ MAX( CABS1( AF( I, K+1 ) ), WORK( K+1 ) ) 2066 END DO 2067 WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) 2068 K = K + 2 2069 END IF 2070 END DO 2071 K = NCOLS 2072 DO WHILE ( K .GE. 1 ) 2073 IF ( IPIV( K ).GT.0 ) THEN 2074 KP = IPIV( K ) 2075 IF ( KP .NE. K ) THEN 2076 TMP = WORK( N+K ) 2077 WORK( N+K ) = WORK( N+KP ) 2078 WORK( N+KP ) = TMP 2079 END IF 2080 K = K - 1 2081 ELSE 2082 KP = -IPIV( K ) 2083 TMP = WORK( N+K ) 2084 WORK( N+K ) = WORK( N+KP ) 2085 WORK( N+KP ) = TMP 2086 K = K - 2 2087 ENDIF 2088 END DO 2089 END IF 2090 IF ( UPPER ) THEN 2091 DO I = NCOLS, N 2092 UMAX = WORK( I ) 2093 AMAX = WORK( N+I ) 2094 IF ( UMAX /= 0.0 ) THEN 2095 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 2096 END IF 2097 END DO 2098 ELSE 2099 DO I = 1, NCOLS 2100 UMAX = WORK( I ) 2101 AMAX = WORK( N+I ) 2102 IF ( UMAX /= 0.0 ) THEN 2103 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 2104 END IF 2105 END DO 2106 END IF 2107 CLA_SYRPVGRW = RPVGRW 2108 END 2109! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clacgv.f 2110 SUBROUTINE CLACGV( N, X, INCX ) 2111 INTEGER INCX, N 2112 COMPLEX X( * ) 2113 INTEGER I, IOFF 2114 INTRINSIC CONJG 2115 IF( INCX.EQ.1 ) THEN 2116 DO 10 I = 1, N 2117 X( I ) = CONJG( X( I ) ) 2118 10 CONTINUE 2119 ELSE 2120 IOFF = 1 2121 IF( INCX.LT.0 ) 2122 $ IOFF = 1 - ( N-1 )*INCX 2123 DO 20 I = 1, N 2124 X( IOFF ) = CONJG( X( IOFF ) ) 2125 IOFF = IOFF + INCX 2126 20 CONTINUE 2127 END IF 2128 RETURN 2129 END 2130! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clacn2.f 2131 SUBROUTINE CLACN2( N, V, X, EST, KASE, ISAVE ) 2132 INTEGER KASE, N 2133 REAL EST 2134 INTEGER ISAVE( 3 ) 2135 COMPLEX V( * ), X( * ) 2136 INTEGER ITMAX 2137 PARAMETER ( ITMAX = 5 ) 2138 REAL ONE, TWO 2139 PARAMETER ( ONE = 1.0E0, TWO = 2.0E0 ) 2140 COMPLEX CZERO, CONE 2141 PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), 2142 $ CONE = ( 1.0E0, 0.0E0 ) ) 2143 INTEGER I, JLAST 2144 REAL ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP 2145 INTEGER ICMAX1 2146 REAL SCSUM1, SLAMCH 2147 EXTERNAL ICMAX1, SCSUM1, SLAMCH 2148 EXTERNAL CCOPY 2149 INTRINSIC ABS, AIMAG, CMPLX, REAL 2150 SAFMIN = SLAMCH( 'Safe minimum' ) 2151 IF( KASE.EQ.0 ) THEN 2152 DO 10 I = 1, N 2153 X( I ) = CMPLX( ONE / REAL( N ) ) 2154 10 CONTINUE 2155 KASE = 1 2156 ISAVE( 1 ) = 1 2157 RETURN 2158 END IF 2159 GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 ) 2160 20 CONTINUE 2161 IF( N.EQ.1 ) THEN 2162 V( 1 ) = X( 1 ) 2163 EST = ABS( V( 1 ) ) 2164 GO TO 130 2165 END IF 2166 EST = SCSUM1( N, X, 1 ) 2167 DO 30 I = 1, N 2168 ABSXI = ABS( X( I ) ) 2169 IF( ABSXI.GT.SAFMIN ) THEN 2170 X( I ) = CMPLX( REAL( X( I ) ) / ABSXI, 2171 $ AIMAG( X( I ) ) / ABSXI ) 2172 ELSE 2173 X( I ) = CONE 2174 END IF 2175 30 CONTINUE 2176 KASE = 2 2177 ISAVE( 1 ) = 2 2178 RETURN 2179 40 CONTINUE 2180 ISAVE( 2 ) = ICMAX1( N, X, 1 ) 2181 ISAVE( 3 ) = 2 2182 50 CONTINUE 2183 DO 60 I = 1, N 2184 X( I ) = CZERO 2185 60 CONTINUE 2186 X( ISAVE( 2 ) ) = CONE 2187 KASE = 1 2188 ISAVE( 1 ) = 3 2189 RETURN 2190 70 CONTINUE 2191 CALL CCOPY( N, X, 1, V, 1 ) 2192 ESTOLD = EST 2193 EST = SCSUM1( N, V, 1 ) 2194 IF( EST.LE.ESTOLD ) 2195 $ GO TO 100 2196 DO 80 I = 1, N 2197 ABSXI = ABS( X( I ) ) 2198 IF( ABSXI.GT.SAFMIN ) THEN 2199 X( I ) = CMPLX( REAL( X( I ) ) / ABSXI, 2200 $ AIMAG( X( I ) ) / ABSXI ) 2201 ELSE 2202 X( I ) = CONE 2203 END IF 2204 80 CONTINUE 2205 KASE = 2 2206 ISAVE( 1 ) = 4 2207 RETURN 2208 90 CONTINUE 2209 JLAST = ISAVE( 2 ) 2210 ISAVE( 2 ) = ICMAX1( N, X, 1 ) 2211 IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. 2212 $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN 2213 ISAVE( 3 ) = ISAVE( 3 ) + 1 2214 GO TO 50 2215 END IF 2216 100 CONTINUE 2217 ALTSGN = ONE 2218 DO 110 I = 1, N 2219 X( I ) = CMPLX( ALTSGN*( ONE + REAL( I-1 ) / REAL( N-1 ) ) ) 2220 ALTSGN = -ALTSGN 2221 110 CONTINUE 2222 KASE = 1 2223 ISAVE( 1 ) = 5 2224 RETURN 2225 120 CONTINUE 2226 TEMP = TWO*( SCSUM1( N, X, 1 ) / REAL( 3*N ) ) 2227 IF( TEMP.GT.EST ) THEN 2228 CALL CCOPY( N, X, 1, V, 1 ) 2229 EST = TEMP 2230 END IF 2231 130 CONTINUE 2232 KASE = 0 2233 RETURN 2234 END 2235! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cladiv.f 2236 COMPLEX FUNCTION CLADIV( X, Y ) 2237 COMPLEX X, Y 2238 REAL ZI, ZR 2239 EXTERNAL SLADIV 2240 INTRINSIC AIMAG, CMPLX, REAL 2241 CALL SLADIV( REAL( X ), AIMAG( X ), REAL( Y ), AIMAG( Y ), ZR, 2242 $ ZI ) 2243 CLADIV = CMPLX( ZR, ZI ) 2244 RETURN 2245 END 2246! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clangb.f 2247 REAL FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB, 2248 $ WORK ) 2249 IMPLICIT NONE 2250 CHARACTER NORM 2251 INTEGER KL, KU, LDAB, N 2252 REAL WORK( * ) 2253 COMPLEX AB( LDAB, * ) 2254 REAL ONE, ZERO 2255 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 2256 INTEGER I, J, K, L 2257 REAL SUM, VALUE, TEMP 2258 REAL SSQ( 2 ), COLSSQ( 2 ) 2259 LOGICAL LSAME, SISNAN 2260 EXTERNAL LSAME, SISNAN 2261 EXTERNAL CLASSQ, SCOMBSSQ 2262 INTRINSIC ABS, MAX, MIN, SQRT 2263 IF( N.EQ.0 ) THEN 2264 VALUE = ZERO 2265 ELSE IF( LSAME( NORM, 'M' ) ) THEN 2266 VALUE = ZERO 2267 DO 20 J = 1, N 2268 DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) 2269 TEMP = ABS( AB( I, J ) ) 2270 IF( VALUE.LT.TEMP .OR. SISNAN( TEMP ) ) VALUE = TEMP 2271 10 CONTINUE 2272 20 CONTINUE 2273 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 2274 VALUE = ZERO 2275 DO 40 J = 1, N 2276 SUM = ZERO 2277 DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) 2278 SUM = SUM + ABS( AB( I, J ) ) 2279 30 CONTINUE 2280 IF( VALUE.LT.SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2281 40 CONTINUE 2282 ELSE IF( LSAME( NORM, 'I' ) ) THEN 2283 DO 50 I = 1, N 2284 WORK( I ) = ZERO 2285 50 CONTINUE 2286 DO 70 J = 1, N 2287 K = KU + 1 - J 2288 DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL ) 2289 WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) ) 2290 60 CONTINUE 2291 70 CONTINUE 2292 VALUE = ZERO 2293 DO 80 I = 1, N 2294 TEMP = WORK( I ) 2295 IF( VALUE.LT.TEMP .OR. SISNAN( TEMP ) ) VALUE = TEMP 2296 80 CONTINUE 2297 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 2298 SSQ( 1 ) = ZERO 2299 SSQ( 2 ) = ONE 2300 DO 90 J = 1, N 2301 L = MAX( 1, J-KU ) 2302 K = KU + 1 - J + L 2303 COLSSQ( 1 ) = ZERO 2304 COLSSQ( 2 ) = ONE 2305 CALL CLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, 2306 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 2307 CALL SCOMBSSQ( SSQ, COLSSQ ) 2308 90 CONTINUE 2309 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 2310 END IF 2311 CLANGB = VALUE 2312 RETURN 2313 END 2314! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clange.f 2315 REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK ) 2316 IMPLICIT NONE 2317 CHARACTER NORM 2318 INTEGER LDA, M, N 2319 REAL WORK( * ) 2320 COMPLEX A( LDA, * ) 2321 REAL ONE, ZERO 2322 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 2323 INTEGER I, J 2324 REAL SUM, VALUE, TEMP 2325 REAL SSQ( 2 ), COLSSQ( 2 ) 2326 LOGICAL LSAME, SISNAN 2327 EXTERNAL LSAME, SISNAN 2328 EXTERNAL CLASSQ, SCOMBSSQ 2329 INTRINSIC ABS, MIN, SQRT 2330 IF( MIN( M, N ).EQ.0 ) THEN 2331 VALUE = ZERO 2332 ELSE IF( LSAME( NORM, 'M' ) ) THEN 2333 VALUE = ZERO 2334 DO 20 J = 1, N 2335 DO 10 I = 1, M 2336 TEMP = ABS( A( I, J ) ) 2337 IF( VALUE.LT.TEMP .OR. SISNAN( TEMP ) ) VALUE = TEMP 2338 10 CONTINUE 2339 20 CONTINUE 2340 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 2341 VALUE = ZERO 2342 DO 40 J = 1, N 2343 SUM = ZERO 2344 DO 30 I = 1, M 2345 SUM = SUM + ABS( A( I, J ) ) 2346 30 CONTINUE 2347 IF( VALUE.LT.SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2348 40 CONTINUE 2349 ELSE IF( LSAME( NORM, 'I' ) ) THEN 2350 DO 50 I = 1, M 2351 WORK( I ) = ZERO 2352 50 CONTINUE 2353 DO 70 J = 1, N 2354 DO 60 I = 1, M 2355 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 2356 60 CONTINUE 2357 70 CONTINUE 2358 VALUE = ZERO 2359 DO 80 I = 1, M 2360 TEMP = WORK( I ) 2361 IF( VALUE.LT.TEMP .OR. SISNAN( TEMP ) ) VALUE = TEMP 2362 80 CONTINUE 2363 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 2364 SSQ( 1 ) = ZERO 2365 SSQ( 2 ) = ONE 2366 DO 90 J = 1, N 2367 COLSSQ( 1 ) = ZERO 2368 COLSSQ( 2 ) = ONE 2369 CALL CLASSQ( M, A( 1, J ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 2370 CALL SCOMBSSQ( SSQ, COLSSQ ) 2371 90 CONTINUE 2372 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 2373 END IF 2374 CLANGE = VALUE 2375 RETURN 2376 END 2377! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clangt.f 2378 REAL FUNCTION CLANGT( NORM, N, DL, D, DU ) 2379 CHARACTER NORM 2380 INTEGER N 2381 COMPLEX D( * ), DL( * ), DU( * ) 2382 REAL ONE, ZERO 2383 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 2384 INTEGER I 2385 REAL ANORM, SCALE, SUM, TEMP 2386 LOGICAL LSAME, SISNAN 2387 EXTERNAL LSAME, SISNAN 2388 EXTERNAL CLASSQ 2389 INTRINSIC ABS, SQRT 2390 IF( N.LE.0 ) THEN 2391 ANORM = ZERO 2392 ELSE IF( LSAME( NORM, 'M' ) ) THEN 2393 ANORM = ABS( D( N ) ) 2394 DO 10 I = 1, N - 1 2395 IF( ANORM.LT.ABS( DL( I ) ) .OR. SISNAN( ABS( DL( I ) ) ) ) 2396 $ ANORM = ABS(DL(I)) 2397 IF( ANORM.LT.ABS( D( I ) ) .OR. SISNAN( ABS( D( I ) ) ) ) 2398 $ ANORM = ABS(D(I)) 2399 IF( ANORM.LT.ABS( DU( I ) ) .OR. SISNAN (ABS( DU( I ) ) ) ) 2400 $ ANORM = ABS(DU(I)) 2401 10 CONTINUE 2402 ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN 2403 IF( N.EQ.1 ) THEN 2404 ANORM = ABS( D( 1 ) ) 2405 ELSE 2406 ANORM = ABS( D( 1 ) )+ABS( DL( 1 ) ) 2407 TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) 2408 IF( ANORM .LT. TEMP .OR. SISNAN( TEMP ) ) ANORM = TEMP 2409 DO 20 I = 2, N - 1 2410 TEMP = ABS( D( I ) )+ABS( DL( I ) )+ABS( DU( I-1 ) ) 2411 IF( ANORM .LT. TEMP .OR. SISNAN( TEMP ) ) ANORM = TEMP 2412 20 CONTINUE 2413 END IF 2414 ELSE IF( LSAME( NORM, 'I' ) ) THEN 2415 IF( N.EQ.1 ) THEN 2416 ANORM = ABS( D( 1 ) ) 2417 ELSE 2418 ANORM = ABS( D( 1 ) )+ABS( DU( 1 ) ) 2419 TEMP = ABS( D( N ) )+ABS( DL( N-1 ) ) 2420 IF( ANORM .LT. TEMP .OR. SISNAN( TEMP ) ) ANORM = TEMP 2421 DO 30 I = 2, N - 1 2422 TEMP = ABS( D( I ) )+ABS( DU( I ) )+ABS( DL( I-1 ) ) 2423 IF( ANORM .LT. TEMP .OR. SISNAN( TEMP ) ) ANORM = TEMP 2424 30 CONTINUE 2425 END IF 2426 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 2427 SCALE = ZERO 2428 SUM = ONE 2429 CALL CLASSQ( N, D, 1, SCALE, SUM ) 2430 IF( N.GT.1 ) THEN 2431 CALL CLASSQ( N-1, DL, 1, SCALE, SUM ) 2432 CALL CLASSQ( N-1, DU, 1, SCALE, SUM ) 2433 END IF 2434 ANORM = SCALE*SQRT( SUM ) 2435 END IF 2436 CLANGT = ANORM 2437 RETURN 2438 END 2439! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clanhb.f 2440 REAL FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, 2441 $ WORK ) 2442 IMPLICIT NONE 2443 CHARACTER NORM, UPLO 2444 INTEGER K, LDAB, N 2445 REAL WORK( * ) 2446 COMPLEX AB( LDAB, * ) 2447 REAL ONE, ZERO 2448 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 2449 INTEGER I, J, L 2450 REAL ABSA, SUM, VALUE 2451 REAL SSQ( 2 ), COLSSQ( 2 ) 2452 LOGICAL LSAME, SISNAN 2453 EXTERNAL LSAME, SISNAN 2454 EXTERNAL CLASSQ, SCOMBSSQ 2455 INTRINSIC ABS, MAX, MIN, REAL, SQRT 2456 IF( N.EQ.0 ) THEN 2457 VALUE = ZERO 2458 ELSE IF( LSAME( NORM, 'M' ) ) THEN 2459 VALUE = ZERO 2460 IF( LSAME( UPLO, 'U' ) ) THEN 2461 DO 20 J = 1, N 2462 DO 10 I = MAX( K+2-J, 1 ), K 2463 SUM = ABS( AB( I, J ) ) 2464 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2465 10 CONTINUE 2466 SUM = ABS( REAL( AB( K+1, J ) ) ) 2467 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2468 20 CONTINUE 2469 ELSE 2470 DO 40 J = 1, N 2471 SUM = ABS( REAL( AB( 1, J ) ) ) 2472 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2473 DO 30 I = 2, MIN( N+1-J, K+1 ) 2474 SUM = ABS( AB( I, J ) ) 2475 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2476 30 CONTINUE 2477 40 CONTINUE 2478 END IF 2479 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 2480 $ ( NORM.EQ.'1' ) ) THEN 2481 VALUE = ZERO 2482 IF( LSAME( UPLO, 'U' ) ) THEN 2483 DO 60 J = 1, N 2484 SUM = ZERO 2485 L = K + 1 - J 2486 DO 50 I = MAX( 1, J-K ), J - 1 2487 ABSA = ABS( AB( L+I, J ) ) 2488 SUM = SUM + ABSA 2489 WORK( I ) = WORK( I ) + ABSA 2490 50 CONTINUE 2491 WORK( J ) = SUM + ABS( REAL( AB( K+1, J ) ) ) 2492 60 CONTINUE 2493 DO 70 I = 1, N 2494 SUM = WORK( I ) 2495 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2496 70 CONTINUE 2497 ELSE 2498 DO 80 I = 1, N 2499 WORK( I ) = ZERO 2500 80 CONTINUE 2501 DO 100 J = 1, N 2502 SUM = WORK( J ) + ABS( REAL( AB( 1, J ) ) ) 2503 L = 1 - J 2504 DO 90 I = J + 1, MIN( N, J+K ) 2505 ABSA = ABS( AB( L+I, J ) ) 2506 SUM = SUM + ABSA 2507 WORK( I ) = WORK( I ) + ABSA 2508 90 CONTINUE 2509 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2510 100 CONTINUE 2511 END IF 2512 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 2513 SSQ( 1 ) = ZERO 2514 SSQ( 2 ) = ONE 2515 IF( K.GT.0 ) THEN 2516 IF( LSAME( UPLO, 'U' ) ) THEN 2517 DO 110 J = 2, N 2518 COLSSQ( 1 ) = ZERO 2519 COLSSQ( 2 ) = ONE 2520 CALL CLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), 2521 $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 2522 CALL SCOMBSSQ( SSQ, COLSSQ ) 2523 110 CONTINUE 2524 L = K + 1 2525 ELSE 2526 DO 120 J = 1, N - 1 2527 COLSSQ( 1 ) = ZERO 2528 COLSSQ( 2 ) = ONE 2529 CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, 2530 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 2531 CALL SCOMBSSQ( SSQ, COLSSQ ) 2532 120 CONTINUE 2533 L = 1 2534 END IF 2535 SSQ( 2 ) = 2*SSQ( 2 ) 2536 ELSE 2537 L = 1 2538 END IF 2539 COLSSQ( 1 ) = ZERO 2540 COLSSQ( 2 ) = ONE 2541 DO 130 J = 1, N 2542 IF( REAL( AB( L, J ) ).NE.ZERO ) THEN 2543 ABSA = ABS( REAL( AB( L, J ) ) ) 2544 IF( COLSSQ( 1 ).LT.ABSA ) THEN 2545 COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 2546 COLSSQ( 1 ) = ABSA 2547 ELSE 2548 COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 2549 END IF 2550 END IF 2551 130 CONTINUE 2552 CALL SCOMBSSQ( SSQ, COLSSQ ) 2553 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 2554 END IF 2555 CLANHB = VALUE 2556 RETURN 2557 END 2558! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clanhe.f 2559 REAL FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK ) 2560 IMPLICIT NONE 2561 CHARACTER NORM, UPLO 2562 INTEGER LDA, N 2563 REAL WORK( * ) 2564 COMPLEX A( LDA, * ) 2565 REAL ONE, ZERO 2566 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 2567 INTEGER I, J 2568 REAL ABSA, SUM, VALUE 2569 REAL SSQ( 2 ), COLSSQ( 2 ) 2570 LOGICAL LSAME, SISNAN 2571 EXTERNAL LSAME, SISNAN 2572 EXTERNAL CLASSQ, SCOMBSSQ 2573 INTRINSIC ABS, REAL, SQRT 2574 IF( N.EQ.0 ) THEN 2575 VALUE = ZERO 2576 ELSE IF( LSAME( NORM, 'M' ) ) THEN 2577 VALUE = ZERO 2578 IF( LSAME( UPLO, 'U' ) ) THEN 2579 DO 20 J = 1, N 2580 DO 10 I = 1, J - 1 2581 SUM = ABS( A( I, J ) ) 2582 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2583 10 CONTINUE 2584 SUM = ABS( REAL( A( J, J ) ) ) 2585 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2586 20 CONTINUE 2587 ELSE 2588 DO 40 J = 1, N 2589 SUM = ABS( REAL( A( J, J ) ) ) 2590 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2591 DO 30 I = J + 1, N 2592 SUM = ABS( A( I, J ) ) 2593 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2594 30 CONTINUE 2595 40 CONTINUE 2596 END IF 2597 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 2598 $ ( NORM.EQ.'1' ) ) THEN 2599 VALUE = ZERO 2600 IF( LSAME( UPLO, 'U' ) ) THEN 2601 DO 60 J = 1, N 2602 SUM = ZERO 2603 DO 50 I = 1, J - 1 2604 ABSA = ABS( A( I, J ) ) 2605 SUM = SUM + ABSA 2606 WORK( I ) = WORK( I ) + ABSA 2607 50 CONTINUE 2608 WORK( J ) = SUM + ABS( REAL( A( J, J ) ) ) 2609 60 CONTINUE 2610 DO 70 I = 1, N 2611 SUM = WORK( I ) 2612 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2613 70 CONTINUE 2614 ELSE 2615 DO 80 I = 1, N 2616 WORK( I ) = ZERO 2617 80 CONTINUE 2618 DO 100 J = 1, N 2619 SUM = WORK( J ) + ABS( REAL( A( J, J ) ) ) 2620 DO 90 I = J + 1, N 2621 ABSA = ABS( A( I, J ) ) 2622 SUM = SUM + ABSA 2623 WORK( I ) = WORK( I ) + ABSA 2624 90 CONTINUE 2625 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 2626 100 CONTINUE 2627 END IF 2628 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 2629 SSQ( 1 ) = ZERO 2630 SSQ( 2 ) = ONE 2631 IF( LSAME( UPLO, 'U' ) ) THEN 2632 DO 110 J = 2, N 2633 COLSSQ( 1 ) = ZERO 2634 COLSSQ( 2 ) = ONE 2635 CALL CLASSQ( J-1, A( 1, J ), 1, 2636 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 2637 CALL SCOMBSSQ( SSQ, COLSSQ ) 2638 110 CONTINUE 2639 ELSE 2640 DO 120 J = 1, N - 1 2641 COLSSQ( 1 ) = ZERO 2642 COLSSQ( 2 ) = ONE 2643 CALL CLASSQ( N-J, A( J+1, J ), 1, 2644 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 2645 CALL SCOMBSSQ( SSQ, COLSSQ ) 2646 120 CONTINUE 2647 END IF 2648 SSQ( 2 ) = 2*SSQ( 2 ) 2649 DO 130 I = 1, N 2650 IF( REAL( A( I, I ) ).NE.ZERO ) THEN 2651 ABSA = ABS( REAL( A( I, I ) ) ) 2652 IF( SSQ( 1 ).LT.ABSA ) THEN 2653 SSQ( 2 ) = ONE + SSQ( 2 )*( SSQ( 1 ) / ABSA )**2 2654 SSQ( 1 ) = ABSA 2655 ELSE 2656 SSQ( 2 ) = SSQ( 2 ) + ( ABSA / SSQ( 1 ) )**2 2657 END IF 2658 END IF 2659 130 CONTINUE 2660 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 2661 END IF 2662 CLANHE = VALUE 2663 RETURN 2664 END 2665! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clanhf.f 2666 REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK ) 2667 CHARACTER NORM, TRANSR, UPLO 2668 INTEGER N 2669 REAL WORK( 0: * ) 2670 COMPLEX A( 0: * ) 2671 REAL ONE, ZERO 2672 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 2673 INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA 2674 REAL SCALE, S, VALUE, AA, TEMP 2675 LOGICAL LSAME, SISNAN 2676 EXTERNAL LSAME, SISNAN 2677 EXTERNAL CLASSQ 2678 INTRINSIC ABS, REAL, SQRT 2679 IF( N.EQ.0 ) THEN 2680 CLANHF = ZERO 2681 RETURN 2682 ELSE IF( N.EQ.1 ) THEN 2683 CLANHF = ABS(REAL(A(0))) 2684 RETURN 2685 END IF 2686 NOE = 1 2687 IF( MOD( N, 2 ).EQ.0 ) 2688 $ NOE = 0 2689 IFM = 1 2690 IF( LSAME( TRANSR, 'C' ) ) 2691 $ IFM = 0 2692 ILU = 1 2693 IF( LSAME( UPLO, 'U' ) ) 2694 $ ILU = 0 2695 IF( IFM.EQ.1 ) THEN 2696 IF( NOE.EQ.1 ) THEN 2697 LDA = N 2698 ELSE 2699 LDA = N + 1 2700 END IF 2701 ELSE 2702 LDA = ( N+1 ) / 2 2703 END IF 2704 IF( LSAME( NORM, 'M' ) ) THEN 2705 K = ( N+1 ) / 2 2706 VALUE = ZERO 2707 IF( NOE.EQ.1 ) THEN 2708 IF( IFM.EQ.1 ) THEN 2709 IF( ILU.EQ.1 ) THEN 2710 J = 0 2711 TEMP = ABS( REAL( A( J+J*LDA ) ) ) 2712 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2713 $ VALUE = TEMP 2714 DO I = 1, N - 1 2715 TEMP = ABS( A( I+J*LDA ) ) 2716 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2717 $ VALUE = TEMP 2718 END DO 2719 DO J = 1, K - 1 2720 DO I = 0, J - 2 2721 TEMP = ABS( A( I+J*LDA ) ) 2722 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2723 $ VALUE = TEMP 2724 END DO 2725 I = J - 1 2726 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2727 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2728 $ VALUE = TEMP 2729 I = J 2730 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2731 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2732 $ VALUE = TEMP 2733 DO I = J + 1, N - 1 2734 TEMP = ABS( A( I+J*LDA ) ) 2735 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2736 $ VALUE = TEMP 2737 END DO 2738 END DO 2739 ELSE 2740 DO J = 0, K - 2 2741 DO I = 0, K + J - 2 2742 TEMP = ABS( A( I+J*LDA ) ) 2743 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2744 $ VALUE = TEMP 2745 END DO 2746 I = K + J - 1 2747 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2748 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2749 $ VALUE = TEMP 2750 I = I + 1 2751 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2752 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2753 $ VALUE = TEMP 2754 DO I = K + J + 1, N - 1 2755 TEMP = ABS( A( I+J*LDA ) ) 2756 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2757 $ VALUE = TEMP 2758 END DO 2759 END DO 2760 DO I = 0, N - 2 2761 TEMP = ABS( A( I+J*LDA ) ) 2762 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2763 $ VALUE = TEMP 2764 END DO 2765 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2766 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2767 $ VALUE = TEMP 2768 END IF 2769 ELSE 2770 IF( ILU.EQ.1 ) THEN 2771 DO J = 0, K - 2 2772 DO I = 0, J - 1 2773 TEMP = ABS( A( I+J*LDA ) ) 2774 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2775 $ VALUE = TEMP 2776 END DO 2777 I = J 2778 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2779 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2780 $ VALUE = TEMP 2781 I = J + 1 2782 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2783 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2784 $ VALUE = TEMP 2785 DO I = J + 2, K - 1 2786 TEMP = ABS( A( I+J*LDA ) ) 2787 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2788 $ VALUE = TEMP 2789 END DO 2790 END DO 2791 J = K - 1 2792 DO I = 0, K - 2 2793 TEMP = ABS( A( I+J*LDA ) ) 2794 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2795 $ VALUE = TEMP 2796 END DO 2797 I = K - 1 2798 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2799 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2800 $ VALUE = TEMP 2801 DO J = K, N - 1 2802 DO I = 0, K - 1 2803 TEMP = ABS( A( I+J*LDA ) ) 2804 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2805 $ VALUE = TEMP 2806 END DO 2807 END DO 2808 ELSE 2809 DO J = 0, K - 2 2810 DO I = 0, K - 1 2811 TEMP = ABS( A( I+J*LDA ) ) 2812 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2813 $ VALUE = TEMP 2814 END DO 2815 END DO 2816 J = K - 1 2817 TEMP = ABS( REAL( A( 0+J*LDA ) ) ) 2818 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2819 $ VALUE = TEMP 2820 DO I = 1, K - 1 2821 TEMP = ABS( A( I+J*LDA ) ) 2822 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2823 $ VALUE = TEMP 2824 END DO 2825 DO J = K, N - 1 2826 DO I = 0, J - K - 1 2827 TEMP = ABS( A( I+J*LDA ) ) 2828 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2829 $ VALUE = TEMP 2830 END DO 2831 I = J - K 2832 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2833 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2834 $ VALUE = TEMP 2835 I = J - K + 1 2836 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2837 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2838 $ VALUE = TEMP 2839 DO I = J - K + 2, K - 1 2840 TEMP = ABS( A( I+J*LDA ) ) 2841 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2842 $ VALUE = TEMP 2843 END DO 2844 END DO 2845 END IF 2846 END IF 2847 ELSE 2848 IF( IFM.EQ.1 ) THEN 2849 IF( ILU.EQ.1 ) THEN 2850 J = 0 2851 TEMP = ABS( REAL( A( J+J*LDA ) ) ) 2852 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2853 $ VALUE = TEMP 2854 TEMP = ABS( REAL( A( J+1+J*LDA ) ) ) 2855 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2856 $ VALUE = TEMP 2857 DO I = 2, N 2858 TEMP = ABS( A( I+J*LDA ) ) 2859 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2860 $ VALUE = TEMP 2861 END DO 2862 DO J = 1, K - 1 2863 DO I = 0, J - 1 2864 TEMP = ABS( A( I+J*LDA ) ) 2865 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2866 $ VALUE = TEMP 2867 END DO 2868 I = J 2869 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2870 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2871 $ VALUE = TEMP 2872 I = J + 1 2873 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2874 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2875 $ VALUE = TEMP 2876 DO I = J + 2, N 2877 TEMP = ABS( A( I+J*LDA ) ) 2878 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2879 $ VALUE = TEMP 2880 END DO 2881 END DO 2882 ELSE 2883 DO J = 0, K - 2 2884 DO I = 0, K + J - 1 2885 TEMP = ABS( A( I+J*LDA ) ) 2886 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2887 $ VALUE = TEMP 2888 END DO 2889 I = K + J 2890 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2891 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2892 $ VALUE = TEMP 2893 I = I + 1 2894 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2895 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2896 $ VALUE = TEMP 2897 DO I = K + J + 2, N 2898 TEMP = ABS( A( I+J*LDA ) ) 2899 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2900 $ VALUE = TEMP 2901 END DO 2902 END DO 2903 DO I = 0, N - 2 2904 TEMP = ABS( A( I+J*LDA ) ) 2905 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2906 $ VALUE = TEMP 2907 END DO 2908 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2909 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2910 $ VALUE = TEMP 2911 I = N 2912 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2913 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2914 $ VALUE = TEMP 2915 END IF 2916 ELSE 2917 IF( ILU.EQ.1 ) THEN 2918 J = 0 2919 TEMP = ABS( REAL( A( J+J*LDA ) ) ) 2920 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2921 $ VALUE = TEMP 2922 DO I = 1, K - 1 2923 TEMP = ABS( A( I+J*LDA ) ) 2924 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2925 $ VALUE = TEMP 2926 END DO 2927 DO J = 1, K - 1 2928 DO I = 0, J - 2 2929 TEMP = ABS( A( I+J*LDA ) ) 2930 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2931 $ VALUE = TEMP 2932 END DO 2933 I = J - 1 2934 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2935 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2936 $ VALUE = TEMP 2937 I = J 2938 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2939 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2940 $ VALUE = TEMP 2941 DO I = J + 1, K - 1 2942 TEMP = ABS( A( I+J*LDA ) ) 2943 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2944 $ VALUE = TEMP 2945 END DO 2946 END DO 2947 J = K 2948 DO I = 0, K - 2 2949 TEMP = ABS( A( I+J*LDA ) ) 2950 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2951 $ VALUE = TEMP 2952 END DO 2953 I = K - 1 2954 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2955 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2956 $ VALUE = TEMP 2957 DO J = K + 1, N 2958 DO I = 0, K - 1 2959 TEMP = ABS( A( I+J*LDA ) ) 2960 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2961 $ VALUE = TEMP 2962 END DO 2963 END DO 2964 ELSE 2965 DO J = 0, K - 1 2966 DO I = 0, K - 1 2967 TEMP = ABS( A( I+J*LDA ) ) 2968 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2969 $ VALUE = TEMP 2970 END DO 2971 END DO 2972 J = K 2973 TEMP = ABS( REAL( A( 0+J*LDA ) ) ) 2974 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2975 $ VALUE = TEMP 2976 DO I = 1, K - 1 2977 TEMP = ABS( A( I+J*LDA ) ) 2978 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2979 $ VALUE = TEMP 2980 END DO 2981 DO J = K + 1, N - 1 2982 DO I = 0, J - K - 2 2983 TEMP = ABS( A( I+J*LDA ) ) 2984 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2985 $ VALUE = TEMP 2986 END DO 2987 I = J - K - 1 2988 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2989 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2990 $ VALUE = TEMP 2991 I = J - K 2992 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 2993 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2994 $ VALUE = TEMP 2995 DO I = J - K + 1, K - 1 2996 TEMP = ABS( A( I+J*LDA ) ) 2997 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 2998 $ VALUE = TEMP 2999 END DO 3000 END DO 3001 J = N 3002 DO I = 0, K - 2 3003 TEMP = ABS( A( I+J*LDA ) ) 3004 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 3005 $ VALUE = TEMP 3006 END DO 3007 I = K - 1 3008 TEMP = ABS( REAL( A( I+J*LDA ) ) ) 3009 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 3010 $ VALUE = TEMP 3011 END IF 3012 END IF 3013 END IF 3014 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 3015 $ ( NORM.EQ.'1' ) ) THEN 3016 IF( IFM.EQ.1 ) THEN 3017 K = N / 2 3018 IF( NOE.EQ.1 ) THEN 3019 IF( ILU.EQ.0 ) THEN 3020 DO I = 0, K - 1 3021 WORK( I ) = ZERO 3022 END DO 3023 DO J = 0, K 3024 S = ZERO 3025 DO I = 0, K + J - 1 3026 AA = ABS( A( I+J*LDA ) ) 3027 S = S + AA 3028 WORK( I ) = WORK( I ) + AA 3029 END DO 3030 AA = ABS( REAL( A( I+J*LDA ) ) ) 3031 WORK( J+K ) = S + AA 3032 IF( I.EQ.K+K ) 3033 $ GO TO 10 3034 I = I + 1 3035 AA = ABS( REAL( A( I+J*LDA ) ) ) 3036 WORK( J ) = WORK( J ) + AA 3037 S = ZERO 3038 DO L = J + 1, K - 1 3039 I = I + 1 3040 AA = ABS( A( I+J*LDA ) ) 3041 S = S + AA 3042 WORK( L ) = WORK( L ) + AA 3043 END DO 3044 WORK( J ) = WORK( J ) + S 3045 END DO 3046 10 CONTINUE 3047 VALUE = WORK( 0 ) 3048 DO I = 1, N-1 3049 TEMP = WORK( I ) 3050 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 3051 $ VALUE = TEMP 3052 END DO 3053 ELSE 3054 K = K + 1 3055 DO I = K, N - 1 3056 WORK( I ) = ZERO 3057 END DO 3058 DO J = K - 1, 0, -1 3059 S = ZERO 3060 DO I = 0, J - 2 3061 AA = ABS( A( I+J*LDA ) ) 3062 S = S + AA 3063 WORK( I+K ) = WORK( I+K ) + AA 3064 END DO 3065 IF( J.GT.0 ) THEN 3066 AA = ABS( REAL( A( I+J*LDA ) ) ) 3067 S = S + AA 3068 WORK( I+K ) = WORK( I+K ) + S 3069 I = I + 1 3070 END IF 3071 AA = ABS( REAL( A( I+J*LDA ) ) ) 3072 WORK( J ) = AA 3073 S = ZERO 3074 DO L = J + 1, N - 1 3075 I = I + 1 3076 AA = ABS( A( I+J*LDA ) ) 3077 S = S + AA 3078 WORK( L ) = WORK( L ) + AA 3079 END DO 3080 WORK( J ) = WORK( J ) + S 3081 END DO 3082 VALUE = WORK( 0 ) 3083 DO I = 1, N-1 3084 TEMP = WORK( I ) 3085 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 3086 $ VALUE = TEMP 3087 END DO 3088 END IF 3089 ELSE 3090 IF( ILU.EQ.0 ) THEN 3091 DO I = 0, K - 1 3092 WORK( I ) = ZERO 3093 END DO 3094 DO J = 0, K - 1 3095 S = ZERO 3096 DO I = 0, K + J - 1 3097 AA = ABS( A( I+J*LDA ) ) 3098 S = S + AA 3099 WORK( I ) = WORK( I ) + AA 3100 END DO 3101 AA = ABS( REAL( A( I+J*LDA ) ) ) 3102 WORK( J+K ) = S + AA 3103 I = I + 1 3104 AA = ABS( REAL( A( I+J*LDA ) ) ) 3105 WORK( J ) = WORK( J ) + AA 3106 S = ZERO 3107 DO L = J + 1, K - 1 3108 I = I + 1 3109 AA = ABS( A( I+J*LDA ) ) 3110 S = S + AA 3111 WORK( L ) = WORK( L ) + AA 3112 END DO 3113 WORK( J ) = WORK( J ) + S 3114 END DO 3115 VALUE = WORK( 0 ) 3116 DO I = 1, N-1 3117 TEMP = WORK( I ) 3118 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 3119 $ VALUE = TEMP 3120 END DO 3121 ELSE 3122 DO I = K, N - 1 3123 WORK( I ) = ZERO 3124 END DO 3125 DO J = K - 1, 0, -1 3126 S = ZERO 3127 DO I = 0, J - 1 3128 AA = ABS( A( I+J*LDA ) ) 3129 S = S + AA 3130 WORK( I+K ) = WORK( I+K ) + AA 3131 END DO 3132 AA = ABS( REAL( A( I+J*LDA ) ) ) 3133 S = S + AA 3134 WORK( I+K ) = WORK( I+K ) + S 3135 I = I + 1 3136 AA = ABS( REAL( A( I+J*LDA ) ) ) 3137 WORK( J ) = AA 3138 S = ZERO 3139 DO L = J + 1, N - 1 3140 I = I + 1 3141 AA = ABS( A( I+J*LDA ) ) 3142 S = S + AA 3143 WORK( L ) = WORK( L ) + AA 3144 END DO 3145 WORK( J ) = WORK( J ) + S 3146 END DO 3147 VALUE = WORK( 0 ) 3148 DO I = 1, N-1 3149 TEMP = WORK( I ) 3150 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 3151 $ VALUE = TEMP 3152 END DO 3153 END IF 3154 END IF 3155 ELSE 3156 K = N / 2 3157 IF( NOE.EQ.1 ) THEN 3158 IF( ILU.EQ.0 ) THEN 3159 N1 = K 3160 K = K + 1 3161 DO I = N1, N - 1 3162 WORK( I ) = ZERO 3163 END DO 3164 DO J = 0, N1 - 1 3165 S = ZERO 3166 DO I = 0, K - 1 3167 AA = ABS( A( I+J*LDA ) ) 3168 WORK( I+N1 ) = WORK( I+N1 ) + AA 3169 S = S + AA 3170 END DO 3171 WORK( J ) = S 3172 END DO 3173 S = ABS( REAL( A( 0+J*LDA ) ) ) 3174 DO I = 1, K - 1 3175 AA = ABS( A( I+J*LDA ) ) 3176 WORK( I+N1 ) = WORK( I+N1 ) + AA 3177 S = S + AA 3178 END DO 3179 WORK( J ) = WORK( J ) + S 3180 DO J = K, N - 1 3181 S = ZERO 3182 DO I = 0, J - K - 1 3183 AA = ABS( A( I+J*LDA ) ) 3184 WORK( I ) = WORK( I ) + AA 3185 S = S + AA 3186 END DO 3187 AA = ABS( REAL( A( I+J*LDA ) ) ) 3188 S = S + AA 3189 WORK( J-K ) = WORK( J-K ) + S 3190 I = I + 1 3191 S = ABS( REAL( A( I+J*LDA ) ) ) 3192 DO L = J + 1, N - 1 3193 I = I + 1 3194 AA = ABS( A( I+J*LDA ) ) 3195 WORK( L ) = WORK( L ) + AA 3196 S = S + AA 3197 END DO 3198 WORK( J ) = WORK( J ) + S 3199 END DO 3200 VALUE = WORK( 0 ) 3201 DO I = 1, N-1 3202 TEMP = WORK( I ) 3203 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 3204 $ VALUE = TEMP 3205 END DO 3206 ELSE 3207 K = K + 1 3208 DO I = K, N - 1 3209 WORK( I ) = ZERO 3210 END DO 3211 DO J = 0, K - 2 3212 S = ZERO 3213 DO I = 0, J - 1 3214 AA = ABS( A( I+J*LDA ) ) 3215 WORK( I ) = WORK( I ) + AA 3216 S = S + AA 3217 END DO 3218 AA = ABS( REAL( A( I+J*LDA ) ) ) 3219 S = S + AA 3220 WORK( J ) = S 3221 I = I + 1 3222 AA = ABS( REAL( A( I+J*LDA ) ) ) 3223 S = AA 3224 DO L = K + J + 1, N - 1 3225 I = I + 1 3226 AA = ABS( A( I+J*LDA ) ) 3227 S = S + AA 3228 WORK( L ) = WORK( L ) + AA 3229 END DO 3230 WORK( K+J ) = WORK( K+J ) + S 3231 END DO 3232 S = ZERO 3233 DO I = 0, K - 2 3234 AA = ABS( A( I+J*LDA ) ) 3235 WORK( I ) = WORK( I ) + AA 3236 S = S + AA 3237 END DO 3238 AA = ABS( REAL( A( I+J*LDA ) ) ) 3239 S = S + AA 3240 WORK( I ) = S 3241 DO J = K, N - 1 3242 S = ZERO 3243 DO I = 0, K - 1 3244 AA = ABS( A( I+J*LDA ) ) 3245 WORK( I ) = WORK( I ) + AA 3246 S = S + AA 3247 END DO 3248 WORK( J ) = WORK( J ) + S 3249 END DO 3250 VALUE = WORK( 0 ) 3251 DO I = 1, N-1 3252 TEMP = WORK( I ) 3253 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 3254 $ VALUE = TEMP 3255 END DO 3256 END IF 3257 ELSE 3258 IF( ILU.EQ.0 ) THEN 3259 DO I = K, N - 1 3260 WORK( I ) = ZERO 3261 END DO 3262 DO J = 0, K - 1 3263 S = ZERO 3264 DO I = 0, K - 1 3265 AA = ABS( A( I+J*LDA ) ) 3266 WORK( I+K ) = WORK( I+K ) + AA 3267 S = S + AA 3268 END DO 3269 WORK( J ) = S 3270 END DO 3271 AA = ABS( REAL( A( 0+J*LDA ) ) ) 3272 S = AA 3273 DO I = 1, K - 1 3274 AA = ABS( A( I+J*LDA ) ) 3275 WORK( I+K ) = WORK( I+K ) + AA 3276 S = S + AA 3277 END DO 3278 WORK( J ) = WORK( J ) + S 3279 DO J = K + 1, N - 1 3280 S = ZERO 3281 DO I = 0, J - 2 - K 3282 AA = ABS( A( I+J*LDA ) ) 3283 WORK( I ) = WORK( I ) + AA 3284 S = S + AA 3285 END DO 3286 AA = ABS( REAL( A( I+J*LDA ) ) ) 3287 S = S + AA 3288 WORK( J-K-1 ) = WORK( J-K-1 ) + S 3289 I = I + 1 3290 AA = ABS( REAL( A( I+J*LDA ) ) ) 3291 S = AA 3292 DO L = J + 1, N - 1 3293 I = I + 1 3294 AA = ABS( A( I+J*LDA ) ) 3295 WORK( L ) = WORK( L ) + AA 3296 S = S + AA 3297 END DO 3298 WORK( J ) = WORK( J ) + S 3299 END DO 3300 S = ZERO 3301 DO I = 0, K - 2 3302 AA = ABS( A( I+J*LDA ) ) 3303 WORK( I ) = WORK( I ) + AA 3304 S = S + AA 3305 END DO 3306 AA = ABS( REAL( A( I+J*LDA ) ) ) 3307 S = S + AA 3308 WORK( I ) = WORK( I ) + S 3309 VALUE = WORK( 0 ) 3310 DO I = 1, N-1 3311 TEMP = WORK( I ) 3312 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 3313 $ VALUE = TEMP 3314 END DO 3315 ELSE 3316 DO I = K, N - 1 3317 WORK( I ) = ZERO 3318 END DO 3319 S = ABS( REAL( A( 0 ) ) ) 3320 DO I = 1, K - 1 3321 AA = ABS( A( I ) ) 3322 WORK( I+K ) = WORK( I+K ) + AA 3323 S = S + AA 3324 END DO 3325 WORK( K ) = WORK( K ) + S 3326 DO J = 1, K - 1 3327 S = ZERO 3328 DO I = 0, J - 2 3329 AA = ABS( A( I+J*LDA ) ) 3330 WORK( I ) = WORK( I ) + AA 3331 S = S + AA 3332 END DO 3333 AA = ABS( REAL( A( I+J*LDA ) ) ) 3334 S = S + AA 3335 WORK( J-1 ) = S 3336 I = I + 1 3337 AA = ABS( REAL( A( I+J*LDA ) ) ) 3338 S = AA 3339 DO L = K + J + 1, N - 1 3340 I = I + 1 3341 AA = ABS( A( I+J*LDA ) ) 3342 S = S + AA 3343 WORK( L ) = WORK( L ) + AA 3344 END DO 3345 WORK( K+J ) = WORK( K+J ) + S 3346 END DO 3347 S = ZERO 3348 DO I = 0, K - 2 3349 AA = ABS( A( I+J*LDA ) ) 3350 WORK( I ) = WORK( I ) + AA 3351 S = S + AA 3352 END DO 3353 AA = ABS( REAL( A( I+J*LDA ) ) ) 3354 S = S + AA 3355 WORK( I ) = S 3356 DO J = K + 1, N 3357 S = ZERO 3358 DO I = 0, K - 1 3359 AA = ABS( A( I+J*LDA ) ) 3360 WORK( I ) = WORK( I ) + AA 3361 S = S + AA 3362 END DO 3363 WORK( J-1 ) = WORK( J-1 ) + S 3364 END DO 3365 VALUE = WORK( 0 ) 3366 DO I = 1, N-1 3367 TEMP = WORK( I ) 3368 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 3369 $ VALUE = TEMP 3370 END DO 3371 END IF 3372 END IF 3373 END IF 3374 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 3375 K = ( N+1 ) / 2 3376 SCALE = ZERO 3377 S = ONE 3378 IF( NOE.EQ.1 ) THEN 3379 IF( IFM.EQ.1 ) THEN 3380 IF( ILU.EQ.0 ) THEN 3381 DO J = 0, K - 3 3382 CALL CLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S ) 3383 END DO 3384 DO J = 0, K - 1 3385 CALL CLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S ) 3386 END DO 3387 S = S + S 3388 L = K - 1 3389 DO I = 0, K - 2 3390 AA = REAL( A( L ) ) 3391 IF( AA.NE.ZERO ) THEN 3392 IF( SCALE.LT.AA ) THEN 3393 S = ONE + S*( SCALE / AA )**2 3394 SCALE = AA 3395 ELSE 3396 S = S + ( AA / SCALE )**2 3397 END IF 3398 END IF 3399 AA = REAL( A( L+1 ) ) 3400 IF( AA.NE.ZERO ) THEN 3401 IF( SCALE.LT.AA ) THEN 3402 S = ONE + S*( SCALE / AA )**2 3403 SCALE = AA 3404 ELSE 3405 S = S + ( AA / SCALE )**2 3406 END IF 3407 END IF 3408 L = L + LDA + 1 3409 END DO 3410 AA = REAL( A( L ) ) 3411 IF( AA.NE.ZERO ) THEN 3412 IF( SCALE.LT.AA ) THEN 3413 S = ONE + S*( SCALE / AA )**2 3414 SCALE = AA 3415 ELSE 3416 S = S + ( AA / SCALE )**2 3417 END IF 3418 END IF 3419 ELSE 3420 DO J = 0, K - 1 3421 CALL CLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S ) 3422 END DO 3423 DO J = 1, K - 2 3424 CALL CLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S ) 3425 END DO 3426 S = S + S 3427 AA = REAL( A( 0 ) ) 3428 IF( AA.NE.ZERO ) THEN 3429 IF( SCALE.LT.AA ) THEN 3430 S = ONE + S*( SCALE / AA )**2 3431 SCALE = AA 3432 ELSE 3433 S = S + ( AA / SCALE )**2 3434 END IF 3435 END IF 3436 L = LDA 3437 DO I = 1, K - 1 3438 AA = REAL( A( L ) ) 3439 IF( AA.NE.ZERO ) THEN 3440 IF( SCALE.LT.AA ) THEN 3441 S = ONE + S*( SCALE / AA )**2 3442 SCALE = AA 3443 ELSE 3444 S = S + ( AA / SCALE )**2 3445 END IF 3446 END IF 3447 AA = REAL( A( L+1 ) ) 3448 IF( AA.NE.ZERO ) THEN 3449 IF( SCALE.LT.AA ) THEN 3450 S = ONE + S*( SCALE / AA )**2 3451 SCALE = AA 3452 ELSE 3453 S = S + ( AA / SCALE )**2 3454 END IF 3455 END IF 3456 L = L + LDA + 1 3457 END DO 3458 END IF 3459 ELSE 3460 IF( ILU.EQ.0 ) THEN 3461 DO J = 1, K - 2 3462 CALL CLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S ) 3463 END DO 3464 DO J = 0, K - 2 3465 CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 3466 END DO 3467 DO J = 0, K - 2 3468 CALL CLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1, 3469 $ SCALE, S ) 3470 END DO 3471 S = S + S 3472 L = 0 + K*LDA - LDA 3473 AA = REAL( A( L ) ) 3474 IF( AA.NE.ZERO ) THEN 3475 IF( SCALE.LT.AA ) THEN 3476 S = ONE + S*( SCALE / AA )**2 3477 SCALE = AA 3478 ELSE 3479 S = S + ( AA / SCALE )**2 3480 END IF 3481 END IF 3482 L = L + LDA 3483 DO J = K, N - 1 3484 AA = REAL( A( L ) ) 3485 IF( AA.NE.ZERO ) THEN 3486 IF( SCALE.LT.AA ) THEN 3487 S = ONE + S*( SCALE / AA )**2 3488 SCALE = AA 3489 ELSE 3490 S = S + ( AA / SCALE )**2 3491 END IF 3492 END IF 3493 AA = REAL( A( L+1 ) ) 3494 IF( AA.NE.ZERO ) THEN 3495 IF( SCALE.LT.AA ) THEN 3496 S = ONE + S*( SCALE / AA )**2 3497 SCALE = AA 3498 ELSE 3499 S = S + ( AA / SCALE )**2 3500 END IF 3501 END IF 3502 L = L + LDA + 1 3503 END DO 3504 ELSE 3505 DO J = 1, K - 1 3506 CALL CLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) 3507 END DO 3508 DO J = K, N - 1 3509 CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 3510 END DO 3511 DO J = 0, K - 3 3512 CALL CLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S ) 3513 END DO 3514 S = S + S 3515 L = 0 3516 DO I = 0, K - 2 3517 AA = REAL( A( L ) ) 3518 IF( AA.NE.ZERO ) THEN 3519 IF( SCALE.LT.AA ) THEN 3520 S = ONE + S*( SCALE / AA )**2 3521 SCALE = AA 3522 ELSE 3523 S = S + ( AA / SCALE )**2 3524 END IF 3525 END IF 3526 AA = REAL( A( L+1 ) ) 3527 IF( AA.NE.ZERO ) THEN 3528 IF( SCALE.LT.AA ) THEN 3529 S = ONE + S*( SCALE / AA )**2 3530 SCALE = AA 3531 ELSE 3532 S = S + ( AA / SCALE )**2 3533 END IF 3534 END IF 3535 L = L + LDA + 1 3536 END DO 3537 AA = REAL( A( L ) ) 3538 IF( AA.NE.ZERO ) THEN 3539 IF( SCALE.LT.AA ) THEN 3540 S = ONE + S*( SCALE / AA )**2 3541 SCALE = AA 3542 ELSE 3543 S = S + ( AA / SCALE )**2 3544 END IF 3545 END IF 3546 END IF 3547 END IF 3548 ELSE 3549 IF( IFM.EQ.1 ) THEN 3550 IF( ILU.EQ.0 ) THEN 3551 DO J = 0, K - 2 3552 CALL CLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S ) 3553 END DO 3554 DO J = 0, K - 1 3555 CALL CLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S ) 3556 END DO 3557 S = S + S 3558 L = K 3559 DO I = 0, K - 1 3560 AA = REAL( A( L ) ) 3561 IF( AA.NE.ZERO ) THEN 3562 IF( SCALE.LT.AA ) THEN 3563 S = ONE + S*( SCALE / AA )**2 3564 SCALE = AA 3565 ELSE 3566 S = S + ( AA / SCALE )**2 3567 END IF 3568 END IF 3569 AA = REAL( A( L+1 ) ) 3570 IF( AA.NE.ZERO ) THEN 3571 IF( SCALE.LT.AA ) THEN 3572 S = ONE + S*( SCALE / AA )**2 3573 SCALE = AA 3574 ELSE 3575 S = S + ( AA / SCALE )**2 3576 END IF 3577 END IF 3578 L = L + LDA + 1 3579 END DO 3580 ELSE 3581 DO J = 0, K - 1 3582 CALL CLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S ) 3583 END DO 3584 DO J = 1, K - 1 3585 CALL CLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) 3586 END DO 3587 S = S + S 3588 L = 0 3589 DO I = 0, K - 1 3590 AA = REAL( A( L ) ) 3591 IF( AA.NE.ZERO ) THEN 3592 IF( SCALE.LT.AA ) THEN 3593 S = ONE + S*( SCALE / AA )**2 3594 SCALE = AA 3595 ELSE 3596 S = S + ( AA / SCALE )**2 3597 END IF 3598 END IF 3599 AA = REAL( A( L+1 ) ) 3600 IF( AA.NE.ZERO ) THEN 3601 IF( SCALE.LT.AA ) THEN 3602 S = ONE + S*( SCALE / AA )**2 3603 SCALE = AA 3604 ELSE 3605 S = S + ( AA / SCALE )**2 3606 END IF 3607 END IF 3608 L = L + LDA + 1 3609 END DO 3610 END IF 3611 ELSE 3612 IF( ILU.EQ.0 ) THEN 3613 DO J = 1, K - 1 3614 CALL CLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S ) 3615 END DO 3616 DO J = 0, K - 1 3617 CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 3618 END DO 3619 DO J = 0, K - 2 3620 CALL CLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE, 3621 $ S ) 3622 END DO 3623 S = S + S 3624 L = 0 + K*LDA 3625 AA = REAL( A( L ) ) 3626 IF( AA.NE.ZERO ) THEN 3627 IF( SCALE.LT.AA ) THEN 3628 S = ONE + S*( SCALE / AA )**2 3629 SCALE = AA 3630 ELSE 3631 S = S + ( AA / SCALE )**2 3632 END IF 3633 END IF 3634 L = L + LDA 3635 DO J = K + 1, N - 1 3636 AA = REAL( A( L ) ) 3637 IF( AA.NE.ZERO ) THEN 3638 IF( SCALE.LT.AA ) THEN 3639 S = ONE + S*( SCALE / AA )**2 3640 SCALE = AA 3641 ELSE 3642 S = S + ( AA / SCALE )**2 3643 END IF 3644 END IF 3645 AA = REAL( A( L+1 ) ) 3646 IF( AA.NE.ZERO ) THEN 3647 IF( SCALE.LT.AA ) THEN 3648 S = ONE + S*( SCALE / AA )**2 3649 SCALE = AA 3650 ELSE 3651 S = S + ( AA / SCALE )**2 3652 END IF 3653 END IF 3654 L = L + LDA + 1 3655 END DO 3656 AA = REAL( A( L ) ) 3657 IF( AA.NE.ZERO ) THEN 3658 IF( SCALE.LT.AA ) THEN 3659 S = ONE + S*( SCALE / AA )**2 3660 SCALE = AA 3661 ELSE 3662 S = S + ( AA / SCALE )**2 3663 END IF 3664 END IF 3665 ELSE 3666 DO J = 1, K - 1 3667 CALL CLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S ) 3668 END DO 3669 DO J = K + 1, N 3670 CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 3671 END DO 3672 DO J = 0, K - 2 3673 CALL CLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S ) 3674 END DO 3675 S = S + S 3676 L = 0 3677 AA = REAL( A( L ) ) 3678 IF( AA.NE.ZERO ) THEN 3679 IF( SCALE.LT.AA ) THEN 3680 S = ONE + S*( SCALE / AA )**2 3681 SCALE = AA 3682 ELSE 3683 S = S + ( AA / SCALE )**2 3684 END IF 3685 END IF 3686 L = LDA 3687 DO I = 0, K - 2 3688 AA = REAL( A( L ) ) 3689 IF( AA.NE.ZERO ) THEN 3690 IF( SCALE.LT.AA ) THEN 3691 S = ONE + S*( SCALE / AA )**2 3692 SCALE = AA 3693 ELSE 3694 S = S + ( AA / SCALE )**2 3695 END IF 3696 END IF 3697 AA = REAL( A( L+1 ) ) 3698 IF( AA.NE.ZERO ) THEN 3699 IF( SCALE.LT.AA ) THEN 3700 S = ONE + S*( SCALE / AA )**2 3701 SCALE = AA 3702 ELSE 3703 S = S + ( AA / SCALE )**2 3704 END IF 3705 END IF 3706 L = L + LDA + 1 3707 END DO 3708 AA = REAL( A( L ) ) 3709 IF( AA.NE.ZERO ) THEN 3710 IF( SCALE.LT.AA ) THEN 3711 S = ONE + S*( SCALE / AA )**2 3712 SCALE = AA 3713 ELSE 3714 S = S + ( AA / SCALE )**2 3715 END IF 3716 END IF 3717 END IF 3718 END IF 3719 END IF 3720 VALUE = SCALE*SQRT( S ) 3721 END IF 3722 CLANHF = VALUE 3723 RETURN 3724 END 3725! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clanhp.f 3726 REAL FUNCTION CLANHP( NORM, UPLO, N, AP, WORK ) 3727 IMPLICIT NONE 3728 CHARACTER NORM, UPLO 3729 INTEGER N 3730 REAL WORK( * ) 3731 COMPLEX AP( * ) 3732 REAL ONE, ZERO 3733 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 3734 INTEGER I, J, K 3735 REAL ABSA, SUM, VALUE 3736 REAL SSQ( 2 ), COLSSQ( 2 ) 3737 LOGICAL LSAME, SISNAN 3738 EXTERNAL LSAME, SISNAN 3739 EXTERNAL CLASSQ, SCOMBSSQ 3740 INTRINSIC ABS, REAL, SQRT 3741 IF( N.EQ.0 ) THEN 3742 VALUE = ZERO 3743 ELSE IF( LSAME( NORM, 'M' ) ) THEN 3744 VALUE = ZERO 3745 IF( LSAME( UPLO, 'U' ) ) THEN 3746 K = 0 3747 DO 20 J = 1, N 3748 DO 10 I = K + 1, K + J - 1 3749 SUM = ABS( AP( I ) ) 3750 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 3751 10 CONTINUE 3752 K = K + J 3753 SUM = ABS( REAL( AP( K ) ) ) 3754 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 3755 20 CONTINUE 3756 ELSE 3757 K = 1 3758 DO 40 J = 1, N 3759 SUM = ABS( REAL( AP( K ) ) ) 3760 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 3761 DO 30 I = K + 1, K + N - J 3762 SUM = ABS( AP( I ) ) 3763 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 3764 30 CONTINUE 3765 K = K + N - J + 1 3766 40 CONTINUE 3767 END IF 3768 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 3769 $ ( NORM.EQ.'1' ) ) THEN 3770 VALUE = ZERO 3771 K = 1 3772 IF( LSAME( UPLO, 'U' ) ) THEN 3773 DO 60 J = 1, N 3774 SUM = ZERO 3775 DO 50 I = 1, J - 1 3776 ABSA = ABS( AP( K ) ) 3777 SUM = SUM + ABSA 3778 WORK( I ) = WORK( I ) + ABSA 3779 K = K + 1 3780 50 CONTINUE 3781 WORK( J ) = SUM + ABS( REAL( AP( K ) ) ) 3782 K = K + 1 3783 60 CONTINUE 3784 DO 70 I = 1, N 3785 SUM = WORK( I ) 3786 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 3787 70 CONTINUE 3788 ELSE 3789 DO 80 I = 1, N 3790 WORK( I ) = ZERO 3791 80 CONTINUE 3792 DO 100 J = 1, N 3793 SUM = WORK( J ) + ABS( REAL( AP( K ) ) ) 3794 K = K + 1 3795 DO 90 I = J + 1, N 3796 ABSA = ABS( AP( K ) ) 3797 SUM = SUM + ABSA 3798 WORK( I ) = WORK( I ) + ABSA 3799 K = K + 1 3800 90 CONTINUE 3801 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 3802 100 CONTINUE 3803 END IF 3804 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 3805 SSQ( 1 ) = ZERO 3806 SSQ( 2 ) = ONE 3807 K = 2 3808 IF( LSAME( UPLO, 'U' ) ) THEN 3809 DO 110 J = 2, N 3810 COLSSQ( 1 ) = ZERO 3811 COLSSQ( 2 ) = ONE 3812 CALL CLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 3813 CALL SCOMBSSQ( SSQ, COLSSQ ) 3814 K = K + J 3815 110 CONTINUE 3816 ELSE 3817 DO 120 J = 1, N - 1 3818 COLSSQ( 1 ) = ZERO 3819 COLSSQ( 2 ) = ONE 3820 CALL CLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 3821 CALL SCOMBSSQ( SSQ, COLSSQ ) 3822 K = K + N - J + 1 3823 120 CONTINUE 3824 END IF 3825 SSQ( 2 ) = 2*SSQ( 2 ) 3826 K = 1 3827 COLSSQ( 1 ) = ZERO 3828 COLSSQ( 2 ) = ONE 3829 DO 130 I = 1, N 3830 IF( REAL( AP( K ) ).NE.ZERO ) THEN 3831 ABSA = ABS( REAL( AP( K ) ) ) 3832 IF( COLSSQ( 1 ).LT.ABSA ) THEN 3833 COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 3834 COLSSQ( 1 ) = ABSA 3835 ELSE 3836 COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 3837 END IF 3838 END IF 3839 IF( LSAME( UPLO, 'U' ) ) THEN 3840 K = K + I + 1 3841 ELSE 3842 K = K + N - I + 1 3843 END IF 3844 130 CONTINUE 3845 CALL SCOMBSSQ( SSQ, COLSSQ ) 3846 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 3847 END IF 3848 CLANHP = VALUE 3849 RETURN 3850 END 3851! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clanhs.f 3852 REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK ) 3853 IMPLICIT NONE 3854 CHARACTER NORM 3855 INTEGER LDA, N 3856 REAL WORK( * ) 3857 COMPLEX A( LDA, * ) 3858 REAL ONE, ZERO 3859 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 3860 INTEGER I, J 3861 REAL SUM, VALUE 3862 REAL SSQ( 2 ), COLSSQ( 2 ) 3863 LOGICAL LSAME, SISNAN 3864 EXTERNAL LSAME, SISNAN 3865 EXTERNAL CLASSQ, SCOMBSSQ 3866 INTRINSIC ABS, MIN, SQRT 3867 IF( N.EQ.0 ) THEN 3868 VALUE = ZERO 3869 ELSE IF( LSAME( NORM, 'M' ) ) THEN 3870 VALUE = ZERO 3871 DO 20 J = 1, N 3872 DO 10 I = 1, MIN( N, J+1 ) 3873 SUM = ABS( A( I, J ) ) 3874 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 3875 10 CONTINUE 3876 20 CONTINUE 3877 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 3878 VALUE = ZERO 3879 DO 40 J = 1, N 3880 SUM = ZERO 3881 DO 30 I = 1, MIN( N, J+1 ) 3882 SUM = SUM + ABS( A( I, J ) ) 3883 30 CONTINUE 3884 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 3885 40 CONTINUE 3886 ELSE IF( LSAME( NORM, 'I' ) ) THEN 3887 DO 50 I = 1, N 3888 WORK( I ) = ZERO 3889 50 CONTINUE 3890 DO 70 J = 1, N 3891 DO 60 I = 1, MIN( N, J+1 ) 3892 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 3893 60 CONTINUE 3894 70 CONTINUE 3895 VALUE = ZERO 3896 DO 80 I = 1, N 3897 SUM = WORK( I ) 3898 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 3899 80 CONTINUE 3900 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 3901 SSQ( 1 ) = ZERO 3902 SSQ( 2 ) = ONE 3903 DO 90 J = 1, N 3904 COLSSQ( 1 ) = ZERO 3905 COLSSQ( 2 ) = ONE 3906 CALL CLASSQ( MIN( N, J+1 ), A( 1, J ), 1, 3907 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 3908 CALL SCOMBSSQ( SSQ, COLSSQ ) 3909 90 CONTINUE 3910 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 3911 END IF 3912 CLANHS = VALUE 3913 RETURN 3914 END 3915! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clanht.f 3916 REAL FUNCTION CLANHT( NORM, N, D, E ) 3917 CHARACTER NORM 3918 INTEGER N 3919 REAL D( * ) 3920 COMPLEX E( * ) 3921 REAL ONE, ZERO 3922 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 3923 INTEGER I 3924 REAL ANORM, SCALE, SUM 3925 LOGICAL LSAME, SISNAN 3926 EXTERNAL LSAME, SISNAN 3927 EXTERNAL CLASSQ, SLASSQ 3928 INTRINSIC ABS, SQRT 3929 IF( N.LE.0 ) THEN 3930 ANORM = ZERO 3931 ELSE IF( LSAME( NORM, 'M' ) ) THEN 3932 ANORM = ABS( D( N ) ) 3933 DO 10 I = 1, N - 1 3934 SUM = ABS( D( I ) ) 3935 IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM 3936 SUM = ABS( E( I ) ) 3937 IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM 3938 10 CONTINUE 3939 ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. 3940 $ LSAME( NORM, 'I' ) ) THEN 3941 IF( N.EQ.1 ) THEN 3942 ANORM = ABS( D( 1 ) ) 3943 ELSE 3944 ANORM = ABS( D( 1 ) )+ABS( E( 1 ) ) 3945 SUM = ABS( E( N-1 ) )+ABS( D( N ) ) 3946 IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM 3947 DO 20 I = 2, N - 1 3948 SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) ) 3949 IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM 3950 20 CONTINUE 3951 END IF 3952 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 3953 SCALE = ZERO 3954 SUM = ONE 3955 IF( N.GT.1 ) THEN 3956 CALL CLASSQ( N-1, E, 1, SCALE, SUM ) 3957 SUM = 2*SUM 3958 END IF 3959 CALL SLASSQ( N, D, 1, SCALE, SUM ) 3960 ANORM = SCALE*SQRT( SUM ) 3961 END IF 3962 CLANHT = ANORM 3963 RETURN 3964 END 3965! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clansb.f 3966 REAL FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB, 3967 $ WORK ) 3968 IMPLICIT NONE 3969 CHARACTER NORM, UPLO 3970 INTEGER K, LDAB, N 3971 REAL WORK( * ) 3972 COMPLEX AB( LDAB, * ) 3973 REAL ONE, ZERO 3974 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 3975 INTEGER I, J, L 3976 REAL ABSA, SUM, VALUE 3977 REAL SSQ( 2 ), COLSSQ( 2 ) 3978 LOGICAL LSAME, SISNAN 3979 EXTERNAL LSAME, SISNAN 3980 EXTERNAL CLASSQ, SCOMBSSQ 3981 INTRINSIC ABS, MAX, MIN, SQRT 3982 IF( N.EQ.0 ) THEN 3983 VALUE = ZERO 3984 ELSE IF( LSAME( NORM, 'M' ) ) THEN 3985 VALUE = ZERO 3986 IF( LSAME( UPLO, 'U' ) ) THEN 3987 DO 20 J = 1, N 3988 DO 10 I = MAX( K+2-J, 1 ), K + 1 3989 SUM = ABS( AB( I, J ) ) 3990 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 3991 10 CONTINUE 3992 20 CONTINUE 3993 ELSE 3994 DO 40 J = 1, N 3995 DO 30 I = 1, MIN( N+1-J, K+1 ) 3996 SUM = ABS( AB( I, J ) ) 3997 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 3998 30 CONTINUE 3999 40 CONTINUE 4000 END IF 4001 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 4002 $ ( NORM.EQ.'1' ) ) THEN 4003 VALUE = ZERO 4004 IF( LSAME( UPLO, 'U' ) ) THEN 4005 DO 60 J = 1, N 4006 SUM = ZERO 4007 L = K + 1 - J 4008 DO 50 I = MAX( 1, J-K ), J - 1 4009 ABSA = ABS( AB( L+I, J ) ) 4010 SUM = SUM + ABSA 4011 WORK( I ) = WORK( I ) + ABSA 4012 50 CONTINUE 4013 WORK( J ) = SUM + ABS( AB( K+1, J ) ) 4014 60 CONTINUE 4015 DO 70 I = 1, N 4016 SUM = WORK( I ) 4017 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4018 70 CONTINUE 4019 ELSE 4020 DO 80 I = 1, N 4021 WORK( I ) = ZERO 4022 80 CONTINUE 4023 DO 100 J = 1, N 4024 SUM = WORK( J ) + ABS( AB( 1, J ) ) 4025 L = 1 - J 4026 DO 90 I = J + 1, MIN( N, J+K ) 4027 ABSA = ABS( AB( L+I, J ) ) 4028 SUM = SUM + ABSA 4029 WORK( I ) = WORK( I ) + ABSA 4030 90 CONTINUE 4031 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4032 100 CONTINUE 4033 END IF 4034 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 4035 SSQ( 1 ) = ZERO 4036 SSQ( 2 ) = ONE 4037 IF( K.GT.0 ) THEN 4038 IF( LSAME( UPLO, 'U' ) ) THEN 4039 DO 110 J = 2, N 4040 COLSSQ( 1 ) = ZERO 4041 COLSSQ( 2 ) = ONE 4042 CALL CLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), 4043 $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 4044 CALL SCOMBSSQ( SSQ, COLSSQ ) 4045 110 CONTINUE 4046 L = K + 1 4047 ELSE 4048 DO 120 J = 1, N - 1 4049 COLSSQ( 1 ) = ZERO 4050 COLSSQ( 2 ) = ONE 4051 CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, 4052 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4053 CALL SCOMBSSQ( SSQ, COLSSQ ) 4054 120 CONTINUE 4055 L = 1 4056 END IF 4057 SSQ( 2 ) = 2*SSQ( 2 ) 4058 ELSE 4059 L = 1 4060 END IF 4061 COLSSQ( 1 ) = ZERO 4062 COLSSQ( 2 ) = ONE 4063 CALL CLASSQ( N, AB( L, 1 ), LDAB, COLSSQ( 1 ), COLSSQ( 2 ) ) 4064 CALL SCOMBSSQ( SSQ, COLSSQ ) 4065 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 4066 END IF 4067 CLANSB = VALUE 4068 RETURN 4069 END 4070! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clansp.f 4071 REAL FUNCTION CLANSP( NORM, UPLO, N, AP, WORK ) 4072 IMPLICIT NONE 4073 CHARACTER NORM, UPLO 4074 INTEGER N 4075 REAL WORK( * ) 4076 COMPLEX AP( * ) 4077 REAL ONE, ZERO 4078 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 4079 INTEGER I, J, K 4080 REAL ABSA, SUM, VALUE 4081 REAL SSQ( 2 ), COLSSQ( 2 ) 4082 LOGICAL LSAME, SISNAN 4083 EXTERNAL LSAME, SISNAN 4084 EXTERNAL CLASSQ, SCOMBSSQ 4085 INTRINSIC ABS, AIMAG, REAL, SQRT 4086 IF( N.EQ.0 ) THEN 4087 VALUE = ZERO 4088 ELSE IF( LSAME( NORM, 'M' ) ) THEN 4089 VALUE = ZERO 4090 IF( LSAME( UPLO, 'U' ) ) THEN 4091 K = 1 4092 DO 20 J = 1, N 4093 DO 10 I = K, K + J - 1 4094 SUM = ABS( AP( I ) ) 4095 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4096 10 CONTINUE 4097 K = K + J 4098 20 CONTINUE 4099 ELSE 4100 K = 1 4101 DO 40 J = 1, N 4102 DO 30 I = K, K + N - J 4103 SUM = ABS( AP( I ) ) 4104 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4105 30 CONTINUE 4106 K = K + N - J + 1 4107 40 CONTINUE 4108 END IF 4109 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 4110 $ ( NORM.EQ.'1' ) ) THEN 4111 VALUE = ZERO 4112 K = 1 4113 IF( LSAME( UPLO, 'U' ) ) THEN 4114 DO 60 J = 1, N 4115 SUM = ZERO 4116 DO 50 I = 1, J - 1 4117 ABSA = ABS( AP( K ) ) 4118 SUM = SUM + ABSA 4119 WORK( I ) = WORK( I ) + ABSA 4120 K = K + 1 4121 50 CONTINUE 4122 WORK( J ) = SUM + ABS( AP( K ) ) 4123 K = K + 1 4124 60 CONTINUE 4125 DO 70 I = 1, N 4126 SUM = WORK( I ) 4127 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4128 70 CONTINUE 4129 ELSE 4130 DO 80 I = 1, N 4131 WORK( I ) = ZERO 4132 80 CONTINUE 4133 DO 100 J = 1, N 4134 SUM = WORK( J ) + ABS( AP( K ) ) 4135 K = K + 1 4136 DO 90 I = J + 1, N 4137 ABSA = ABS( AP( K ) ) 4138 SUM = SUM + ABSA 4139 WORK( I ) = WORK( I ) + ABSA 4140 K = K + 1 4141 90 CONTINUE 4142 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4143 100 CONTINUE 4144 END IF 4145 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 4146 SSQ( 1 ) = ZERO 4147 SSQ( 2 ) = ONE 4148 K = 2 4149 IF( LSAME( UPLO, 'U' ) ) THEN 4150 DO 110 J = 2, N 4151 COLSSQ( 1 ) = ZERO 4152 COLSSQ( 2 ) = ONE 4153 CALL CLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 4154 CALL SCOMBSSQ( SSQ, COLSSQ ) 4155 K = K + J 4156 110 CONTINUE 4157 ELSE 4158 DO 120 J = 1, N - 1 4159 COLSSQ( 1 ) = ZERO 4160 COLSSQ( 2 ) = ONE 4161 CALL CLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 4162 CALL SCOMBSSQ( SSQ, COLSSQ ) 4163 K = K + N - J + 1 4164 120 CONTINUE 4165 END IF 4166 SSQ( 2 ) = 2*SSQ( 2 ) 4167 K = 1 4168 COLSSQ( 1 ) = ZERO 4169 COLSSQ( 2 ) = ONE 4170 DO 130 I = 1, N 4171 IF( REAL( AP( K ) ).NE.ZERO ) THEN 4172 ABSA = ABS( REAL( AP( K ) ) ) 4173 IF( COLSSQ( 1 ).LT.ABSA ) THEN 4174 COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 4175 COLSSQ( 1 ) = ABSA 4176 ELSE 4177 COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 4178 END IF 4179 END IF 4180 IF( AIMAG( AP( K ) ).NE.ZERO ) THEN 4181 ABSA = ABS( AIMAG( AP( K ) ) ) 4182 IF( COLSSQ( 1 ).LT.ABSA ) THEN 4183 COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 4184 COLSSQ( 1 ) = ABSA 4185 ELSE 4186 COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 4187 END IF 4188 END IF 4189 IF( LSAME( UPLO, 'U' ) ) THEN 4190 K = K + I + 1 4191 ELSE 4192 K = K + N - I + 1 4193 END IF 4194 130 CONTINUE 4195 CALL SCOMBSSQ( SSQ, COLSSQ ) 4196 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 4197 END IF 4198 CLANSP = VALUE 4199 RETURN 4200 END 4201! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clansy.f 4202 REAL FUNCTION CLANSY( NORM, UPLO, N, A, LDA, WORK ) 4203 IMPLICIT NONE 4204 CHARACTER NORM, UPLO 4205 INTEGER LDA, N 4206 REAL WORK( * ) 4207 COMPLEX A( LDA, * ) 4208 REAL ONE, ZERO 4209 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 4210 INTEGER I, J 4211 REAL ABSA, SUM, VALUE 4212 REAL SSQ( 2 ), COLSSQ( 2 ) 4213 LOGICAL LSAME, SISNAN 4214 EXTERNAL LSAME, SISNAN 4215 EXTERNAL CLASSQ, SCOMBSSQ 4216 INTRINSIC ABS, SQRT 4217 IF( N.EQ.0 ) THEN 4218 VALUE = ZERO 4219 ELSE IF( LSAME( NORM, 'M' ) ) THEN 4220 VALUE = ZERO 4221 IF( LSAME( UPLO, 'U' ) ) THEN 4222 DO 20 J = 1, N 4223 DO 10 I = 1, J 4224 SUM = ABS( A( I, J ) ) 4225 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4226 10 CONTINUE 4227 20 CONTINUE 4228 ELSE 4229 DO 40 J = 1, N 4230 DO 30 I = J, N 4231 SUM = ABS( A( I, J ) ) 4232 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4233 30 CONTINUE 4234 40 CONTINUE 4235 END IF 4236 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 4237 $ ( NORM.EQ.'1' ) ) THEN 4238 VALUE = ZERO 4239 IF( LSAME( UPLO, 'U' ) ) THEN 4240 DO 60 J = 1, N 4241 SUM = ZERO 4242 DO 50 I = 1, J - 1 4243 ABSA = ABS( A( I, J ) ) 4244 SUM = SUM + ABSA 4245 WORK( I ) = WORK( I ) + ABSA 4246 50 CONTINUE 4247 WORK( J ) = SUM + ABS( A( J, J ) ) 4248 60 CONTINUE 4249 DO 70 I = 1, N 4250 SUM = WORK( I ) 4251 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4252 70 CONTINUE 4253 ELSE 4254 DO 80 I = 1, N 4255 WORK( I ) = ZERO 4256 80 CONTINUE 4257 DO 100 J = 1, N 4258 SUM = WORK( J ) + ABS( A( J, J ) ) 4259 DO 90 I = J + 1, N 4260 ABSA = ABS( A( I, J ) ) 4261 SUM = SUM + ABSA 4262 WORK( I ) = WORK( I ) + ABSA 4263 90 CONTINUE 4264 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4265 100 CONTINUE 4266 END IF 4267 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 4268 SSQ( 1 ) = ZERO 4269 SSQ( 2 ) = ONE 4270 IF( LSAME( UPLO, 'U' ) ) THEN 4271 DO 110 J = 2, N 4272 COLSSQ( 1 ) = ZERO 4273 COLSSQ( 2 ) = ONE 4274 CALL CLASSQ( J-1, A( 1, J ), 1, COLSSQ(1), COLSSQ(2) ) 4275 CALL SCOMBSSQ( SSQ, COLSSQ ) 4276 110 CONTINUE 4277 ELSE 4278 DO 120 J = 1, N - 1 4279 COLSSQ( 1 ) = ZERO 4280 COLSSQ( 2 ) = ONE 4281 CALL CLASSQ( N-J, A( J+1, J ), 1, COLSSQ(1), COLSSQ(2) ) 4282 CALL SCOMBSSQ( SSQ, COLSSQ ) 4283 120 CONTINUE 4284 END IF 4285 SSQ( 2 ) = 2*SSQ( 2 ) 4286 COLSSQ( 1 ) = ZERO 4287 COLSSQ( 2 ) = ONE 4288 CALL CLASSQ( N, A, LDA+1, COLSSQ( 1 ), COLSSQ( 2 ) ) 4289 CALL SCOMBSSQ( SSQ, COLSSQ ) 4290 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 4291 END IF 4292 CLANSY = VALUE 4293 RETURN 4294 END 4295! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clantb.f 4296 REAL FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, 4297 $ LDAB, WORK ) 4298 IMPLICIT NONE 4299 CHARACTER DIAG, NORM, UPLO 4300 INTEGER K, LDAB, N 4301 REAL WORK( * ) 4302 COMPLEX AB( LDAB, * ) 4303 REAL ONE, ZERO 4304 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 4305 LOGICAL UDIAG 4306 INTEGER I, J, L 4307 REAL SUM, VALUE 4308 REAL SSQ( 2 ), COLSSQ( 2 ) 4309 LOGICAL LSAME, SISNAN 4310 EXTERNAL LSAME, SISNAN 4311 EXTERNAL CLASSQ, SCOMBSSQ 4312 INTRINSIC ABS, MAX, MIN, SQRT 4313 IF( N.EQ.0 ) THEN 4314 VALUE = ZERO 4315 ELSE IF( LSAME( NORM, 'M' ) ) THEN 4316 IF( LSAME( DIAG, 'U' ) ) THEN 4317 VALUE = ONE 4318 IF( LSAME( UPLO, 'U' ) ) THEN 4319 DO 20 J = 1, N 4320 DO 10 I = MAX( K+2-J, 1 ), K 4321 SUM = ABS( AB( I, J ) ) 4322 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4323 10 CONTINUE 4324 20 CONTINUE 4325 ELSE 4326 DO 40 J = 1, N 4327 DO 30 I = 2, MIN( N+1-J, K+1 ) 4328 SUM = ABS( AB( I, J ) ) 4329 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4330 30 CONTINUE 4331 40 CONTINUE 4332 END IF 4333 ELSE 4334 VALUE = ZERO 4335 IF( LSAME( UPLO, 'U' ) ) THEN 4336 DO 60 J = 1, N 4337 DO 50 I = MAX( K+2-J, 1 ), K + 1 4338 SUM = ABS( AB( I, J ) ) 4339 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4340 50 CONTINUE 4341 60 CONTINUE 4342 ELSE 4343 DO 80 J = 1, N 4344 DO 70 I = 1, MIN( N+1-J, K+1 ) 4345 SUM = ABS( AB( I, J ) ) 4346 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4347 70 CONTINUE 4348 80 CONTINUE 4349 END IF 4350 END IF 4351 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 4352 VALUE = ZERO 4353 UDIAG = LSAME( DIAG, 'U' ) 4354 IF( LSAME( UPLO, 'U' ) ) THEN 4355 DO 110 J = 1, N 4356 IF( UDIAG ) THEN 4357 SUM = ONE 4358 DO 90 I = MAX( K+2-J, 1 ), K 4359 SUM = SUM + ABS( AB( I, J ) ) 4360 90 CONTINUE 4361 ELSE 4362 SUM = ZERO 4363 DO 100 I = MAX( K+2-J, 1 ), K + 1 4364 SUM = SUM + ABS( AB( I, J ) ) 4365 100 CONTINUE 4366 END IF 4367 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4368 110 CONTINUE 4369 ELSE 4370 DO 140 J = 1, N 4371 IF( UDIAG ) THEN 4372 SUM = ONE 4373 DO 120 I = 2, MIN( N+1-J, K+1 ) 4374 SUM = SUM + ABS( AB( I, J ) ) 4375 120 CONTINUE 4376 ELSE 4377 SUM = ZERO 4378 DO 130 I = 1, MIN( N+1-J, K+1 ) 4379 SUM = SUM + ABS( AB( I, J ) ) 4380 130 CONTINUE 4381 END IF 4382 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4383 140 CONTINUE 4384 END IF 4385 ELSE IF( LSAME( NORM, 'I' ) ) THEN 4386 VALUE = ZERO 4387 IF( LSAME( UPLO, 'U' ) ) THEN 4388 IF( LSAME( DIAG, 'U' ) ) THEN 4389 DO 150 I = 1, N 4390 WORK( I ) = ONE 4391 150 CONTINUE 4392 DO 170 J = 1, N 4393 L = K + 1 - J 4394 DO 160 I = MAX( 1, J-K ), J - 1 4395 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 4396 160 CONTINUE 4397 170 CONTINUE 4398 ELSE 4399 DO 180 I = 1, N 4400 WORK( I ) = ZERO 4401 180 CONTINUE 4402 DO 200 J = 1, N 4403 L = K + 1 - J 4404 DO 190 I = MAX( 1, J-K ), J 4405 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 4406 190 CONTINUE 4407 200 CONTINUE 4408 END IF 4409 ELSE 4410 IF( LSAME( DIAG, 'U' ) ) THEN 4411 DO 210 I = 1, N 4412 WORK( I ) = ONE 4413 210 CONTINUE 4414 DO 230 J = 1, N 4415 L = 1 - J 4416 DO 220 I = J + 1, MIN( N, J+K ) 4417 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 4418 220 CONTINUE 4419 230 CONTINUE 4420 ELSE 4421 DO 240 I = 1, N 4422 WORK( I ) = ZERO 4423 240 CONTINUE 4424 DO 260 J = 1, N 4425 L = 1 - J 4426 DO 250 I = J, MIN( N, J+K ) 4427 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 4428 250 CONTINUE 4429 260 CONTINUE 4430 END IF 4431 END IF 4432 DO 270 I = 1, N 4433 SUM = WORK( I ) 4434 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4435 270 CONTINUE 4436 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 4437 IF( LSAME( UPLO, 'U' ) ) THEN 4438 IF( LSAME( DIAG, 'U' ) ) THEN 4439 SSQ( 1 ) = ONE 4440 SSQ( 2 ) = N 4441 IF( K.GT.0 ) THEN 4442 DO 280 J = 2, N 4443 COLSSQ( 1 ) = ZERO 4444 COLSSQ( 2 ) = ONE 4445 CALL CLASSQ( MIN( J-1, K ), 4446 $ AB( MAX( K+2-J, 1 ), J ), 1, 4447 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4448 CALL SCOMBSSQ( SSQ, COLSSQ ) 4449 280 CONTINUE 4450 END IF 4451 ELSE 4452 SSQ( 1 ) = ZERO 4453 SSQ( 2 ) = ONE 4454 DO 290 J = 1, N 4455 COLSSQ( 1 ) = ZERO 4456 COLSSQ( 2 ) = ONE 4457 CALL CLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), 4458 $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 4459 CALL SCOMBSSQ( SSQ, COLSSQ ) 4460 290 CONTINUE 4461 END IF 4462 ELSE 4463 IF( LSAME( DIAG, 'U' ) ) THEN 4464 SSQ( 1 ) = ONE 4465 SSQ( 2 ) = N 4466 IF( K.GT.0 ) THEN 4467 DO 300 J = 1, N - 1 4468 COLSSQ( 1 ) = ZERO 4469 COLSSQ( 2 ) = ONE 4470 CALL CLASSQ( MIN( N-J, K ), AB( 2, J ), 1, 4471 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4472 CALL SCOMBSSQ( SSQ, COLSSQ ) 4473 300 CONTINUE 4474 END IF 4475 ELSE 4476 SSQ( 1 ) = ZERO 4477 SSQ( 2 ) = ONE 4478 DO 310 J = 1, N 4479 COLSSQ( 1 ) = ZERO 4480 COLSSQ( 2 ) = ONE 4481 CALL CLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, 4482 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4483 CALL SCOMBSSQ( SSQ, COLSSQ ) 4484 310 CONTINUE 4485 END IF 4486 END IF 4487 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 4488 END IF 4489 CLANTB = VALUE 4490 RETURN 4491 END 4492! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clantp.f 4493 REAL FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, WORK ) 4494 IMPLICIT NONE 4495 CHARACTER DIAG, NORM, UPLO 4496 INTEGER N 4497 REAL WORK( * ) 4498 COMPLEX AP( * ) 4499 REAL ONE, ZERO 4500 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 4501 LOGICAL UDIAG 4502 INTEGER I, J, K 4503 REAL SUM, VALUE 4504 REAL SSQ( 2 ), COLSSQ( 2 ) 4505 LOGICAL LSAME, SISNAN 4506 EXTERNAL LSAME, SISNAN 4507 EXTERNAL CLASSQ, SCOMBSSQ 4508 INTRINSIC ABS, SQRT 4509 IF( N.EQ.0 ) THEN 4510 VALUE = ZERO 4511 ELSE IF( LSAME( NORM, 'M' ) ) THEN 4512 K = 1 4513 IF( LSAME( DIAG, 'U' ) ) THEN 4514 VALUE = ONE 4515 IF( LSAME( UPLO, 'U' ) ) THEN 4516 DO 20 J = 1, N 4517 DO 10 I = K, K + J - 2 4518 SUM = ABS( AP( I ) ) 4519 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4520 10 CONTINUE 4521 K = K + J 4522 20 CONTINUE 4523 ELSE 4524 DO 40 J = 1, N 4525 DO 30 I = K + 1, K + N - J 4526 SUM = ABS( AP( I ) ) 4527 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4528 30 CONTINUE 4529 K = K + N - J + 1 4530 40 CONTINUE 4531 END IF 4532 ELSE 4533 VALUE = ZERO 4534 IF( LSAME( UPLO, 'U' ) ) THEN 4535 DO 60 J = 1, N 4536 DO 50 I = K, K + J - 1 4537 SUM = ABS( AP( I ) ) 4538 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4539 50 CONTINUE 4540 K = K + J 4541 60 CONTINUE 4542 ELSE 4543 DO 80 J = 1, N 4544 DO 70 I = K, K + N - J 4545 SUM = ABS( AP( I ) ) 4546 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4547 70 CONTINUE 4548 K = K + N - J + 1 4549 80 CONTINUE 4550 END IF 4551 END IF 4552 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 4553 VALUE = ZERO 4554 K = 1 4555 UDIAG = LSAME( DIAG, 'U' ) 4556 IF( LSAME( UPLO, 'U' ) ) THEN 4557 DO 110 J = 1, N 4558 IF( UDIAG ) THEN 4559 SUM = ONE 4560 DO 90 I = K, K + J - 2 4561 SUM = SUM + ABS( AP( I ) ) 4562 90 CONTINUE 4563 ELSE 4564 SUM = ZERO 4565 DO 100 I = K, K + J - 1 4566 SUM = SUM + ABS( AP( I ) ) 4567 100 CONTINUE 4568 END IF 4569 K = K + J 4570 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4571 110 CONTINUE 4572 ELSE 4573 DO 140 J = 1, N 4574 IF( UDIAG ) THEN 4575 SUM = ONE 4576 DO 120 I = K + 1, K + N - J 4577 SUM = SUM + ABS( AP( I ) ) 4578 120 CONTINUE 4579 ELSE 4580 SUM = ZERO 4581 DO 130 I = K, K + N - J 4582 SUM = SUM + ABS( AP( I ) ) 4583 130 CONTINUE 4584 END IF 4585 K = K + N - J + 1 4586 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4587 140 CONTINUE 4588 END IF 4589 ELSE IF( LSAME( NORM, 'I' ) ) THEN 4590 K = 1 4591 IF( LSAME( UPLO, 'U' ) ) THEN 4592 IF( LSAME( DIAG, 'U' ) ) THEN 4593 DO 150 I = 1, N 4594 WORK( I ) = ONE 4595 150 CONTINUE 4596 DO 170 J = 1, N 4597 DO 160 I = 1, J - 1 4598 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 4599 K = K + 1 4600 160 CONTINUE 4601 K = K + 1 4602 170 CONTINUE 4603 ELSE 4604 DO 180 I = 1, N 4605 WORK( I ) = ZERO 4606 180 CONTINUE 4607 DO 200 J = 1, N 4608 DO 190 I = 1, J 4609 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 4610 K = K + 1 4611 190 CONTINUE 4612 200 CONTINUE 4613 END IF 4614 ELSE 4615 IF( LSAME( DIAG, 'U' ) ) THEN 4616 DO 210 I = 1, N 4617 WORK( I ) = ONE 4618 210 CONTINUE 4619 DO 230 J = 1, N 4620 K = K + 1 4621 DO 220 I = J + 1, N 4622 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 4623 K = K + 1 4624 220 CONTINUE 4625 230 CONTINUE 4626 ELSE 4627 DO 240 I = 1, N 4628 WORK( I ) = ZERO 4629 240 CONTINUE 4630 DO 260 J = 1, N 4631 DO 250 I = J, N 4632 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 4633 K = K + 1 4634 250 CONTINUE 4635 260 CONTINUE 4636 END IF 4637 END IF 4638 VALUE = ZERO 4639 DO 270 I = 1, N 4640 SUM = WORK( I ) 4641 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4642 270 CONTINUE 4643 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 4644 IF( LSAME( UPLO, 'U' ) ) THEN 4645 IF( LSAME( DIAG, 'U' ) ) THEN 4646 SSQ( 1 ) = ONE 4647 SSQ( 2 ) = N 4648 K = 2 4649 DO 280 J = 2, N 4650 COLSSQ( 1 ) = ZERO 4651 COLSSQ( 2 ) = ONE 4652 CALL CLASSQ( J-1, AP( K ), 1, 4653 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4654 CALL SCOMBSSQ( SSQ, COLSSQ ) 4655 K = K + J 4656 280 CONTINUE 4657 ELSE 4658 SSQ( 1 ) = ZERO 4659 SSQ( 2 ) = ONE 4660 K = 1 4661 DO 290 J = 1, N 4662 COLSSQ( 1 ) = ZERO 4663 COLSSQ( 2 ) = ONE 4664 CALL CLASSQ( J, AP( K ), 1, 4665 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4666 CALL SCOMBSSQ( SSQ, COLSSQ ) 4667 K = K + J 4668 290 CONTINUE 4669 END IF 4670 ELSE 4671 IF( LSAME( DIAG, 'U' ) ) THEN 4672 SSQ( 1 ) = ONE 4673 SSQ( 2 ) = N 4674 K = 2 4675 DO 300 J = 1, N - 1 4676 COLSSQ( 1 ) = ZERO 4677 COLSSQ( 2 ) = ONE 4678 CALL CLASSQ( N-J, AP( K ), 1, 4679 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4680 CALL SCOMBSSQ( SSQ, COLSSQ ) 4681 K = K + N - J + 1 4682 300 CONTINUE 4683 ELSE 4684 SSQ( 1 ) = ZERO 4685 SSQ( 2 ) = ONE 4686 K = 1 4687 DO 310 J = 1, N 4688 COLSSQ( 1 ) = ZERO 4689 COLSSQ( 2 ) = ONE 4690 CALL CLASSQ( N-J+1, AP( K ), 1, 4691 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4692 CALL SCOMBSSQ( SSQ, COLSSQ ) 4693 K = K + N - J + 1 4694 310 CONTINUE 4695 END IF 4696 END IF 4697 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 4698 END IF 4699 CLANTP = VALUE 4700 RETURN 4701 END 4702! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/clantr.f 4703 REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA, 4704 $ WORK ) 4705 IMPLICIT NONE 4706 CHARACTER DIAG, NORM, UPLO 4707 INTEGER LDA, M, N 4708 REAL WORK( * ) 4709 COMPLEX A( LDA, * ) 4710 REAL ONE, ZERO 4711 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 4712 LOGICAL UDIAG 4713 INTEGER I, J 4714 REAL SUM, VALUE 4715 REAL SSQ( 2 ), COLSSQ( 2 ) 4716 LOGICAL LSAME, SISNAN 4717 EXTERNAL LSAME, SISNAN 4718 EXTERNAL CLASSQ, SCOMBSSQ 4719 INTRINSIC ABS, MIN, SQRT 4720 IF( MIN( M, N ).EQ.0 ) THEN 4721 VALUE = ZERO 4722 ELSE IF( LSAME( NORM, 'M' ) ) THEN 4723 IF( LSAME( DIAG, 'U' ) ) THEN 4724 VALUE = ONE 4725 IF( LSAME( UPLO, 'U' ) ) THEN 4726 DO 20 J = 1, N 4727 DO 10 I = 1, MIN( M, J-1 ) 4728 SUM = ABS( A( I, J ) ) 4729 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4730 10 CONTINUE 4731 20 CONTINUE 4732 ELSE 4733 DO 40 J = 1, N 4734 DO 30 I = J + 1, M 4735 SUM = ABS( A( I, J ) ) 4736 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4737 30 CONTINUE 4738 40 CONTINUE 4739 END IF 4740 ELSE 4741 VALUE = ZERO 4742 IF( LSAME( UPLO, 'U' ) ) THEN 4743 DO 60 J = 1, N 4744 DO 50 I = 1, MIN( M, J ) 4745 SUM = ABS( A( I, J ) ) 4746 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4747 50 CONTINUE 4748 60 CONTINUE 4749 ELSE 4750 DO 80 J = 1, N 4751 DO 70 I = J, M 4752 SUM = ABS( A( I, J ) ) 4753 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4754 70 CONTINUE 4755 80 CONTINUE 4756 END IF 4757 END IF 4758 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 4759 VALUE = ZERO 4760 UDIAG = LSAME( DIAG, 'U' ) 4761 IF( LSAME( UPLO, 'U' ) ) THEN 4762 DO 110 J = 1, N 4763 IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN 4764 SUM = ONE 4765 DO 90 I = 1, J - 1 4766 SUM = SUM + ABS( A( I, J ) ) 4767 90 CONTINUE 4768 ELSE 4769 SUM = ZERO 4770 DO 100 I = 1, MIN( M, J ) 4771 SUM = SUM + ABS( A( I, J ) ) 4772 100 CONTINUE 4773 END IF 4774 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4775 110 CONTINUE 4776 ELSE 4777 DO 140 J = 1, N 4778 IF( UDIAG ) THEN 4779 SUM = ONE 4780 DO 120 I = J + 1, M 4781 SUM = SUM + ABS( A( I, J ) ) 4782 120 CONTINUE 4783 ELSE 4784 SUM = ZERO 4785 DO 130 I = J, M 4786 SUM = SUM + ABS( A( I, J ) ) 4787 130 CONTINUE 4788 END IF 4789 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4790 140 CONTINUE 4791 END IF 4792 ELSE IF( LSAME( NORM, 'I' ) ) THEN 4793 IF( LSAME( UPLO, 'U' ) ) THEN 4794 IF( LSAME( DIAG, 'U' ) ) THEN 4795 DO 150 I = 1, M 4796 WORK( I ) = ONE 4797 150 CONTINUE 4798 DO 170 J = 1, N 4799 DO 160 I = 1, MIN( M, J-1 ) 4800 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 4801 160 CONTINUE 4802 170 CONTINUE 4803 ELSE 4804 DO 180 I = 1, M 4805 WORK( I ) = ZERO 4806 180 CONTINUE 4807 DO 200 J = 1, N 4808 DO 190 I = 1, MIN( M, J ) 4809 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 4810 190 CONTINUE 4811 200 CONTINUE 4812 END IF 4813 ELSE 4814 IF( LSAME( DIAG, 'U' ) ) THEN 4815 DO 210 I = 1, MIN( M, N ) 4816 WORK( I ) = ONE 4817 210 CONTINUE 4818 DO 220 I = N + 1, M 4819 WORK( I ) = ZERO 4820 220 CONTINUE 4821 DO 240 J = 1, N 4822 DO 230 I = J + 1, M 4823 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 4824 230 CONTINUE 4825 240 CONTINUE 4826 ELSE 4827 DO 250 I = 1, M 4828 WORK( I ) = ZERO 4829 250 CONTINUE 4830 DO 270 J = 1, N 4831 DO 260 I = J, M 4832 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 4833 260 CONTINUE 4834 270 CONTINUE 4835 END IF 4836 END IF 4837 VALUE = ZERO 4838 DO 280 I = 1, M 4839 SUM = WORK( I ) 4840 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 4841 280 CONTINUE 4842 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 4843 IF( LSAME( UPLO, 'U' ) ) THEN 4844 IF( LSAME( DIAG, 'U' ) ) THEN 4845 SSQ( 1 ) = ONE 4846 SSQ( 2 ) = MIN( M, N ) 4847 DO 290 J = 2, N 4848 COLSSQ( 1 ) = ZERO 4849 COLSSQ( 2 ) = ONE 4850 CALL CLASSQ( MIN( M, J-1 ), A( 1, J ), 1, 4851 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4852 CALL SCOMBSSQ( SSQ, COLSSQ ) 4853 290 CONTINUE 4854 ELSE 4855 SSQ( 1 ) = ZERO 4856 SSQ( 2 ) = ONE 4857 DO 300 J = 1, N 4858 COLSSQ( 1 ) = ZERO 4859 COLSSQ( 2 ) = ONE 4860 CALL CLASSQ( MIN( M, J ), A( 1, J ), 1, 4861 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4862 CALL SCOMBSSQ( SSQ, COLSSQ ) 4863 300 CONTINUE 4864 END IF 4865 ELSE 4866 IF( LSAME( DIAG, 'U' ) ) THEN 4867 SSQ( 1 ) = ONE 4868 SSQ( 2 ) = MIN( M, N ) 4869 DO 310 J = 1, N 4870 COLSSQ( 1 ) = ZERO 4871 COLSSQ( 2 ) = ONE 4872 CALL CLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, 4873 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4874 CALL SCOMBSSQ( SSQ, COLSSQ ) 4875 310 CONTINUE 4876 ELSE 4877 SSQ( 1 ) = ZERO 4878 SSQ( 2 ) = ONE 4879 DO 320 J = 1, N 4880 COLSSQ( 1 ) = ZERO 4881 COLSSQ( 2 ) = ONE 4882 CALL CLASSQ( M-J+1, A( J, J ), 1, 4883 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 4884 CALL SCOMBSSQ( SSQ, COLSSQ ) 4885 320 CONTINUE 4886 END IF 4887 END IF 4888 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 4889 END IF 4890 CLANTR = VALUE 4891 RETURN 4892 END 4893! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/classq.f 4894 SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ ) 4895 INTEGER INCX, N 4896 REAL SCALE, SUMSQ 4897 COMPLEX X( * ) 4898 REAL ZERO 4899 PARAMETER ( ZERO = 0.0E+0 ) 4900 INTEGER IX 4901 REAL TEMP1 4902 LOGICAL SISNAN 4903 EXTERNAL SISNAN 4904 INTRINSIC ABS, AIMAG, REAL 4905 IF( N.GT.0 ) THEN 4906 DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX 4907 TEMP1 = ABS( REAL( X( IX ) ) ) 4908 IF( TEMP1.GT.ZERO.OR.SISNAN( TEMP1 ) ) THEN 4909 IF( SCALE.LT.TEMP1 ) THEN 4910 SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 4911 SCALE = TEMP1 4912 ELSE 4913 SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 4914 END IF 4915 END IF 4916 TEMP1 = ABS( AIMAG( X( IX ) ) ) 4917 IF( TEMP1.GT.ZERO.OR.SISNAN( TEMP1 ) ) THEN 4918 IF( SCALE.LT.TEMP1 .OR. SISNAN( TEMP1 ) ) THEN 4919 SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 4920 SCALE = TEMP1 4921 ELSE 4922 SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 4923 END IF 4924 END IF 4925 10 CONTINUE 4926 END IF 4927 RETURN 4928 END 4929! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/claswp.f 4930 SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX ) 4931 INTEGER INCX, K1, K2, LDA, N 4932 INTEGER IPIV( * ) 4933 COMPLEX A( LDA, * ) 4934 INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 4935 COMPLEX TEMP 4936 IF( INCX.GT.0 ) THEN 4937 IX0 = K1 4938 I1 = K1 4939 I2 = K2 4940 INC = 1 4941 ELSE IF( INCX.LT.0 ) THEN 4942 IX0 = K1 + ( K1-K2 )*INCX 4943 I1 = K2 4944 I2 = K1 4945 INC = -1 4946 ELSE 4947 RETURN 4948 END IF 4949 N32 = ( N / 32 )*32 4950 IF( N32.NE.0 ) THEN 4951 DO 30 J = 1, N32, 32 4952 IX = IX0 4953 DO 20 I = I1, I2, INC 4954 IP = IPIV( IX ) 4955 IF( IP.NE.I ) THEN 4956 DO 10 K = J, J + 31 4957 TEMP = A( I, K ) 4958 A( I, K ) = A( IP, K ) 4959 A( IP, K ) = TEMP 4960 10 CONTINUE 4961 END IF 4962 IX = IX + INCX 4963 20 CONTINUE 4964 30 CONTINUE 4965 END IF 4966 IF( N32.NE.N ) THEN 4967 N32 = N32 + 1 4968 IX = IX0 4969 DO 50 I = I1, I2, INC 4970 IP = IPIV( IX ) 4971 IF( IP.NE.I ) THEN 4972 DO 40 K = N32, N 4973 TEMP = A( I, K ) 4974 A( I, K ) = A( IP, K ) 4975 A( IP, K ) = TEMP 4976 40 CONTINUE 4977 END IF 4978 IX = IX + INCX 4979 50 CONTINUE 4980 END IF 4981 RETURN 4982 END 4983! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/cpotrs.f 4984 SUBROUTINE CPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) 4985 CHARACTER UPLO 4986 INTEGER INFO, LDA, LDB, N, NRHS 4987 COMPLEX A( LDA, * ), B( LDB, * ) 4988 COMPLEX ONE 4989 PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) 4990 LOGICAL UPPER 4991 LOGICAL LSAME 4992 EXTERNAL LSAME 4993 EXTERNAL CTRSM, XERBLA 4994 INTRINSIC MAX 4995 INFO = 0 4996 UPPER = LSAME( UPLO, 'U' ) 4997 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 4998 INFO = -1 4999 ELSE IF( N.LT.0 ) THEN 5000 INFO = -2 5001 ELSE IF( NRHS.LT.0 ) THEN 5002 INFO = -3 5003 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 5004 INFO = -5 5005 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 5006 INFO = -7 5007 END IF 5008 IF( INFO.NE.0 ) THEN 5009 CALL XERBLA( 'CPOTRS', -INFO ) 5010 RETURN 5011 END IF 5012 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 5013 $ RETURN 5014 IF( UPPER ) THEN 5015 CALL CTRSM( 'Left', 'Upper', 'Conjugate transpose', 'Non-unit', 5016 $ N, NRHS, ONE, A, LDA, B, LDB ) 5017 CALL CTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, 5018 $ NRHS, ONE, A, LDA, B, LDB ) 5019 ELSE 5020 CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, 5021 $ NRHS, ONE, A, LDA, B, LDB ) 5022 CALL CTRSM( 'Left', 'Lower', 'Conjugate transpose', 'Non-unit', 5023 $ N, NRHS, ONE, A, LDA, B, LDB ) 5024 END IF 5025 RETURN 5026 END 5027! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/csytrs.f 5028 SUBROUTINE CSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 5029 CHARACTER UPLO 5030 INTEGER INFO, LDA, LDB, N, NRHS 5031 INTEGER IPIV( * ) 5032 COMPLEX A( LDA, * ), B( LDB, * ) 5033 COMPLEX ONE 5034 PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) 5035 LOGICAL UPPER 5036 INTEGER J, K, KP 5037 COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM 5038 LOGICAL LSAME 5039 EXTERNAL LSAME 5040 EXTERNAL CGEMV, CGERU, CSCAL, CSWAP, XERBLA 5041 INTRINSIC MAX 5042 INFO = 0 5043 UPPER = LSAME( UPLO, 'U' ) 5044 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 5045 INFO = -1 5046 ELSE IF( N.LT.0 ) THEN 5047 INFO = -2 5048 ELSE IF( NRHS.LT.0 ) THEN 5049 INFO = -3 5050 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 5051 INFO = -5 5052 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 5053 INFO = -8 5054 END IF 5055 IF( INFO.NE.0 ) THEN 5056 CALL XERBLA( 'CSYTRS', -INFO ) 5057 RETURN 5058 END IF 5059 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 5060 $ RETURN 5061 IF( UPPER ) THEN 5062 K = N 5063 10 CONTINUE 5064 IF( K.LT.1 ) 5065 $ GO TO 30 5066 IF( IPIV( K ).GT.0 ) THEN 5067 KP = IPIV( K ) 5068 IF( KP.NE.K ) 5069 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 5070 CALL CGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 5071 $ B( 1, 1 ), LDB ) 5072 CALL CSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) 5073 K = K - 1 5074 ELSE 5075 KP = -IPIV( K ) 5076 IF( KP.NE.K-1 ) 5077 $ CALL CSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) 5078 CALL CGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 5079 $ B( 1, 1 ), LDB ) 5080 CALL CGERU( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), 5081 $ LDB, B( 1, 1 ), LDB ) 5082 AKM1K = A( K-1, K ) 5083 AKM1 = A( K-1, K-1 ) / AKM1K 5084 AK = A( K, K ) / AKM1K 5085 DENOM = AKM1*AK - ONE 5086 DO 20 J = 1, NRHS 5087 BKM1 = B( K-1, J ) / AKM1K 5088 BK = B( K, J ) / AKM1K 5089 B( K-1, J ) = ( AK*BKM1-BK ) / DENOM 5090 B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM 5091 20 CONTINUE 5092 K = K - 2 5093 END IF 5094 GO TO 10 5095 30 CONTINUE 5096 K = 1 5097 40 CONTINUE 5098 IF( K.GT.N ) 5099 $ GO TO 50 5100 IF( IPIV( K ).GT.0 ) THEN 5101 CALL CGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), 5102 $ 1, ONE, B( K, 1 ), LDB ) 5103 KP = IPIV( K ) 5104 IF( KP.NE.K ) 5105 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 5106 K = K + 1 5107 ELSE 5108 CALL CGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), 5109 $ 1, ONE, B( K, 1 ), LDB ) 5110 CALL CGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, 5111 $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) 5112 KP = -IPIV( K ) 5113 IF( KP.NE.K ) 5114 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 5115 K = K + 2 5116 END IF 5117 GO TO 40 5118 50 CONTINUE 5119 ELSE 5120 K = 1 5121 60 CONTINUE 5122 IF( K.GT.N ) 5123 $ GO TO 80 5124 IF( IPIV( K ).GT.0 ) THEN 5125 KP = IPIV( K ) 5126 IF( KP.NE.K ) 5127 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 5128 IF( K.LT.N ) 5129 $ CALL CGERU( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), 5130 $ LDB, B( K+1, 1 ), LDB ) 5131 CALL CSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) 5132 K = K + 1 5133 ELSE 5134 KP = -IPIV( K ) 5135 IF( KP.NE.K+1 ) 5136 $ CALL CSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) 5137 IF( K.LT.N-1 ) THEN 5138 CALL CGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), 5139 $ LDB, B( K+2, 1 ), LDB ) 5140 CALL CGERU( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, 5141 $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) 5142 END IF 5143 AKM1K = A( K+1, K ) 5144 AKM1 = A( K, K ) / AKM1K 5145 AK = A( K+1, K+1 ) / AKM1K 5146 DENOM = AKM1*AK - ONE 5147 DO 70 J = 1, NRHS 5148 BKM1 = B( K, J ) / AKM1K 5149 BK = B( K+1, J ) / AKM1K 5150 B( K, J ) = ( AK*BKM1-BK ) / DENOM 5151 B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM 5152 70 CONTINUE 5153 K = K + 2 5154 END IF 5155 GO TO 60 5156 80 CONTINUE 5157 K = N 5158 90 CONTINUE 5159 IF( K.LT.1 ) 5160 $ GO TO 100 5161 IF( IPIV( K ).GT.0 ) THEN 5162 IF( K.LT.N ) 5163 $ CALL CGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 5164 $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) 5165 KP = IPIV( K ) 5166 IF( KP.NE.K ) 5167 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 5168 K = K - 1 5169 ELSE 5170 IF( K.LT.N ) THEN 5171 CALL CGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 5172 $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) 5173 CALL CGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 5174 $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), 5175 $ LDB ) 5176 END IF 5177 KP = -IPIV( K ) 5178 IF( KP.NE.K ) 5179 $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 5180 K = K - 2 5181 END IF 5182 GO TO 90 5183 100 CONTINUE 5184 END IF 5185 RETURN 5186 END 5187! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dbdsqr.f 5188 SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, 5189 $ LDU, C, LDC, WORK, INFO ) 5190 CHARACTER UPLO 5191 INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU 5192 DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), 5193 $ VT( LDVT, * ), WORK( * ) 5194 DOUBLE PRECISION ZERO 5195 PARAMETER ( ZERO = 0.0D0 ) 5196 DOUBLE PRECISION ONE 5197 PARAMETER ( ONE = 1.0D0 ) 5198 DOUBLE PRECISION NEGONE 5199 PARAMETER ( NEGONE = -1.0D0 ) 5200 DOUBLE PRECISION HNDRTH 5201 PARAMETER ( HNDRTH = 0.01D0 ) 5202 DOUBLE PRECISION TEN 5203 PARAMETER ( TEN = 10.0D0 ) 5204 DOUBLE PRECISION HNDRD 5205 PARAMETER ( HNDRD = 100.0D0 ) 5206 DOUBLE PRECISION MEIGTH 5207 PARAMETER ( MEIGTH = -0.125D0 ) 5208 INTEGER MAXITR 5209 PARAMETER ( MAXITR = 6 ) 5210 LOGICAL LOWER, ROTATE 5211 INTEGER I, IDIR, ISUB, ITER, ITERDIVN, J, LL, LLL, M, 5212 $ MAXITDIVN, NM1, NM12, NM13, OLDLL, OLDM 5213 DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, 5214 $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, 5215 $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA, 5216 $ SN, THRESH, TOL, TOLMUL, UNFL 5217 LOGICAL LSAME 5218 DOUBLE PRECISION DLAMCH 5219 EXTERNAL LSAME, DLAMCH 5220 EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT, 5221 $ DSCAL, DSWAP, XERBLA 5222 INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT 5223 INFO = 0 5224 LOWER = LSAME( UPLO, 'L' ) 5225 IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN 5226 INFO = -1 5227 ELSE IF( N.LT.0 ) THEN 5228 INFO = -2 5229 ELSE IF( NCVT.LT.0 ) THEN 5230 INFO = -3 5231 ELSE IF( NRU.LT.0 ) THEN 5232 INFO = -4 5233 ELSE IF( NCC.LT.0 ) THEN 5234 INFO = -5 5235 ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. 5236 $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN 5237 INFO = -9 5238 ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN 5239 INFO = -11 5240 ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. 5241 $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN 5242 INFO = -13 5243 END IF 5244 IF( INFO.NE.0 ) THEN 5245 CALL XERBLA( 'DBDSQR', -INFO ) 5246 RETURN 5247 END IF 5248 IF( N.EQ.0 ) 5249 $ RETURN 5250 IF( N.EQ.1 ) 5251 $ GO TO 160 5252 ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) 5253 IF( .NOT.ROTATE ) THEN 5254 CALL DLASQ1( N, D, E, WORK, INFO ) 5255 IF( INFO .NE. 2 ) RETURN 5256 INFO = 0 5257 END IF 5258 NM1 = N - 1 5259 NM12 = NM1 + NM1 5260 NM13 = NM12 + NM1 5261 IDIR = 0 5262 EPS = DLAMCH( 'Epsilon' ) 5263 UNFL = DLAMCH( 'Safe minimum' ) 5264 IF( LOWER ) THEN 5265 DO 10 I = 1, N - 1 5266 CALL DLARTG( D( I ), E( I ), CS, SN, R ) 5267 D( I ) = R 5268 E( I ) = SN*D( I+1 ) 5269 D( I+1 ) = CS*D( I+1 ) 5270 WORK( I ) = CS 5271 WORK( NM1+I ) = SN 5272 10 CONTINUE 5273 IF( NRU.GT.0 ) 5274 $ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U, 5275 $ LDU ) 5276 IF( NCC.GT.0 ) 5277 $ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C, 5278 $ LDC ) 5279 END IF 5280 TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) 5281 TOL = TOLMUL*EPS 5282 SMAX = ZERO 5283 DO 20 I = 1, N 5284 SMAX = MAX( SMAX, ABS( D( I ) ) ) 5285 20 CONTINUE 5286 DO 30 I = 1, N - 1 5287 SMAX = MAX( SMAX, ABS( E( I ) ) ) 5288 30 CONTINUE 5289 SMINL = ZERO 5290 IF( TOL.GE.ZERO ) THEN 5291 SMINOA = ABS( D( 1 ) ) 5292 IF( SMINOA.EQ.ZERO ) 5293 $ GO TO 50 5294 MU = SMINOA 5295 DO 40 I = 2, N 5296 MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) 5297 SMINOA = MIN( SMINOA, MU ) 5298 IF( SMINOA.EQ.ZERO ) 5299 $ GO TO 50 5300 40 CONTINUE 5301 50 CONTINUE 5302 SMINOA = SMINOA / SQRT( DBLE( N ) ) 5303 THRESH = MAX( TOL*SMINOA, MAXITR*(N*(N*UNFL)) ) 5304 ELSE 5305 THRESH = MAX( ABS( TOL )*SMAX, MAXITR*(N*(N*UNFL)) ) 5306 END IF 5307 MAXITDIVN = MAXITR*N 5308 ITERDIVN = 0 5309 ITER = -1 5310 OLDLL = -1 5311 OLDM = -1 5312 M = N 5313 60 CONTINUE 5314 IF( M.LE.1 ) 5315 $ GO TO 160 5316 IF( ITER.GE.N ) THEN 5317 ITER = ITER - N 5318 ITERDIVN = ITERDIVN + 1 5319 IF( ITERDIVN.GE.MAXITDIVN ) 5320 $ GO TO 200 5321 END IF 5322 IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) 5323 $ D( M ) = ZERO 5324 SMAX = ABS( D( M ) ) 5325 SMIN = SMAX 5326 DO 70 LLL = 1, M - 1 5327 LL = M - LLL 5328 ABSS = ABS( D( LL ) ) 5329 ABSE = ABS( E( LL ) ) 5330 IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) 5331 $ D( LL ) = ZERO 5332 IF( ABSE.LE.THRESH ) 5333 $ GO TO 80 5334 SMIN = MIN( SMIN, ABSS ) 5335 SMAX = MAX( SMAX, ABSS, ABSE ) 5336 70 CONTINUE 5337 LL = 0 5338 GO TO 90 5339 80 CONTINUE 5340 E( LL ) = ZERO 5341 IF( LL.EQ.M-1 ) THEN 5342 M = M - 1 5343 GO TO 60 5344 END IF 5345 90 CONTINUE 5346 LL = LL + 1 5347 IF( LL.EQ.M-1 ) THEN 5348 CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, 5349 $ COSR, SINL, COSL ) 5350 D( M-1 ) = SIGMX 5351 E( M-1 ) = ZERO 5352 D( M ) = SIGMN 5353 IF( NCVT.GT.0 ) 5354 $ CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR, 5355 $ SINR ) 5356 IF( NRU.GT.0 ) 5357 $ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL ) 5358 IF( NCC.GT.0 ) 5359 $ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, 5360 $ SINL ) 5361 M = M - 2 5362 GO TO 60 5363 END IF 5364 IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN 5365 IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN 5366 IDIR = 1 5367 ELSE 5368 IDIR = 2 5369 END IF 5370 END IF 5371 IF( IDIR.EQ.1 ) THEN 5372 IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. 5373 $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN 5374 E( M-1 ) = ZERO 5375 GO TO 60 5376 END IF 5377 IF( TOL.GE.ZERO ) THEN 5378 MU = ABS( D( LL ) ) 5379 SMINL = MU 5380 DO 100 LLL = LL, M - 1 5381 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN 5382 E( LLL ) = ZERO 5383 GO TO 60 5384 END IF 5385 MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) 5386 SMINL = MIN( SMINL, MU ) 5387 100 CONTINUE 5388 END IF 5389 ELSE 5390 IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. 5391 $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN 5392 E( LL ) = ZERO 5393 GO TO 60 5394 END IF 5395 IF( TOL.GE.ZERO ) THEN 5396 MU = ABS( D( M ) ) 5397 SMINL = MU 5398 DO 110 LLL = M - 1, LL, -1 5399 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN 5400 E( LLL ) = ZERO 5401 GO TO 60 5402 END IF 5403 MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) 5404 SMINL = MIN( SMINL, MU ) 5405 110 CONTINUE 5406 END IF 5407 END IF 5408 OLDLL = LL 5409 OLDM = M 5410 IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. 5411 $ MAX( EPS, HNDRTH*TOL ) ) THEN 5412 SHIFT = ZERO 5413 ELSE 5414 IF( IDIR.EQ.1 ) THEN 5415 SLL = ABS( D( LL ) ) 5416 CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) 5417 ELSE 5418 SLL = ABS( D( M ) ) 5419 CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) 5420 END IF 5421 IF( SLL.GT.ZERO ) THEN 5422 IF( ( SHIFT / SLL )**2.LT.EPS ) 5423 $ SHIFT = ZERO 5424 END IF 5425 END IF 5426 ITER = ITER + M - LL 5427 IF( SHIFT.EQ.ZERO ) THEN 5428 IF( IDIR.EQ.1 ) THEN 5429 CS = ONE 5430 OLDCS = ONE 5431 DO 120 I = LL, M - 1 5432 CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) 5433 IF( I.GT.LL ) 5434 $ E( I-1 ) = OLDSN*R 5435 CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) 5436 WORK( I-LL+1 ) = CS 5437 WORK( I-LL+1+NM1 ) = SN 5438 WORK( I-LL+1+NM12 ) = OLDCS 5439 WORK( I-LL+1+NM13 ) = OLDSN 5440 120 CONTINUE 5441 H = D( M )*CS 5442 D( M ) = H*OLDCS 5443 E( M-1 ) = H*OLDSN 5444 IF( NCVT.GT.0 ) 5445 $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), 5446 $ WORK( N ), VT( LL, 1 ), LDVT ) 5447 IF( NRU.GT.0 ) 5448 $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), 5449 $ WORK( NM13+1 ), U( 1, LL ), LDU ) 5450 IF( NCC.GT.0 ) 5451 $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), 5452 $ WORK( NM13+1 ), C( LL, 1 ), LDC ) 5453 IF( ABS( E( M-1 ) ).LE.THRESH ) 5454 $ E( M-1 ) = ZERO 5455 ELSE 5456 CS = ONE 5457 OLDCS = ONE 5458 DO 130 I = M, LL + 1, -1 5459 CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) 5460 IF( I.LT.M ) 5461 $ E( I ) = OLDSN*R 5462 CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) 5463 WORK( I-LL ) = CS 5464 WORK( I-LL+NM1 ) = -SN 5465 WORK( I-LL+NM12 ) = OLDCS 5466 WORK( I-LL+NM13 ) = -OLDSN 5467 130 CONTINUE 5468 H = D( LL )*CS 5469 D( LL ) = H*OLDCS 5470 E( LL ) = H*OLDSN 5471 IF( NCVT.GT.0 ) 5472 $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), 5473 $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) 5474 IF( NRU.GT.0 ) 5475 $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), 5476 $ WORK( N ), U( 1, LL ), LDU ) 5477 IF( NCC.GT.0 ) 5478 $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), 5479 $ WORK( N ), C( LL, 1 ), LDC ) 5480 IF( ABS( E( LL ) ).LE.THRESH ) 5481 $ E( LL ) = ZERO 5482 END IF 5483 ELSE 5484 IF( IDIR.EQ.1 ) THEN 5485 F = ( ABS( D( LL ) )-SHIFT )* 5486 $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) 5487 G = E( LL ) 5488 DO 140 I = LL, M - 1 5489 CALL DLARTG( F, G, COSR, SINR, R ) 5490 IF( I.GT.LL ) 5491 $ E( I-1 ) = R 5492 F = COSR*D( I ) + SINR*E( I ) 5493 E( I ) = COSR*E( I ) - SINR*D( I ) 5494 G = SINR*D( I+1 ) 5495 D( I+1 ) = COSR*D( I+1 ) 5496 CALL DLARTG( F, G, COSL, SINL, R ) 5497 D( I ) = R 5498 F = COSL*E( I ) + SINL*D( I+1 ) 5499 D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) 5500 IF( I.LT.M-1 ) THEN 5501 G = SINL*E( I+1 ) 5502 E( I+1 ) = COSL*E( I+1 ) 5503 END IF 5504 WORK( I-LL+1 ) = COSR 5505 WORK( I-LL+1+NM1 ) = SINR 5506 WORK( I-LL+1+NM12 ) = COSL 5507 WORK( I-LL+1+NM13 ) = SINL 5508 140 CONTINUE 5509 E( M-1 ) = F 5510 IF( NCVT.GT.0 ) 5511 $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), 5512 $ WORK( N ), VT( LL, 1 ), LDVT ) 5513 IF( NRU.GT.0 ) 5514 $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), 5515 $ WORK( NM13+1 ), U( 1, LL ), LDU ) 5516 IF( NCC.GT.0 ) 5517 $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), 5518 $ WORK( NM13+1 ), C( LL, 1 ), LDC ) 5519 IF( ABS( E( M-1 ) ).LE.THRESH ) 5520 $ E( M-1 ) = ZERO 5521 ELSE 5522 F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / 5523 $ D( M ) ) 5524 G = E( M-1 ) 5525 DO 150 I = M, LL + 1, -1 5526 CALL DLARTG( F, G, COSR, SINR, R ) 5527 IF( I.LT.M ) 5528 $ E( I ) = R 5529 F = COSR*D( I ) + SINR*E( I-1 ) 5530 E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) 5531 G = SINR*D( I-1 ) 5532 D( I-1 ) = COSR*D( I-1 ) 5533 CALL DLARTG( F, G, COSL, SINL, R ) 5534 D( I ) = R 5535 F = COSL*E( I-1 ) + SINL*D( I-1 ) 5536 D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) 5537 IF( I.GT.LL+1 ) THEN 5538 G = SINL*E( I-2 ) 5539 E( I-2 ) = COSL*E( I-2 ) 5540 END IF 5541 WORK( I-LL ) = COSR 5542 WORK( I-LL+NM1 ) = -SINR 5543 WORK( I-LL+NM12 ) = COSL 5544 WORK( I-LL+NM13 ) = -SINL 5545 150 CONTINUE 5546 E( LL ) = F 5547 IF( ABS( E( LL ) ).LE.THRESH ) 5548 $ E( LL ) = ZERO 5549 IF( NCVT.GT.0 ) 5550 $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), 5551 $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) 5552 IF( NRU.GT.0 ) 5553 $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), 5554 $ WORK( N ), U( 1, LL ), LDU ) 5555 IF( NCC.GT.0 ) 5556 $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), 5557 $ WORK( N ), C( LL, 1 ), LDC ) 5558 END IF 5559 END IF 5560 GO TO 60 5561 160 CONTINUE 5562 DO 170 I = 1, N 5563 IF( D( I ).LT.ZERO ) THEN 5564 D( I ) = -D( I ) 5565 IF( NCVT.GT.0 ) 5566 $ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) 5567 END IF 5568 170 CONTINUE 5569 DO 190 I = 1, N - 1 5570 ISUB = 1 5571 SMIN = D( 1 ) 5572 DO 180 J = 2, N + 1 - I 5573 IF( D( J ).LE.SMIN ) THEN 5574 ISUB = J 5575 SMIN = D( J ) 5576 END IF 5577 180 CONTINUE 5578 IF( ISUB.NE.N+1-I ) THEN 5579 D( ISUB ) = D( N+1-I ) 5580 D( N+1-I ) = SMIN 5581 IF( NCVT.GT.0 ) 5582 $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), 5583 $ LDVT ) 5584 IF( NRU.GT.0 ) 5585 $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) 5586 IF( NCC.GT.0 ) 5587 $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) 5588 END IF 5589 190 CONTINUE 5590 GO TO 220 5591 200 CONTINUE 5592 INFO = 0 5593 DO 210 I = 1, N - 1 5594 IF( E( I ).NE.ZERO ) 5595 $ INFO = INFO + 1 5596 210 CONTINUE 5597 220 CONTINUE 5598 RETURN 5599 END 5600! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dcombssq.f 5601 SUBROUTINE DCOMBSSQ( V1, V2 ) 5602 DOUBLE PRECISION V1( 2 ), V2( 2 ) 5603 DOUBLE PRECISION ZERO 5604 PARAMETER ( ZERO = 0.0D+0 ) 5605 IF( V1( 1 ).GE.V2( 1 ) ) THEN 5606 IF( V1( 1 ).NE.ZERO ) THEN 5607 V1( 2 ) = V1( 2 ) + ( V2( 1 ) / V1( 1 ) )**2 * V2( 2 ) 5608 ELSE 5609 V1( 2 ) = V1( 2 ) + V2( 2 ) 5610 END IF 5611 ELSE 5612 V1( 2 ) = V2( 2 ) + ( V1( 1 ) / V2( 1 ) )**2 * V1( 2 ) 5613 V1( 1 ) = V2( 1 ) 5614 END IF 5615 RETURN 5616 END 5617! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgbtrs.f 5618 SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, 5619 $ INFO ) 5620 CHARACTER TRANS 5621 INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS 5622 INTEGER IPIV( * ) 5623 DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) 5624 DOUBLE PRECISION ONE 5625 PARAMETER ( ONE = 1.0D+0 ) 5626 LOGICAL LNOTI, NOTRAN 5627 INTEGER I, J, KD, L, LM 5628 LOGICAL LSAME 5629 EXTERNAL LSAME 5630 EXTERNAL DGEMV, DGER, DSWAP, DTBSV, XERBLA 5631 INTRINSIC MAX, MIN 5632 INFO = 0 5633 NOTRAN = LSAME( TRANS, 'N' ) 5634 IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. 5635 $ LSAME( TRANS, 'C' ) ) THEN 5636 INFO = -1 5637 ELSE IF( N.LT.0 ) THEN 5638 INFO = -2 5639 ELSE IF( KL.LT.0 ) THEN 5640 INFO = -3 5641 ELSE IF( KU.LT.0 ) THEN 5642 INFO = -4 5643 ELSE IF( NRHS.LT.0 ) THEN 5644 INFO = -5 5645 ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN 5646 INFO = -7 5647 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 5648 INFO = -10 5649 END IF 5650 IF( INFO.NE.0 ) THEN 5651 CALL XERBLA( 'DGBTRS', -INFO ) 5652 RETURN 5653 END IF 5654 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 5655 $ RETURN 5656 KD = KU + KL + 1 5657 LNOTI = KL.GT.0 5658 IF( NOTRAN ) THEN 5659 IF( LNOTI ) THEN 5660 DO 10 J = 1, N - 1 5661 LM = MIN( KL, N-J ) 5662 L = IPIV( J ) 5663 IF( L.NE.J ) 5664 $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 5665 CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), 5666 $ LDB, B( J+1, 1 ), LDB ) 5667 10 CONTINUE 5668 END IF 5669 DO 20 I = 1, NRHS 5670 CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, 5671 $ AB, LDAB, B( 1, I ), 1 ) 5672 20 CONTINUE 5673 ELSE 5674 DO 30 I = 1, NRHS 5675 CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, 5676 $ LDAB, B( 1, I ), 1 ) 5677 30 CONTINUE 5678 IF( LNOTI ) THEN 5679 DO 40 J = N - 1, 1, -1 5680 LM = MIN( KL, N-J ) 5681 CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), 5682 $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) 5683 L = IPIV( J ) 5684 IF( L.NE.J ) 5685 $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 5686 40 CONTINUE 5687 END IF 5688 END IF 5689 RETURN 5690 END 5691! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgebd2.f 5692 SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) 5693 INTEGER INFO, LDA, M, N 5694 DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), 5695 $ TAUQ( * ), WORK( * ) 5696 DOUBLE PRECISION ZERO, ONE 5697 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 5698 INTEGER I 5699 EXTERNAL DLARF, DLARFG, XERBLA 5700 INTRINSIC MAX, MIN 5701 INFO = 0 5702 IF( M.LT.0 ) THEN 5703 INFO = -1 5704 ELSE IF( N.LT.0 ) THEN 5705 INFO = -2 5706 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 5707 INFO = -4 5708 END IF 5709 IF( INFO.LT.0 ) THEN 5710 CALL XERBLA( 'DGEBD2', -INFO ) 5711 RETURN 5712 END IF 5713 IF( M.GE.N ) THEN 5714 DO 10 I = 1, N 5715 CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, 5716 $ TAUQ( I ) ) 5717 D( I ) = A( I, I ) 5718 A( I, I ) = ONE 5719 IF( I.LT.N ) 5720 $ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), 5721 $ A( I, I+1 ), LDA, WORK ) 5722 A( I, I ) = D( I ) 5723 IF( I.LT.N ) THEN 5724 CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), 5725 $ LDA, TAUP( I ) ) 5726 E( I ) = A( I, I+1 ) 5727 A( I, I+1 ) = ONE 5728 CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, 5729 $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) 5730 A( I, I+1 ) = E( I ) 5731 ELSE 5732 TAUP( I ) = ZERO 5733 END IF 5734 10 CONTINUE 5735 ELSE 5736 DO 20 I = 1, M 5737 CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, 5738 $ TAUP( I ) ) 5739 D( I ) = A( I, I ) 5740 A( I, I ) = ONE 5741 IF( I.LT.M ) 5742 $ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, 5743 $ TAUP( I ), A( I+1, I ), LDA, WORK ) 5744 A( I, I ) = D( I ) 5745 IF( I.LT.M ) THEN 5746 CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, 5747 $ TAUQ( I ) ) 5748 E( I ) = A( I+1, I ) 5749 A( I+1, I ) = ONE 5750 CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), 5751 $ A( I+1, I+1 ), LDA, WORK ) 5752 A( I+1, I ) = E( I ) 5753 ELSE 5754 TAUQ( I ) = ZERO 5755 END IF 5756 20 CONTINUE 5757 END IF 5758 RETURN 5759 END 5760! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgebrd.f 5761 SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, 5762 $ INFO ) 5763 INTEGER INFO, LDA, LWORK, M, N 5764 DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), 5765 $ TAUQ( * ), WORK( * ) 5766 DOUBLE PRECISION ONE 5767 PARAMETER ( ONE = 1.0D+0 ) 5768 LOGICAL LQUERY 5769 INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, 5770 $ NBMIN, NX, WS 5771 EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA 5772 INTRINSIC DBLE, MAX, MIN 5773 INTEGER ILAENV 5774 EXTERNAL ILAENV 5775 INFO = 0 5776 NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) ) 5777 LWKOPT = ( M+N )*NB 5778 WORK( 1 ) = DBLE( LWKOPT ) 5779 LQUERY = ( LWORK.EQ.-1 ) 5780 IF( M.LT.0 ) THEN 5781 INFO = -1 5782 ELSE IF( N.LT.0 ) THEN 5783 INFO = -2 5784 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 5785 INFO = -4 5786 ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN 5787 INFO = -10 5788 END IF 5789 IF( INFO.LT.0 ) THEN 5790 CALL XERBLA( 'DGEBRD', -INFO ) 5791 RETURN 5792 ELSE IF( LQUERY ) THEN 5793 RETURN 5794 END IF 5795 MINMN = MIN( M, N ) 5796 IF( MINMN.EQ.0 ) THEN 5797 WORK( 1 ) = 1 5798 RETURN 5799 END IF 5800 WS = MAX( M, N ) 5801 LDWRKX = M 5802 LDWRKY = N 5803 IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN 5804 NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) ) 5805 IF( NX.LT.MINMN ) THEN 5806 WS = ( M+N )*NB 5807 IF( LWORK.LT.WS ) THEN 5808 NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 ) 5809 IF( LWORK.GE.( M+N )*NBMIN ) THEN 5810 NB = LWORK / ( M+N ) 5811 ELSE 5812 NB = 1 5813 NX = MINMN 5814 END IF 5815 END IF 5816 END IF 5817 ELSE 5818 NX = MINMN 5819 END IF 5820 DO 30 I = 1, MINMN - NX, NB 5821 CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), 5822 $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, 5823 $ WORK( LDWRKX*NB+1 ), LDWRKY ) 5824 CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1, 5825 $ NB, -ONE, A( I+NB, I ), LDA, 5826 $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, 5827 $ A( I+NB, I+NB ), LDA ) 5828 CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, 5829 $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, 5830 $ ONE, A( I+NB, I+NB ), LDA ) 5831 IF( M.GE.N ) THEN 5832 DO 10 J = I, I + NB - 1 5833 A( J, J ) = D( J ) 5834 A( J, J+1 ) = E( J ) 5835 10 CONTINUE 5836 ELSE 5837 DO 20 J = I, I + NB - 1 5838 A( J, J ) = D( J ) 5839 A( J+1, J ) = E( J ) 5840 20 CONTINUE 5841 END IF 5842 30 CONTINUE 5843 CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), 5844 $ TAUQ( I ), TAUP( I ), WORK, IINFO ) 5845 WORK( 1 ) = WS 5846 RETURN 5847 END 5848! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgelq2.f 5849 SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) 5850 INTEGER INFO, LDA, M, N 5851 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 5852 DOUBLE PRECISION ONE 5853 PARAMETER ( ONE = 1.0D+0 ) 5854 INTEGER I, K 5855 DOUBLE PRECISION AII 5856 EXTERNAL DLARF, DLARFG, XERBLA 5857 INTRINSIC MAX, MIN 5858 INFO = 0 5859 IF( M.LT.0 ) THEN 5860 INFO = -1 5861 ELSE IF( N.LT.0 ) THEN 5862 INFO = -2 5863 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 5864 INFO = -4 5865 END IF 5866 IF( INFO.NE.0 ) THEN 5867 CALL XERBLA( 'DGELQ2', -INFO ) 5868 RETURN 5869 END IF 5870 K = MIN( M, N ) 5871 DO 10 I = 1, K 5872 CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, 5873 $ TAU( I ) ) 5874 IF( I.LT.M ) THEN 5875 AII = A( I, I ) 5876 A( I, I ) = ONE 5877 CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), 5878 $ A( I+1, I ), LDA, WORK ) 5879 A( I, I ) = AII 5880 END IF 5881 10 CONTINUE 5882 RETURN 5883 END 5884! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgelqf.f 5885 SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) 5886 INTEGER INFO, LDA, LWORK, M, N 5887 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 5888 LOGICAL LQUERY 5889 INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, 5890 $ NBMIN, NX 5891 EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA 5892 INTRINSIC MAX, MIN 5893 INTEGER ILAENV 5894 EXTERNAL ILAENV 5895 INFO = 0 5896 NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) 5897 LWKOPT = M*NB 5898 WORK( 1 ) = LWKOPT 5899 LQUERY = ( LWORK.EQ.-1 ) 5900 IF( M.LT.0 ) THEN 5901 INFO = -1 5902 ELSE IF( N.LT.0 ) THEN 5903 INFO = -2 5904 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 5905 INFO = -4 5906 ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN 5907 INFO = -7 5908 END IF 5909 IF( INFO.NE.0 ) THEN 5910 CALL XERBLA( 'DGELQF', -INFO ) 5911 RETURN 5912 ELSE IF( LQUERY ) THEN 5913 RETURN 5914 END IF 5915 K = MIN( M, N ) 5916 IF( K.EQ.0 ) THEN 5917 WORK( 1 ) = 1 5918 RETURN 5919 END IF 5920 NBMIN = 2 5921 NX = 0 5922 IWS = M 5923 IF( NB.GT.1 .AND. NB.LT.K ) THEN 5924 NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) ) 5925 IF( NX.LT.K ) THEN 5926 LDWORK = M 5927 IWS = LDWORK*NB 5928 IF( LWORK.LT.IWS ) THEN 5929 NB = LWORK / LDWORK 5930 NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1, 5931 $ -1 ) ) 5932 END IF 5933 END IF 5934 END IF 5935 IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN 5936 DO 10 I = 1, K - NX, NB 5937 IB = MIN( K-I+1, NB ) 5938 CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, 5939 $ IINFO ) 5940 IF( I+IB.LE.M ) THEN 5941 CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), 5942 $ LDA, TAU( I ), WORK, LDWORK ) 5943 CALL DLARFB( 'Right', 'No transpose', 'Forward', 5944 $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), 5945 $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, 5946 $ WORK( IB+1 ), LDWORK ) 5947 END IF 5948 10 CONTINUE 5949 ELSE 5950 I = 1 5951 END IF 5952 IF( I.LE.K ) 5953 $ CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, 5954 $ IINFO ) 5955 WORK( 1 ) = IWS 5956 RETURN 5957 END 5958! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgels.f 5959 SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, 5960 $ INFO ) 5961 CHARACTER TRANS 5962 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS 5963 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) 5964 DOUBLE PRECISION ZERO, ONE 5965 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 5966 LOGICAL LQUERY, TPSD 5967 INTEGER BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE 5968 DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM 5969 DOUBLE PRECISION RWORK( 1 ) 5970 LOGICAL LSAME 5971 INTEGER ILAENV 5972 DOUBLE PRECISION DLAMCH, DLANGE 5973 EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE 5974 EXTERNAL DGELQF, DGEQRF, DLASCL, DLASET, DORMLQ, DORMQR, 5975 $ DTRTRS, XERBLA 5976 INTRINSIC DBLE, MAX, MIN 5977 INFO = 0 5978 MN = MIN( M, N ) 5979 LQUERY = ( LWORK.EQ.-1 ) 5980 IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN 5981 INFO = -1 5982 ELSE IF( M.LT.0 ) THEN 5983 INFO = -2 5984 ELSE IF( N.LT.0 ) THEN 5985 INFO = -3 5986 ELSE IF( NRHS.LT.0 ) THEN 5987 INFO = -4 5988 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 5989 INFO = -6 5990 ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN 5991 INFO = -8 5992 ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY ) 5993 $ THEN 5994 INFO = -10 5995 END IF 5996 IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN 5997 TPSD = .TRUE. 5998 IF( LSAME( TRANS, 'N' ) ) 5999 $ TPSD = .FALSE. 6000 IF( M.GE.N ) THEN 6001 NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) 6002 IF( TPSD ) THEN 6003 NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LN', M, NRHS, N, 6004 $ -1 ) ) 6005 ELSE 6006 NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, 6007 $ -1 ) ) 6008 END IF 6009 ELSE 6010 NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) 6011 IF( TPSD ) THEN 6012 NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, 6013 $ -1 ) ) 6014 ELSE 6015 NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LN', N, NRHS, M, 6016 $ -1 ) ) 6017 END IF 6018 END IF 6019 WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB ) 6020 WORK( 1 ) = DBLE( WSIZE ) 6021 END IF 6022 IF( INFO.NE.0 ) THEN 6023 CALL XERBLA( 'DGELS ', -INFO ) 6024 RETURN 6025 ELSE IF( LQUERY ) THEN 6026 RETURN 6027 END IF 6028 IF( MIN( M, N, NRHS ).EQ.0 ) THEN 6029 CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) 6030 RETURN 6031 END IF 6032 SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) 6033 BIGNUM = ONE / SMLNUM 6034 CALL DLABAD( SMLNUM, BIGNUM ) 6035 ANRM = DLANGE( 'M', M, N, A, LDA, RWORK ) 6036 IASCL = 0 6037 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN 6038 CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) 6039 IASCL = 1 6040 ELSE IF( ANRM.GT.BIGNUM ) THEN 6041 CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) 6042 IASCL = 2 6043 ELSE IF( ANRM.EQ.ZERO ) THEN 6044 CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) 6045 GO TO 50 6046 END IF 6047 BROW = M 6048 IF( TPSD ) 6049 $ BROW = N 6050 BNRM = DLANGE( 'M', BROW, NRHS, B, LDB, RWORK ) 6051 IBSCL = 0 6052 IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN 6053 CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB, 6054 $ INFO ) 6055 IBSCL = 1 6056 ELSE IF( BNRM.GT.BIGNUM ) THEN 6057 CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB, 6058 $ INFO ) 6059 IBSCL = 2 6060 END IF 6061 IF( M.GE.N ) THEN 6062 CALL DGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN, 6063 $ INFO ) 6064 IF( .NOT.TPSD ) THEN 6065 CALL DORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA, 6066 $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, 6067 $ INFO ) 6068 CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', N, NRHS, 6069 $ A, LDA, B, LDB, INFO ) 6070 IF( INFO.GT.0 ) THEN 6071 RETURN 6072 END IF 6073 SCLLEN = N 6074 ELSE 6075 CALL DTRTRS( 'Upper', 'Transpose', 'Non-unit', N, NRHS, 6076 $ A, LDA, B, LDB, INFO ) 6077 IF( INFO.GT.0 ) THEN 6078 RETURN 6079 END IF 6080 DO 20 J = 1, NRHS 6081 DO 10 I = N + 1, M 6082 B( I, J ) = ZERO 6083 10 CONTINUE 6084 20 CONTINUE 6085 CALL DORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA, 6086 $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, 6087 $ INFO ) 6088 SCLLEN = M 6089 END IF 6090 ELSE 6091 CALL DGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN, 6092 $ INFO ) 6093 IF( .NOT.TPSD ) THEN 6094 CALL DTRTRS( 'Lower', 'No transpose', 'Non-unit', M, NRHS, 6095 $ A, LDA, B, LDB, INFO ) 6096 IF( INFO.GT.0 ) THEN 6097 RETURN 6098 END IF 6099 DO 40 J = 1, NRHS 6100 DO 30 I = M + 1, N 6101 B( I, J ) = ZERO 6102 30 CONTINUE 6103 40 CONTINUE 6104 CALL DORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA, 6105 $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, 6106 $ INFO ) 6107 SCLLEN = N 6108 ELSE 6109 CALL DORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA, 6110 $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN, 6111 $ INFO ) 6112 CALL DTRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS, 6113 $ A, LDA, B, LDB, INFO ) 6114 IF( INFO.GT.0 ) THEN 6115 RETURN 6116 END IF 6117 SCLLEN = M 6118 END IF 6119 END IF 6120 IF( IASCL.EQ.1 ) THEN 6121 CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB, 6122 $ INFO ) 6123 ELSE IF( IASCL.EQ.2 ) THEN 6124 CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB, 6125 $ INFO ) 6126 END IF 6127 IF( IBSCL.EQ.1 ) THEN 6128 CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB, 6129 $ INFO ) 6130 ELSE IF( IBSCL.EQ.2 ) THEN 6131 CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB, 6132 $ INFO ) 6133 END IF 6134 50 CONTINUE 6135 WORK( 1 ) = DBLE( WSIZE ) 6136 RETURN 6137 END 6138! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgelss.f 6139 SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, 6140 $ WORK, LWORK, INFO ) 6141 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK 6142 DOUBLE PRECISION RCOND 6143 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) 6144 DOUBLE PRECISION ZERO, ONE 6145 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 6146 LOGICAL LQUERY 6147 INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL, 6148 $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN, 6149 $ MAXWRK, MINMN, MINWRK, MM, MNTHR 6150 INTEGER LWORK_DGEQRF, LWORK_DORMQR, LWORK_DGEBRD, 6151 $ LWORK_DORMBR, LWORK_DORGBR, LWORK_DORMLQ, 6152 $ LWORK_DGELQF 6153 DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR 6154 DOUBLE PRECISION DUM( 1 ) 6155 EXTERNAL DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV, 6156 $ DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR, 6157 $ DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA 6158 INTEGER ILAENV 6159 DOUBLE PRECISION DLAMCH, DLANGE 6160 EXTERNAL ILAENV, DLAMCH, DLANGE 6161 INTRINSIC MAX, MIN 6162 INFO = 0 6163 MINMN = MIN( M, N ) 6164 MAXMN = MAX( M, N ) 6165 LQUERY = ( LWORK.EQ.-1 ) 6166 IF( M.LT.0 ) THEN 6167 INFO = -1 6168 ELSE IF( N.LT.0 ) THEN 6169 INFO = -2 6170 ELSE IF( NRHS.LT.0 ) THEN 6171 INFO = -3 6172 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 6173 INFO = -5 6174 ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN 6175 INFO = -7 6176 END IF 6177 IF( INFO.EQ.0 ) THEN 6178 MINWRK = 1 6179 MAXWRK = 1 6180 IF( MINMN.GT.0 ) THEN 6181 MM = M 6182 MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 ) 6183 IF( M.GE.N .AND. M.GE.MNTHR ) THEN 6184 CALL DGEQRF( M, N, A, LDA, DUM(1), DUM(1), -1, INFO ) 6185 LWORK_DGEQRF=DUM(1) 6186 CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, DUM(1), B, 6187 $ LDB, DUM(1), -1, INFO ) 6188 LWORK_DORMQR=DUM(1) 6189 MM = N 6190 MAXWRK = MAX( MAXWRK, N + LWORK_DGEQRF ) 6191 MAXWRK = MAX( MAXWRK, N + LWORK_DORMQR ) 6192 END IF 6193 IF( M.GE.N ) THEN 6194 BDSPAC = MAX( 1, 5*N ) 6195 CALL DGEBRD( MM, N, A, LDA, S, DUM(1), DUM(1), 6196 $ DUM(1), DUM(1), -1, INFO ) 6197 LWORK_DGEBRD=DUM(1) 6198 CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, DUM(1), 6199 $ B, LDB, DUM(1), -1, INFO ) 6200 LWORK_DORMBR=DUM(1) 6201 CALL DORGBR( 'P', N, N, N, A, LDA, DUM(1), 6202 $ DUM(1), -1, INFO ) 6203 LWORK_DORGBR=DUM(1) 6204 MAXWRK = MAX( MAXWRK, 3*N + LWORK_DGEBRD ) 6205 MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORMBR ) 6206 MAXWRK = MAX( MAXWRK, 3*N + LWORK_DORGBR ) 6207 MAXWRK = MAX( MAXWRK, BDSPAC ) 6208 MAXWRK = MAX( MAXWRK, N*NRHS ) 6209 MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC ) 6210 MAXWRK = MAX( MINWRK, MAXWRK ) 6211 END IF 6212 IF( N.GT.M ) THEN 6213 BDSPAC = MAX( 1, 5*M ) 6214 MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) 6215 IF( N.GE.MNTHR ) THEN 6216 CALL DGELQF( M, N, A, LDA, DUM(1), DUM(1), 6217 $ -1, INFO ) 6218 LWORK_DGELQF=DUM(1) 6219 CALL DGEBRD( M, M, A, LDA, S, DUM(1), DUM(1), 6220 $ DUM(1), DUM(1), -1, INFO ) 6221 LWORK_DGEBRD=DUM(1) 6222 CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, 6223 $ DUM(1), B, LDB, DUM(1), -1, INFO ) 6224 LWORK_DORMBR=DUM(1) 6225 CALL DORGBR( 'P', M, M, M, A, LDA, DUM(1), 6226 $ DUM(1), -1, INFO ) 6227 LWORK_DORGBR=DUM(1) 6228 CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, DUM(1), 6229 $ B, LDB, DUM(1), -1, INFO ) 6230 LWORK_DORMLQ=DUM(1) 6231 MAXWRK = M + LWORK_DGELQF 6232 MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DGEBRD ) 6233 MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DORMBR ) 6234 MAXWRK = MAX( MAXWRK, M*M + 4*M + LWORK_DORGBR ) 6235 MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC ) 6236 IF( NRHS.GT.1 ) THEN 6237 MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS ) 6238 ELSE 6239 MAXWRK = MAX( MAXWRK, M*M + 2*M ) 6240 END IF 6241 MAXWRK = MAX( MAXWRK, M + LWORK_DORMLQ ) 6242 ELSE 6243 CALL DGEBRD( M, N, A, LDA, S, DUM(1), DUM(1), 6244 $ DUM(1), DUM(1), -1, INFO ) 6245 LWORK_DGEBRD=DUM(1) 6246 CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, A, LDA, 6247 $ DUM(1), B, LDB, DUM(1), -1, INFO ) 6248 LWORK_DORMBR=DUM(1) 6249 CALL DORGBR( 'P', M, N, M, A, LDA, DUM(1), 6250 $ DUM(1), -1, INFO ) 6251 LWORK_DORGBR=DUM(1) 6252 MAXWRK = 3*M + LWORK_DGEBRD 6253 MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORMBR ) 6254 MAXWRK = MAX( MAXWRK, 3*M + LWORK_DORGBR ) 6255 MAXWRK = MAX( MAXWRK, BDSPAC ) 6256 MAXWRK = MAX( MAXWRK, N*NRHS ) 6257 END IF 6258 END IF 6259 MAXWRK = MAX( MINWRK, MAXWRK ) 6260 END IF 6261 WORK( 1 ) = MAXWRK 6262 IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) 6263 $ INFO = -12 6264 END IF 6265 IF( INFO.NE.0 ) THEN 6266 CALL XERBLA( 'DGELSS', -INFO ) 6267 RETURN 6268 ELSE IF( LQUERY ) THEN 6269 RETURN 6270 END IF 6271 IF( M.EQ.0 .OR. N.EQ.0 ) THEN 6272 RANK = 0 6273 RETURN 6274 END IF 6275 EPS = DLAMCH( 'P' ) 6276 SFMIN = DLAMCH( 'S' ) 6277 SMLNUM = SFMIN / EPS 6278 BIGNUM = ONE / SMLNUM 6279 CALL DLABAD( SMLNUM, BIGNUM ) 6280 ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) 6281 IASCL = 0 6282 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN 6283 CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) 6284 IASCL = 1 6285 ELSE IF( ANRM.GT.BIGNUM ) THEN 6286 CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) 6287 IASCL = 2 6288 ELSE IF( ANRM.EQ.ZERO ) THEN 6289 CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) 6290 CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, MINMN ) 6291 RANK = 0 6292 GO TO 70 6293 END IF 6294 BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) 6295 IBSCL = 0 6296 IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN 6297 CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) 6298 IBSCL = 1 6299 ELSE IF( BNRM.GT.BIGNUM ) THEN 6300 CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) 6301 IBSCL = 2 6302 END IF 6303 IF( M.GE.N ) THEN 6304 MM = M 6305 IF( M.GE.MNTHR ) THEN 6306 MM = N 6307 ITAU = 1 6308 IWORK = ITAU + N 6309 CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), 6310 $ LWORK-IWORK+1, INFO ) 6311 CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, 6312 $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) 6313 IF( N.GT.1 ) 6314 $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) 6315 END IF 6316 IE = 1 6317 ITAUQ = IE + N 6318 ITAUP = ITAUQ + N 6319 IWORK = ITAUP + N 6320 CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), 6321 $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, 6322 $ INFO ) 6323 CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), 6324 $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) 6325 CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), 6326 $ WORK( IWORK ), LWORK-IWORK+1, INFO ) 6327 IWORK = IE + N 6328 CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, DUM, 6329 $ 1, B, LDB, WORK( IWORK ), INFO ) 6330 IF( INFO.NE.0 ) 6331 $ GO TO 70 6332 THR = MAX( RCOND*S( 1 ), SFMIN ) 6333 IF( RCOND.LT.ZERO ) 6334 $ THR = MAX( EPS*S( 1 ), SFMIN ) 6335 RANK = 0 6336 DO 10 I = 1, N 6337 IF( S( I ).GT.THR ) THEN 6338 CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) 6339 RANK = RANK + 1 6340 ELSE 6341 CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) 6342 END IF 6343 10 CONTINUE 6344 IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN 6345 CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO, 6346 $ WORK, LDB ) 6347 CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB ) 6348 ELSE IF( NRHS.GT.1 ) THEN 6349 CHUNK = LWORK / N 6350 DO 20 I = 1, NRHS, CHUNK 6351 BL = MIN( NRHS-I+1, CHUNK ) 6352 CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ), 6353 $ LDB, ZERO, WORK, N ) 6354 CALL DLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB ) 6355 20 CONTINUE 6356 ELSE 6357 CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) 6358 CALL DCOPY( N, WORK, 1, B, 1 ) 6359 END IF 6360 ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ 6361 $ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN 6362 LDWORK = M 6363 IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), 6364 $ M*LDA+M+M*NRHS ) )LDWORK = LDA 6365 ITAU = 1 6366 IWORK = M + 1 6367 CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), 6368 $ LWORK-IWORK+1, INFO ) 6369 IL = IWORK 6370 CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) 6371 CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), 6372 $ LDWORK ) 6373 IE = IL + LDWORK*M 6374 ITAUQ = IE + M 6375 ITAUP = ITAUQ + M 6376 IWORK = ITAUP + M 6377 CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), 6378 $ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ), 6379 $ LWORK-IWORK+1, INFO ) 6380 CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, 6381 $ WORK( ITAUQ ), B, LDB, WORK( IWORK ), 6382 $ LWORK-IWORK+1, INFO ) 6383 CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ), 6384 $ WORK( IWORK ), LWORK-IWORK+1, INFO ) 6385 IWORK = IE + M 6386 CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ), 6387 $ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO ) 6388 IF( INFO.NE.0 ) 6389 $ GO TO 70 6390 THR = MAX( RCOND*S( 1 ), SFMIN ) 6391 IF( RCOND.LT.ZERO ) 6392 $ THR = MAX( EPS*S( 1 ), SFMIN ) 6393 RANK = 0 6394 DO 30 I = 1, M 6395 IF( S( I ).GT.THR ) THEN 6396 CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) 6397 RANK = RANK + 1 6398 ELSE 6399 CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) 6400 END IF 6401 30 CONTINUE 6402 IWORK = IE 6403 IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN 6404 CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK, 6405 $ B, LDB, ZERO, WORK( IWORK ), LDB ) 6406 CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB ) 6407 ELSE IF( NRHS.GT.1 ) THEN 6408 CHUNK = ( LWORK-IWORK+1 ) / M 6409 DO 40 I = 1, NRHS, CHUNK 6410 BL = MIN( NRHS-I+1, CHUNK ) 6411 CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, 6412 $ B( 1, I ), LDB, ZERO, WORK( IWORK ), M ) 6413 CALL DLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ), 6414 $ LDB ) 6415 40 CONTINUE 6416 ELSE 6417 CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ), 6418 $ 1, ZERO, WORK( IWORK ), 1 ) 6419 CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 ) 6420 END IF 6421 CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) 6422 IWORK = ITAU + M 6423 CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, 6424 $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) 6425 ELSE 6426 IE = 1 6427 ITAUQ = IE + M 6428 ITAUP = ITAUQ + M 6429 IWORK = ITAUP + M 6430 CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), 6431 $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, 6432 $ INFO ) 6433 CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), 6434 $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) 6435 CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), 6436 $ WORK( IWORK ), LWORK-IWORK+1, INFO ) 6437 IWORK = IE + M 6438 CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, DUM, 6439 $ 1, B, LDB, WORK( IWORK ), INFO ) 6440 IF( INFO.NE.0 ) 6441 $ GO TO 70 6442 THR = MAX( RCOND*S( 1 ), SFMIN ) 6443 IF( RCOND.LT.ZERO ) 6444 $ THR = MAX( EPS*S( 1 ), SFMIN ) 6445 RANK = 0 6446 DO 50 I = 1, M 6447 IF( S( I ).GT.THR ) THEN 6448 CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) 6449 RANK = RANK + 1 6450 ELSE 6451 CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) 6452 END IF 6453 50 CONTINUE 6454 IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN 6455 CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO, 6456 $ WORK, LDB ) 6457 CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB ) 6458 ELSE IF( NRHS.GT.1 ) THEN 6459 CHUNK = LWORK / N 6460 DO 60 I = 1, NRHS, CHUNK 6461 BL = MIN( NRHS-I+1, CHUNK ) 6462 CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ), 6463 $ LDB, ZERO, WORK, N ) 6464 CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB ) 6465 60 CONTINUE 6466 ELSE 6467 CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) 6468 CALL DCOPY( N, WORK, 1, B, 1 ) 6469 END IF 6470 END IF 6471 IF( IASCL.EQ.1 ) THEN 6472 CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) 6473 CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, 6474 $ INFO ) 6475 ELSE IF( IASCL.EQ.2 ) THEN 6476 CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) 6477 CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, 6478 $ INFO ) 6479 END IF 6480 IF( IBSCL.EQ.1 ) THEN 6481 CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) 6482 ELSE IF( IBSCL.EQ.2 ) THEN 6483 CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) 6484 END IF 6485 70 CONTINUE 6486 WORK( 1 ) = MAXWRK 6487 RETURN 6488 END 6489! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgeqr2.f 6490 SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) 6491 INTEGER INFO, LDA, M, N 6492 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 6493 DOUBLE PRECISION ONE 6494 PARAMETER ( ONE = 1.0D+0 ) 6495 INTEGER I, K 6496 DOUBLE PRECISION AII 6497 EXTERNAL DLARF, DLARFG, XERBLA 6498 INTRINSIC MAX, MIN 6499 INFO = 0 6500 IF( M.LT.0 ) THEN 6501 INFO = -1 6502 ELSE IF( N.LT.0 ) THEN 6503 INFO = -2 6504 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 6505 INFO = -4 6506 END IF 6507 IF( INFO.NE.0 ) THEN 6508 CALL XERBLA( 'DGEQR2', -INFO ) 6509 RETURN 6510 END IF 6511 K = MIN( M, N ) 6512 DO 10 I = 1, K 6513 CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, 6514 $ TAU( I ) ) 6515 IF( I.LT.N ) THEN 6516 AII = A( I, I ) 6517 A( I, I ) = ONE 6518 CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), 6519 $ A( I, I+1 ), LDA, WORK ) 6520 A( I, I ) = AII 6521 END IF 6522 10 CONTINUE 6523 RETURN 6524 END 6525! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgeqrf.f 6526 SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) 6527 INTEGER INFO, LDA, LWORK, M, N 6528 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 6529 LOGICAL LQUERY 6530 INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, 6531 $ NBMIN, NX 6532 EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA 6533 INTRINSIC MAX, MIN 6534 INTEGER ILAENV 6535 EXTERNAL ILAENV 6536 INFO = 0 6537 NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) 6538 LWKOPT = N*NB 6539 WORK( 1 ) = LWKOPT 6540 LQUERY = ( LWORK.EQ.-1 ) 6541 IF( M.LT.0 ) THEN 6542 INFO = -1 6543 ELSE IF( N.LT.0 ) THEN 6544 INFO = -2 6545 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 6546 INFO = -4 6547 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 6548 INFO = -7 6549 END IF 6550 IF( INFO.NE.0 ) THEN 6551 CALL XERBLA( 'DGEQRF', -INFO ) 6552 RETURN 6553 ELSE IF( LQUERY ) THEN 6554 RETURN 6555 END IF 6556 K = MIN( M, N ) 6557 IF( K.EQ.0 ) THEN 6558 WORK( 1 ) = 1 6559 RETURN 6560 END IF 6561 NBMIN = 2 6562 NX = 0 6563 IWS = N 6564 IF( NB.GT.1 .AND. NB.LT.K ) THEN 6565 NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) 6566 IF( NX.LT.K ) THEN 6567 LDWORK = N 6568 IWS = LDWORK*NB 6569 IF( LWORK.LT.IWS ) THEN 6570 NB = LWORK / LDWORK 6571 NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, 6572 $ -1 ) ) 6573 END IF 6574 END IF 6575 END IF 6576 IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN 6577 DO 10 I = 1, K - NX, NB 6578 IB = MIN( K-I+1, NB ) 6579 CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, 6580 $ IINFO ) 6581 IF( I+IB.LE.N ) THEN 6582 CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, 6583 $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) 6584 CALL DLARFB( 'Left', 'Transpose', 'Forward', 6585 $ 'Columnwise', M-I+1, N-I-IB+1, IB, 6586 $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), 6587 $ LDA, WORK( IB+1 ), LDWORK ) 6588 END IF 6589 10 CONTINUE 6590 ELSE 6591 I = 1 6592 END IF 6593 IF( I.LE.K ) 6594 $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, 6595 $ IINFO ) 6596 WORK( 1 ) = IWS 6597 RETURN 6598 END 6599! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgesv.f 6600 SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 6601 INTEGER INFO, LDA, LDB, N, NRHS 6602 INTEGER IPIV( * ) 6603 DOUBLE PRECISION A( LDA, * ), B( LDB, * ) 6604 EXTERNAL DGETRF, DGETRS, XERBLA 6605 INTRINSIC MAX 6606 INFO = 0 6607 IF( N.LT.0 ) THEN 6608 INFO = -1 6609 ELSE IF( NRHS.LT.0 ) THEN 6610 INFO = -2 6611 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 6612 INFO = -4 6613 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 6614 INFO = -7 6615 END IF 6616 IF( INFO.NE.0 ) THEN 6617 CALL XERBLA( 'DGESV ', -INFO ) 6618 RETURN 6619 END IF 6620 CALL DGETRF( N, N, A, LDA, IPIV, INFO ) 6621 IF( INFO.EQ.0 ) THEN 6622 CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, 6623 $ INFO ) 6624 END IF 6625 RETURN 6626 END 6627! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgetrf.f 6628 SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) 6629 INTEGER INFO, LDA, M, N 6630 INTEGER IPIV( * ) 6631 DOUBLE PRECISION A( LDA, * ) 6632 DOUBLE PRECISION ONE 6633 PARAMETER ( ONE = 1.0D+0 ) 6634 INTEGER I, IINFO, J, JB, NB 6635 EXTERNAL DGEMM, DGETRF2, DLASWP, DTRSM, XERBLA 6636 INTEGER ILAENV 6637 EXTERNAL ILAENV 6638 INTRINSIC MAX, MIN 6639 INFO = 0 6640 IF( M.LT.0 ) THEN 6641 INFO = -1 6642 ELSE IF( N.LT.0 ) THEN 6643 INFO = -2 6644 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 6645 INFO = -4 6646 END IF 6647 IF( INFO.NE.0 ) THEN 6648 CALL XERBLA( 'DGETRF', -INFO ) 6649 RETURN 6650 END IF 6651 IF( M.EQ.0 .OR. N.EQ.0 ) 6652 $ RETURN 6653 NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) 6654 IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN 6655 CALL DGETRF2( M, N, A, LDA, IPIV, INFO ) 6656 ELSE 6657 DO 20 J = 1, MIN( M, N ), NB 6658 JB = MIN( MIN( M, N )-J+1, NB ) 6659 CALL DGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) 6660 IF( INFO.EQ.0 .AND. IINFO.GT.0 ) 6661 $ INFO = IINFO + J - 1 6662 DO 10 I = J, MIN( M, J+JB-1 ) 6663 IPIV( I ) = J - 1 + IPIV( I ) 6664 10 CONTINUE 6665 CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) 6666 IF( J+JB.LE.N ) THEN 6667 CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, 6668 $ IPIV, 1 ) 6669 CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, 6670 $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), 6671 $ LDA ) 6672 IF( J+JB.LE.M ) THEN 6673 CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, 6674 $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, 6675 $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), 6676 $ LDA ) 6677 END IF 6678 END IF 6679 20 CONTINUE 6680 END IF 6681 RETURN 6682 END 6683! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgetrf2.f 6684 RECURSIVE SUBROUTINE DGETRF2( M, N, A, LDA, IPIV, INFO ) 6685 INTEGER INFO, LDA, M, N 6686 INTEGER IPIV( * ) 6687 DOUBLE PRECISION A( LDA, * ) 6688 DOUBLE PRECISION ONE, ZERO 6689 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 6690 DOUBLE PRECISION SFMIN, TEMP 6691 INTEGER I, IINFO, N1, N2 6692 DOUBLE PRECISION DLAMCH 6693 INTEGER IDAMAX 6694 EXTERNAL DLAMCH, IDAMAX 6695 EXTERNAL DGEMM, DSCAL, DLASWP, DTRSM, XERBLA 6696 INTRINSIC MAX, MIN 6697 INFO = 0 6698 IF( M.LT.0 ) THEN 6699 INFO = -1 6700 ELSE IF( N.LT.0 ) THEN 6701 INFO = -2 6702 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 6703 INFO = -4 6704 END IF 6705 IF( INFO.NE.0 ) THEN 6706 CALL XERBLA( 'DGETRF2', -INFO ) 6707 RETURN 6708 END IF 6709 IF( M.EQ.0 .OR. N.EQ.0 ) 6710 $ RETURN 6711 IF ( M.EQ.1 ) THEN 6712 IPIV( 1 ) = 1 6713 IF ( A(1,1).EQ.ZERO ) 6714 $ INFO = 1 6715 ELSE IF( N.EQ.1 ) THEN 6716 SFMIN = DLAMCH('S') 6717 I = IDAMAX( M, A( 1, 1 ), 1 ) 6718 IPIV( 1 ) = I 6719 IF( A( I, 1 ).NE.ZERO ) THEN 6720 IF( I.NE.1 ) THEN 6721 TEMP = A( 1, 1 ) 6722 A( 1, 1 ) = A( I, 1 ) 6723 A( I, 1 ) = TEMP 6724 END IF 6725 IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN 6726 CALL DSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 ) 6727 ELSE 6728 DO 10 I = 1, M-1 6729 A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 ) 6730 10 CONTINUE 6731 END IF 6732 ELSE 6733 INFO = 1 6734 END IF 6735 ELSE 6736 N1 = MIN( M, N ) / 2 6737 N2 = N-N1 6738 CALL DGETRF2( M, N1, A, LDA, IPIV, IINFO ) 6739 IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) 6740 $ INFO = IINFO 6741 CALL DLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 ) 6742 CALL DTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, 6743 $ A( 1, N1+1 ), LDA ) 6744 CALL DGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, 6745 $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) 6746 CALL DGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ), 6747 $ IINFO ) 6748 IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) 6749 $ INFO = IINFO + N1 6750 DO 20 I = N1+1, MIN( M, N ) 6751 IPIV( I ) = IPIV( I ) + N1 6752 20 CONTINUE 6753 CALL DLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 ) 6754 END IF 6755 RETURN 6756 END 6757! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgetri.f 6758 SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) 6759 INTEGER INFO, LDA, LWORK, N 6760 INTEGER IPIV( * ) 6761 DOUBLE PRECISION A( LDA, * ), WORK( * ) 6762 DOUBLE PRECISION ZERO, ONE 6763 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 6764 LOGICAL LQUERY 6765 INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, 6766 $ NBMIN, NN 6767 INTEGER ILAENV 6768 EXTERNAL ILAENV 6769 EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA 6770 INTRINSIC MAX, MIN 6771 INFO = 0 6772 NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) 6773 LWKOPT = N*NB 6774 WORK( 1 ) = LWKOPT 6775 LQUERY = ( LWORK.EQ.-1 ) 6776 IF( N.LT.0 ) THEN 6777 INFO = -1 6778 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 6779 INFO = -3 6780 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 6781 INFO = -6 6782 END IF 6783 IF( INFO.NE.0 ) THEN 6784 CALL XERBLA( 'DGETRI', -INFO ) 6785 RETURN 6786 ELSE IF( LQUERY ) THEN 6787 RETURN 6788 END IF 6789 IF( N.EQ.0 ) 6790 $ RETURN 6791 CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) 6792 IF( INFO.GT.0 ) 6793 $ RETURN 6794 NBMIN = 2 6795 LDWORK = N 6796 IF( NB.GT.1 .AND. NB.LT.N ) THEN 6797 IWS = MAX( LDWORK*NB, 1 ) 6798 IF( LWORK.LT.IWS ) THEN 6799 NB = LWORK / LDWORK 6800 NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) 6801 END IF 6802 ELSE 6803 IWS = N 6804 END IF 6805 IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN 6806 DO 20 J = N, 1, -1 6807 DO 10 I = J + 1, N 6808 WORK( I ) = A( I, J ) 6809 A( I, J ) = ZERO 6810 10 CONTINUE 6811 IF( J.LT.N ) 6812 $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), 6813 $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) 6814 20 CONTINUE 6815 ELSE 6816 NN = ( ( N-1 ) / NB )*NB + 1 6817 DO 50 J = NN, 1, -NB 6818 JB = MIN( NB, N-J+1 ) 6819 DO 40 JJ = J, J + JB - 1 6820 DO 30 I = JJ + 1, N 6821 WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) 6822 A( I, JJ ) = ZERO 6823 30 CONTINUE 6824 40 CONTINUE 6825 IF( J+JB.LE.N ) 6826 $ CALL DGEMM( 'No transpose', 'No transpose', N, JB, 6827 $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, 6828 $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) 6829 CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, 6830 $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) 6831 50 CONTINUE 6832 END IF 6833 DO 60 J = N - 1, 1, -1 6834 JP = IPIV( J ) 6835 IF( JP.NE.J ) 6836 $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) 6837 60 CONTINUE 6838 WORK( 1 ) = IWS 6839 RETURN 6840 END 6841! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dgetrs.f 6842 SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 6843 CHARACTER TRANS 6844 INTEGER INFO, LDA, LDB, N, NRHS 6845 INTEGER IPIV( * ) 6846 DOUBLE PRECISION A( LDA, * ), B( LDB, * ) 6847 DOUBLE PRECISION ONE 6848 PARAMETER ( ONE = 1.0D+0 ) 6849 LOGICAL NOTRAN 6850 LOGICAL LSAME 6851 EXTERNAL LSAME 6852 EXTERNAL DLASWP, DTRSM, XERBLA 6853 INTRINSIC MAX 6854 INFO = 0 6855 NOTRAN = LSAME( TRANS, 'N' ) 6856 IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. 6857 $ LSAME( TRANS, 'C' ) ) THEN 6858 INFO = -1 6859 ELSE IF( N.LT.0 ) THEN 6860 INFO = -2 6861 ELSE IF( NRHS.LT.0 ) THEN 6862 INFO = -3 6863 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 6864 INFO = -5 6865 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 6866 INFO = -8 6867 END IF 6868 IF( INFO.NE.0 ) THEN 6869 CALL XERBLA( 'DGETRS', -INFO ) 6870 RETURN 6871 END IF 6872 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 6873 $ RETURN 6874 IF( NOTRAN ) THEN 6875 CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) 6876 CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, 6877 $ ONE, A, LDA, B, LDB ) 6878 CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, 6879 $ NRHS, ONE, A, LDA, B, LDB ) 6880 ELSE 6881 CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, 6882 $ ONE, A, LDA, B, LDB ) 6883 CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, 6884 $ A, LDA, B, LDB ) 6885 CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) 6886 END IF 6887 RETURN 6888 END 6889! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/disnan.f 6890 LOGICAL FUNCTION DISNAN( DIN ) 6891 DOUBLE PRECISION, INTENT(IN) :: DIN 6892 LOGICAL DLAISNAN 6893 EXTERNAL DLAISNAN 6894 DISNAN = DLAISNAN(DIN,DIN) 6895 RETURN 6896 END 6897! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dla_gbrcond.f 6898 DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, 6899 $ AFB, LDAFB, IPIV, CMODE, C, 6900 $ INFO, WORK, IWORK ) 6901 CHARACTER TRANS 6902 INTEGER N, LDAB, LDAFB, INFO, KL, KU, CMODE 6903 INTEGER IWORK( * ), IPIV( * ) 6904 DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), 6905 $ C( * ) 6906 LOGICAL NOTRANS 6907 INTEGER KASE, I, J, KD, KE 6908 DOUBLE PRECISION AINVNM, TMP 6909 INTEGER ISAVE( 3 ) 6910 LOGICAL LSAME 6911 EXTERNAL LSAME 6912 EXTERNAL DLACN2, DGBTRS, XERBLA 6913 INTRINSIC ABS, MAX 6914 DLA_GBRCOND = 0.0D+0 6915 INFO = 0 6916 NOTRANS = LSAME( TRANS, 'N' ) 6917 IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') 6918 $ .AND. .NOT. LSAME(TRANS, 'C') ) THEN 6919 INFO = -1 6920 ELSE IF( N.LT.0 ) THEN 6921 INFO = -2 6922 ELSE IF( KL.LT.0 .OR. KL.GT.N-1 ) THEN 6923 INFO = -3 6924 ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN 6925 INFO = -4 6926 ELSE IF( LDAB.LT.KL+KU+1 ) THEN 6927 INFO = -6 6928 ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN 6929 INFO = -8 6930 END IF 6931 IF( INFO.NE.0 ) THEN 6932 CALL XERBLA( 'DLA_GBRCOND', -INFO ) 6933 RETURN 6934 END IF 6935 IF( N.EQ.0 ) THEN 6936 DLA_GBRCOND = 1.0D+0 6937 RETURN 6938 END IF 6939 KD = KU + 1 6940 KE = KL + 1 6941 IF ( NOTRANS ) THEN 6942 DO I = 1, N 6943 TMP = 0.0D+0 6944 IF ( CMODE .EQ. 1 ) THEN 6945 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 6946 TMP = TMP + ABS( AB( KD+I-J, J ) * C( J ) ) 6947 END DO 6948 ELSE IF ( CMODE .EQ. 0 ) THEN 6949 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 6950 TMP = TMP + ABS( AB( KD+I-J, J ) ) 6951 END DO 6952 ELSE 6953 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 6954 TMP = TMP + ABS( AB( KD+I-J, J ) / C( J ) ) 6955 END DO 6956 END IF 6957 WORK( 2*N+I ) = TMP 6958 END DO 6959 ELSE 6960 DO I = 1, N 6961 TMP = 0.0D+0 6962 IF ( CMODE .EQ. 1 ) THEN 6963 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 6964 TMP = TMP + ABS( AB( KE-I+J, I ) * C( J ) ) 6965 END DO 6966 ELSE IF ( CMODE .EQ. 0 ) THEN 6967 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 6968 TMP = TMP + ABS( AB( KE-I+J, I ) ) 6969 END DO 6970 ELSE 6971 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 6972 TMP = TMP + ABS( AB( KE-I+J, I ) / C( J ) ) 6973 END DO 6974 END IF 6975 WORK( 2*N+I ) = TMP 6976 END DO 6977 END IF 6978 AINVNM = 0.0D+0 6979 KASE = 0 6980 10 CONTINUE 6981 CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) 6982 IF( KASE.NE.0 ) THEN 6983 IF( KASE.EQ.2 ) THEN 6984 DO I = 1, N 6985 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 6986 END DO 6987 IF ( NOTRANS ) THEN 6988 CALL DGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 6989 $ IPIV, WORK, N, INFO ) 6990 ELSE 6991 CALL DGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV, 6992 $ WORK, N, INFO ) 6993 END IF 6994 IF ( CMODE .EQ. 1 ) THEN 6995 DO I = 1, N 6996 WORK( I ) = WORK( I ) / C( I ) 6997 END DO 6998 ELSE IF ( CMODE .EQ. -1 ) THEN 6999 DO I = 1, N 7000 WORK( I ) = WORK( I ) * C( I ) 7001 END DO 7002 END IF 7003 ELSE 7004 IF ( CMODE .EQ. 1 ) THEN 7005 DO I = 1, N 7006 WORK( I ) = WORK( I ) / C( I ) 7007 END DO 7008 ELSE IF ( CMODE .EQ. -1 ) THEN 7009 DO I = 1, N 7010 WORK( I ) = WORK( I ) * C( I ) 7011 END DO 7012 END IF 7013 IF ( NOTRANS ) THEN 7014 CALL DGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV, 7015 $ WORK, N, INFO ) 7016 ELSE 7017 CALL DGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 7018 $ IPIV, WORK, N, INFO ) 7019 END IF 7020 DO I = 1, N 7021 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 7022 END DO 7023 END IF 7024 GO TO 10 7025 END IF 7026 IF( AINVNM .NE. 0.0D+0 ) 7027 $ DLA_GBRCOND = ( 1.0D+0 / AINVNM ) 7028 RETURN 7029 END 7030! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dla_gbrpvgrw.f 7031 DOUBLE PRECISION FUNCTION DLA_GBRPVGRW( N, KL, KU, NCOLS, AB, 7032 $ LDAB, AFB, LDAFB ) 7033 INTEGER N, KL, KU, NCOLS, LDAB, LDAFB 7034 DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ) 7035 INTEGER I, J, KD 7036 DOUBLE PRECISION AMAX, UMAX, RPVGRW 7037 INTRINSIC ABS, MAX, MIN 7038 RPVGRW = 1.0D+0 7039 KD = KU + 1 7040 DO J = 1, NCOLS 7041 AMAX = 0.0D+0 7042 UMAX = 0.0D+0 7043 DO I = MAX( J-KU, 1 ), MIN( J+KL, N ) 7044 AMAX = MAX( ABS( AB( KD+I-J, J)), AMAX ) 7045 END DO 7046 DO I = MAX( J-KU, 1 ), J 7047 UMAX = MAX( ABS( AFB( KD+I-J, J ) ), UMAX ) 7048 END DO 7049 IF ( UMAX /= 0.0D+0 ) THEN 7050 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 7051 END IF 7052 END DO 7053 DLA_GBRPVGRW = RPVGRW 7054 END 7055! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dla_gercond.f 7056 DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF, 7057 $ LDAF, IPIV, CMODE, C, 7058 $ INFO, WORK, IWORK ) 7059 CHARACTER TRANS 7060 INTEGER N, LDA, LDAF, INFO, CMODE 7061 INTEGER IPIV( * ), IWORK( * ) 7062 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), 7063 $ C( * ) 7064 LOGICAL NOTRANS 7065 INTEGER KASE, I, J 7066 DOUBLE PRECISION AINVNM, TMP 7067 INTEGER ISAVE( 3 ) 7068 LOGICAL LSAME 7069 EXTERNAL LSAME 7070 EXTERNAL DLACN2, DGETRS, XERBLA 7071 INTRINSIC ABS, MAX 7072 DLA_GERCOND = 0.0D+0 7073 INFO = 0 7074 NOTRANS = LSAME( TRANS, 'N' ) 7075 IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') 7076 $ .AND. .NOT. LSAME(TRANS, 'C') ) THEN 7077 INFO = -1 7078 ELSE IF( N.LT.0 ) THEN 7079 INFO = -2 7080 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 7081 INFO = -4 7082 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 7083 INFO = -6 7084 END IF 7085 IF( INFO.NE.0 ) THEN 7086 CALL XERBLA( 'DLA_GERCOND', -INFO ) 7087 RETURN 7088 END IF 7089 IF( N.EQ.0 ) THEN 7090 DLA_GERCOND = 1.0D+0 7091 RETURN 7092 END IF 7093 IF (NOTRANS) THEN 7094 DO I = 1, N 7095 TMP = 0.0D+0 7096 IF ( CMODE .EQ. 1 ) THEN 7097 DO J = 1, N 7098 TMP = TMP + ABS( A( I, J ) * C( J ) ) 7099 END DO 7100 ELSE IF ( CMODE .EQ. 0 ) THEN 7101 DO J = 1, N 7102 TMP = TMP + ABS( A( I, J ) ) 7103 END DO 7104 ELSE 7105 DO J = 1, N 7106 TMP = TMP + ABS( A( I, J ) / C( J ) ) 7107 END DO 7108 END IF 7109 WORK( 2*N+I ) = TMP 7110 END DO 7111 ELSE 7112 DO I = 1, N 7113 TMP = 0.0D+0 7114 IF ( CMODE .EQ. 1 ) THEN 7115 DO J = 1, N 7116 TMP = TMP + ABS( A( J, I ) * C( J ) ) 7117 END DO 7118 ELSE IF ( CMODE .EQ. 0 ) THEN 7119 DO J = 1, N 7120 TMP = TMP + ABS( A( J, I ) ) 7121 END DO 7122 ELSE 7123 DO J = 1, N 7124 TMP = TMP + ABS( A( J, I ) / C( J ) ) 7125 END DO 7126 END IF 7127 WORK( 2*N+I ) = TMP 7128 END DO 7129 END IF 7130 AINVNM = 0.0D+0 7131 KASE = 0 7132 10 CONTINUE 7133 CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) 7134 IF( KASE.NE.0 ) THEN 7135 IF( KASE.EQ.2 ) THEN 7136 DO I = 1, N 7137 WORK(I) = WORK(I) * WORK(2*N+I) 7138 END DO 7139 IF (NOTRANS) THEN 7140 CALL DGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 7141 $ WORK, N, INFO ) 7142 ELSE 7143 CALL DGETRS( 'Transpose', N, 1, AF, LDAF, IPIV, 7144 $ WORK, N, INFO ) 7145 END IF 7146 IF ( CMODE .EQ. 1 ) THEN 7147 DO I = 1, N 7148 WORK( I ) = WORK( I ) / C( I ) 7149 END DO 7150 ELSE IF ( CMODE .EQ. -1 ) THEN 7151 DO I = 1, N 7152 WORK( I ) = WORK( I ) * C( I ) 7153 END DO 7154 END IF 7155 ELSE 7156 IF ( CMODE .EQ. 1 ) THEN 7157 DO I = 1, N 7158 WORK( I ) = WORK( I ) / C( I ) 7159 END DO 7160 ELSE IF ( CMODE .EQ. -1 ) THEN 7161 DO I = 1, N 7162 WORK( I ) = WORK( I ) * C( I ) 7163 END DO 7164 END IF 7165 IF (NOTRANS) THEN 7166 CALL DGETRS( 'Transpose', N, 1, AF, LDAF, IPIV, 7167 $ WORK, N, INFO ) 7168 ELSE 7169 CALL DGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 7170 $ WORK, N, INFO ) 7171 END IF 7172 DO I = 1, N 7173 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 7174 END DO 7175 END IF 7176 GO TO 10 7177 END IF 7178 IF( AINVNM .NE. 0.0D+0 ) 7179 $ DLA_GERCOND = ( 1.0D+0 / AINVNM ) 7180 RETURN 7181 END 7182! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dla_gerpvgrw.f 7183 DOUBLE PRECISION FUNCTION DLA_GERPVGRW( N, NCOLS, A, LDA, AF, 7184 $ LDAF ) 7185 INTEGER N, NCOLS, LDA, LDAF 7186 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ) 7187 INTEGER I, J 7188 DOUBLE PRECISION AMAX, UMAX, RPVGRW 7189 INTRINSIC ABS, MAX, MIN 7190 RPVGRW = 1.0D+0 7191 DO J = 1, NCOLS 7192 AMAX = 0.0D+0 7193 UMAX = 0.0D+0 7194 DO I = 1, N 7195 AMAX = MAX( ABS( A( I, J ) ), AMAX ) 7196 END DO 7197 DO I = 1, J 7198 UMAX = MAX( ABS( AF( I, J ) ), UMAX ) 7199 END DO 7200 IF ( UMAX /= 0.0D+0 ) THEN 7201 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 7202 END IF 7203 END DO 7204 DLA_GERPVGRW = RPVGRW 7205 END 7206! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dla_porcond.f 7207 DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, 7208 $ CMODE, C, INFO, WORK, 7209 $ IWORK ) 7210 CHARACTER UPLO 7211 INTEGER N, LDA, LDAF, INFO, CMODE 7212 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), 7213 $ C( * ) 7214 INTEGER IWORK( * ) 7215 INTEGER KASE, I, J 7216 DOUBLE PRECISION AINVNM, TMP 7217 LOGICAL UP 7218 INTEGER ISAVE( 3 ) 7219 LOGICAL LSAME 7220 EXTERNAL LSAME 7221 EXTERNAL DLACN2, DPOTRS, XERBLA 7222 INTRINSIC ABS, MAX 7223 DLA_PORCOND = 0.0D+0 7224 INFO = 0 7225 IF( N.LT.0 ) THEN 7226 INFO = -2 7227 END IF 7228 IF( INFO.NE.0 ) THEN 7229 CALL XERBLA( 'DLA_PORCOND', -INFO ) 7230 RETURN 7231 END IF 7232 IF( N.EQ.0 ) THEN 7233 DLA_PORCOND = 1.0D+0 7234 RETURN 7235 END IF 7236 UP = .FALSE. 7237 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 7238 IF ( UP ) THEN 7239 DO I = 1, N 7240 TMP = 0.0D+0 7241 IF ( CMODE .EQ. 1 ) THEN 7242 DO J = 1, I 7243 TMP = TMP + ABS( A( J, I ) * C( J ) ) 7244 END DO 7245 DO J = I+1, N 7246 TMP = TMP + ABS( A( I, J ) * C( J ) ) 7247 END DO 7248 ELSE IF ( CMODE .EQ. 0 ) THEN 7249 DO J = 1, I 7250 TMP = TMP + ABS( A( J, I ) ) 7251 END DO 7252 DO J = I+1, N 7253 TMP = TMP + ABS( A( I, J ) ) 7254 END DO 7255 ELSE 7256 DO J = 1, I 7257 TMP = TMP + ABS( A( J ,I ) / C( J ) ) 7258 END DO 7259 DO J = I+1, N 7260 TMP = TMP + ABS( A( I, J ) / C( J ) ) 7261 END DO 7262 END IF 7263 WORK( 2*N+I ) = TMP 7264 END DO 7265 ELSE 7266 DO I = 1, N 7267 TMP = 0.0D+0 7268 IF ( CMODE .EQ. 1 ) THEN 7269 DO J = 1, I 7270 TMP = TMP + ABS( A( I, J ) * C( J ) ) 7271 END DO 7272 DO J = I+1, N 7273 TMP = TMP + ABS( A( J, I ) * C( J ) ) 7274 END DO 7275 ELSE IF ( CMODE .EQ. 0 ) THEN 7276 DO J = 1, I 7277 TMP = TMP + ABS( A( I, J ) ) 7278 END DO 7279 DO J = I+1, N 7280 TMP = TMP + ABS( A( J, I ) ) 7281 END DO 7282 ELSE 7283 DO J = 1, I 7284 TMP = TMP + ABS( A( I, J ) / C( J ) ) 7285 END DO 7286 DO J = I+1, N 7287 TMP = TMP + ABS( A( J, I ) / C( J ) ) 7288 END DO 7289 END IF 7290 WORK( 2*N+I ) = TMP 7291 END DO 7292 ENDIF 7293 AINVNM = 0.0D+0 7294 KASE = 0 7295 10 CONTINUE 7296 CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) 7297 IF( KASE.NE.0 ) THEN 7298 IF( KASE.EQ.2 ) THEN 7299 DO I = 1, N 7300 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 7301 END DO 7302 IF (UP) THEN 7303 CALL DPOTRS( 'Upper', N, 1, AF, LDAF, WORK, N, INFO ) 7304 ELSE 7305 CALL DPOTRS( 'Lower', N, 1, AF, LDAF, WORK, N, INFO ) 7306 ENDIF 7307 IF ( CMODE .EQ. 1 ) THEN 7308 DO I = 1, N 7309 WORK( I ) = WORK( I ) / C( I ) 7310 END DO 7311 ELSE IF ( CMODE .EQ. -1 ) THEN 7312 DO I = 1, N 7313 WORK( I ) = WORK( I ) * C( I ) 7314 END DO 7315 END IF 7316 ELSE 7317 IF ( CMODE .EQ. 1 ) THEN 7318 DO I = 1, N 7319 WORK( I ) = WORK( I ) / C( I ) 7320 END DO 7321 ELSE IF ( CMODE .EQ. -1 ) THEN 7322 DO I = 1, N 7323 WORK( I ) = WORK( I ) * C( I ) 7324 END DO 7325 END IF 7326 IF ( UP ) THEN 7327 CALL DPOTRS( 'Upper', N, 1, AF, LDAF, WORK, N, INFO ) 7328 ELSE 7329 CALL DPOTRS( 'Lower', N, 1, AF, LDAF, WORK, N, INFO ) 7330 ENDIF 7331 DO I = 1, N 7332 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 7333 END DO 7334 END IF 7335 GO TO 10 7336 END IF 7337 IF( AINVNM .NE. 0.0D+0 ) 7338 $ DLA_PORCOND = ( 1.0D+0 / AINVNM ) 7339 RETURN 7340 END 7341! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dla_porpvgrw.f 7342 DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, 7343 $ LDAF, WORK ) 7344 CHARACTER*1 UPLO 7345 INTEGER NCOLS, LDA, LDAF 7346 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) 7347 INTEGER I, J 7348 DOUBLE PRECISION AMAX, UMAX, RPVGRW 7349 LOGICAL UPPER 7350 INTRINSIC ABS, MAX, MIN 7351 EXTERNAL LSAME 7352 LOGICAL LSAME 7353 UPPER = LSAME( 'Upper', UPLO ) 7354 RPVGRW = 1.0D+0 7355 DO I = 1, 2*NCOLS 7356 WORK( I ) = 0.0D+0 7357 END DO 7358 IF ( UPPER ) THEN 7359 DO J = 1, NCOLS 7360 DO I = 1, J 7361 WORK( NCOLS+J ) = 7362 $ MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) ) 7363 END DO 7364 END DO 7365 ELSE 7366 DO J = 1, NCOLS 7367 DO I = J, NCOLS 7368 WORK( NCOLS+J ) = 7369 $ MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) ) 7370 END DO 7371 END DO 7372 END IF 7373 IF ( LSAME( 'Upper', UPLO ) ) THEN 7374 DO J = 1, NCOLS 7375 DO I = 1, J 7376 WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) ) 7377 END DO 7378 END DO 7379 ELSE 7380 DO J = 1, NCOLS 7381 DO I = J, NCOLS 7382 WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) ) 7383 END DO 7384 END DO 7385 END IF 7386 IF ( LSAME( 'Upper', UPLO ) ) THEN 7387 DO I = 1, NCOLS 7388 UMAX = WORK( I ) 7389 AMAX = WORK( NCOLS+I ) 7390 IF ( UMAX /= 0.0D+0 ) THEN 7391 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 7392 END IF 7393 END DO 7394 ELSE 7395 DO I = 1, NCOLS 7396 UMAX = WORK( I ) 7397 AMAX = WORK( NCOLS+I ) 7398 IF ( UMAX /= 0.0D+0 ) THEN 7399 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 7400 END IF 7401 END DO 7402 END IF 7403 DLA_PORPVGRW = RPVGRW 7404 END 7405! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dla_syrcond.f 7406 DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, 7407 $ IPIV, CMODE, C, INFO, WORK, 7408 $ IWORK ) 7409 CHARACTER UPLO 7410 INTEGER N, LDA, LDAF, INFO, CMODE 7411 INTEGER IWORK( * ), IPIV( * ) 7412 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * ) 7413 CHARACTER NORMIN 7414 INTEGER KASE, I, J 7415 DOUBLE PRECISION AINVNM, SMLNUM, TMP 7416 LOGICAL UP 7417 INTEGER ISAVE( 3 ) 7418 LOGICAL LSAME 7419 DOUBLE PRECISION DLAMCH 7420 EXTERNAL LSAME, DLAMCH 7421 EXTERNAL DLACN2, XERBLA, DSYTRS 7422 INTRINSIC ABS, MAX 7423 DLA_SYRCOND = 0.0D+0 7424 INFO = 0 7425 IF( N.LT.0 ) THEN 7426 INFO = -2 7427 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 7428 INFO = -4 7429 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 7430 INFO = -6 7431 END IF 7432 IF( INFO.NE.0 ) THEN 7433 CALL XERBLA( 'DLA_SYRCOND', -INFO ) 7434 RETURN 7435 END IF 7436 IF( N.EQ.0 ) THEN 7437 DLA_SYRCOND = 1.0D+0 7438 RETURN 7439 END IF 7440 UP = .FALSE. 7441 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 7442 IF ( UP ) THEN 7443 DO I = 1, N 7444 TMP = 0.0D+0 7445 IF ( CMODE .EQ. 1 ) THEN 7446 DO J = 1, I 7447 TMP = TMP + ABS( A( J, I ) * C( J ) ) 7448 END DO 7449 DO J = I+1, N 7450 TMP = TMP + ABS( A( I, J ) * C( J ) ) 7451 END DO 7452 ELSE IF ( CMODE .EQ. 0 ) THEN 7453 DO J = 1, I 7454 TMP = TMP + ABS( A( J, I ) ) 7455 END DO 7456 DO J = I+1, N 7457 TMP = TMP + ABS( A( I, J ) ) 7458 END DO 7459 ELSE 7460 DO J = 1, I 7461 TMP = TMP + ABS( A( J, I ) / C( J ) ) 7462 END DO 7463 DO J = I+1, N 7464 TMP = TMP + ABS( A( I, J ) / C( J ) ) 7465 END DO 7466 END IF 7467 WORK( 2*N+I ) = TMP 7468 END DO 7469 ELSE 7470 DO I = 1, N 7471 TMP = 0.0D+0 7472 IF ( CMODE .EQ. 1 ) THEN 7473 DO J = 1, I 7474 TMP = TMP + ABS( A( I, J ) * C( J ) ) 7475 END DO 7476 DO J = I+1, N 7477 TMP = TMP + ABS( A( J, I ) * C( J ) ) 7478 END DO 7479 ELSE IF ( CMODE .EQ. 0 ) THEN 7480 DO J = 1, I 7481 TMP = TMP + ABS( A( I, J ) ) 7482 END DO 7483 DO J = I+1, N 7484 TMP = TMP + ABS( A( J, I ) ) 7485 END DO 7486 ELSE 7487 DO J = 1, I 7488 TMP = TMP + ABS( A( I, J) / C( J ) ) 7489 END DO 7490 DO J = I+1, N 7491 TMP = TMP + ABS( A( J, I) / C( J ) ) 7492 END DO 7493 END IF 7494 WORK( 2*N+I ) = TMP 7495 END DO 7496 ENDIF 7497 SMLNUM = DLAMCH( 'Safe minimum' ) 7498 AINVNM = 0.0D+0 7499 NORMIN = 'N' 7500 KASE = 0 7501 10 CONTINUE 7502 CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) 7503 IF( KASE.NE.0 ) THEN 7504 IF( KASE.EQ.2 ) THEN 7505 DO I = 1, N 7506 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 7507 END DO 7508 IF ( UP ) THEN 7509 CALL DSYTRS( 'U', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) 7510 ELSE 7511 CALL DSYTRS( 'L', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) 7512 ENDIF 7513 IF ( CMODE .EQ. 1 ) THEN 7514 DO I = 1, N 7515 WORK( I ) = WORK( I ) / C( I ) 7516 END DO 7517 ELSE IF ( CMODE .EQ. -1 ) THEN 7518 DO I = 1, N 7519 WORK( I ) = WORK( I ) * C( I ) 7520 END DO 7521 END IF 7522 ELSE 7523 IF ( CMODE .EQ. 1 ) THEN 7524 DO I = 1, N 7525 WORK( I ) = WORK( I ) / C( I ) 7526 END DO 7527 ELSE IF ( CMODE .EQ. -1 ) THEN 7528 DO I = 1, N 7529 WORK( I ) = WORK( I ) * C( I ) 7530 END DO 7531 END IF 7532 IF ( UP ) THEN 7533 CALL DSYTRS( 'U', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) 7534 ELSE 7535 CALL DSYTRS( 'L', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) 7536 ENDIF 7537 DO I = 1, N 7538 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 7539 END DO 7540 END IF 7541 GO TO 10 7542 END IF 7543 IF( AINVNM .NE. 0.0D+0 ) 7544 $ DLA_SYRCOND = ( 1.0D+0 / AINVNM ) 7545 RETURN 7546 END 7547! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dla_syrpvgrw.f 7548 DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, 7549 $ LDAF, IPIV, WORK ) 7550 CHARACTER*1 UPLO 7551 INTEGER N, INFO, LDA, LDAF 7552 INTEGER IPIV( * ) 7553 DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) 7554 INTEGER NCOLS, I, J, K, KP 7555 DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP 7556 LOGICAL UPPER 7557 INTRINSIC ABS, MAX, MIN 7558 EXTERNAL LSAME 7559 LOGICAL LSAME 7560 UPPER = LSAME( 'Upper', UPLO ) 7561 IF ( INFO.EQ.0 ) THEN 7562 IF ( UPPER ) THEN 7563 NCOLS = 1 7564 ELSE 7565 NCOLS = N 7566 END IF 7567 ELSE 7568 NCOLS = INFO 7569 END IF 7570 RPVGRW = 1.0D+0 7571 DO I = 1, 2*N 7572 WORK( I ) = 0.0D+0 7573 END DO 7574 IF ( UPPER ) THEN 7575 DO J = 1, N 7576 DO I = 1, J 7577 WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) ) 7578 WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) ) 7579 END DO 7580 END DO 7581 ELSE 7582 DO J = 1, N 7583 DO I = J, N 7584 WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) ) 7585 WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) ) 7586 END DO 7587 END DO 7588 END IF 7589 IF ( UPPER ) THEN 7590 K = N 7591 DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) 7592 IF ( IPIV( K ).GT.0 ) THEN 7593 KP = IPIV( K ) 7594 IF ( KP .NE. K ) THEN 7595 TMP = WORK( N+K ) 7596 WORK( N+K ) = WORK( N+KP ) 7597 WORK( N+KP ) = TMP 7598 END IF 7599 DO I = 1, K 7600 WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) 7601 END DO 7602 K = K - 1 7603 ELSE 7604 KP = -IPIV( K ) 7605 TMP = WORK( N+K-1 ) 7606 WORK( N+K-1 ) = WORK( N+KP ) 7607 WORK( N+KP ) = TMP 7608 DO I = 1, K-1 7609 WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) 7610 WORK( K-1 ) = MAX( ABS( AF( I, K-1 ) ), WORK( K-1 ) ) 7611 END DO 7612 WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) ) 7613 K = K - 2 7614 END IF 7615 END DO 7616 K = NCOLS 7617 DO WHILE ( K .LE. N ) 7618 IF ( IPIV( K ).GT.0 ) THEN 7619 KP = IPIV( K ) 7620 IF ( KP .NE. K ) THEN 7621 TMP = WORK( N+K ) 7622 WORK( N+K ) = WORK( N+KP ) 7623 WORK( N+KP ) = TMP 7624 END IF 7625 K = K + 1 7626 ELSE 7627 KP = -IPIV( K ) 7628 TMP = WORK( N+K ) 7629 WORK( N+K ) = WORK( N+KP ) 7630 WORK( N+KP ) = TMP 7631 K = K + 2 7632 END IF 7633 END DO 7634 ELSE 7635 K = 1 7636 DO WHILE ( K .LE. NCOLS ) 7637 IF ( IPIV( K ).GT.0 ) THEN 7638 KP = IPIV( K ) 7639 IF ( KP .NE. K ) THEN 7640 TMP = WORK( N+K ) 7641 WORK( N+K ) = WORK( N+KP ) 7642 WORK( N+KP ) = TMP 7643 END IF 7644 DO I = K, N 7645 WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) 7646 END DO 7647 K = K + 1 7648 ELSE 7649 KP = -IPIV( K ) 7650 TMP = WORK( N+K+1 ) 7651 WORK( N+K+1 ) = WORK( N+KP ) 7652 WORK( N+KP ) = TMP 7653 DO I = K+1, N 7654 WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) 7655 WORK( K+1 ) = MAX( ABS( AF(I, K+1 ) ), WORK( K+1 ) ) 7656 END DO 7657 WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) ) 7658 K = K + 2 7659 END IF 7660 END DO 7661 K = NCOLS 7662 DO WHILE ( K .GE. 1 ) 7663 IF ( IPIV( K ).GT.0 ) THEN 7664 KP = IPIV( K ) 7665 IF ( KP .NE. K ) THEN 7666 TMP = WORK( N+K ) 7667 WORK( N+K ) = WORK( N+KP ) 7668 WORK( N+KP ) = TMP 7669 END IF 7670 K = K - 1 7671 ELSE 7672 KP = -IPIV( K ) 7673 TMP = WORK( N+K ) 7674 WORK( N+K ) = WORK( N+KP ) 7675 WORK( N+KP ) = TMP 7676 K = K - 2 7677 ENDIF 7678 END DO 7679 END IF 7680 IF ( UPPER ) THEN 7681 DO I = NCOLS, N 7682 UMAX = WORK( I ) 7683 AMAX = WORK( N+I ) 7684 IF ( UMAX /= 0.0D+0 ) THEN 7685 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 7686 END IF 7687 END DO 7688 ELSE 7689 DO I = 1, NCOLS 7690 UMAX = WORK( I ) 7691 AMAX = WORK( N+I ) 7692 IF ( UMAX /= 0.0D+0 ) THEN 7693 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 7694 END IF 7695 END DO 7696 END IF 7697 DLA_SYRPVGRW = RPVGRW 7698 END 7699! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlabad.f 7700 SUBROUTINE DLABAD( SMALL, LARGE ) 7701 DOUBLE PRECISION LARGE, SMALL 7702 INTRINSIC LOG10, SQRT 7703 IF( LOG10( LARGE ).GT.2000.D0 ) THEN 7704 SMALL = SQRT( SMALL ) 7705 LARGE = SQRT( LARGE ) 7706 END IF 7707 RETURN 7708 END 7709! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlabrd.f 7710 SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, 7711 $ LDY ) 7712 INTEGER LDA, LDX, LDY, M, N, NB 7713 DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), 7714 $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) 7715 DOUBLE PRECISION ZERO, ONE 7716 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 7717 INTEGER I 7718 EXTERNAL DGEMV, DLARFG, DSCAL 7719 INTRINSIC MIN 7720 IF( M.LE.0 .OR. N.LE.0 ) 7721 $ RETURN 7722 IF( M.GE.N ) THEN 7723 DO 10 I = 1, NB 7724 CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), 7725 $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) 7726 CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), 7727 $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) 7728 CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, 7729 $ TAUQ( I ) ) 7730 D( I ) = A( I, I ) 7731 IF( I.LT.N ) THEN 7732 A( I, I ) = ONE 7733 CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ), 7734 $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 ) 7735 CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA, 7736 $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) 7737 CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), 7738 $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) 7739 CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX, 7740 $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) 7741 CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), 7742 $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) 7743 CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) 7744 CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), 7745 $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) 7746 CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), 7747 $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA ) 7748 CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), 7749 $ LDA, TAUP( I ) ) 7750 E( I ) = A( I, I+1 ) 7751 A( I, I+1 ) = ONE 7752 CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), 7753 $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) 7754 CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY, 7755 $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) 7756 CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), 7757 $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) 7758 CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), 7759 $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) 7760 CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), 7761 $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) 7762 CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) 7763 END IF 7764 10 CONTINUE 7765 ELSE 7766 DO 20 I = 1, NB 7767 CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), 7768 $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) 7769 CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA, 7770 $ X( I, 1 ), LDX, ONE, A( I, I ), LDA ) 7771 CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, 7772 $ TAUP( I ) ) 7773 D( I ) = A( I, I ) 7774 IF( I.LT.M ) THEN 7775 A( I, I ) = ONE 7776 CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), 7777 $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) 7778 CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY, 7779 $ A( I, I ), LDA, ZERO, X( 1, I ), 1 ) 7780 CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), 7781 $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) 7782 CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), 7783 $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) 7784 CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), 7785 $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) 7786 CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) 7787 CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), 7788 $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) 7789 CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), 7790 $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) 7791 CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, 7792 $ TAUQ( I ) ) 7793 E( I ) = A( I+1, I ) 7794 A( I+1, I ) = ONE 7795 CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ), 7796 $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 ) 7797 CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA, 7798 $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) 7799 CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), 7800 $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) 7801 CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX, 7802 $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) 7803 CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA, 7804 $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) 7805 CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) 7806 END IF 7807 20 CONTINUE 7808 END IF 7809 RETURN 7810 END 7811! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlacn2.f 7812 SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) 7813 INTEGER KASE, N 7814 DOUBLE PRECISION EST 7815 INTEGER ISGN( * ), ISAVE( 3 ) 7816 DOUBLE PRECISION V( * ), X( * ) 7817 INTEGER ITMAX 7818 PARAMETER ( ITMAX = 5 ) 7819 DOUBLE PRECISION ZERO, ONE, TWO 7820 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) 7821 INTEGER I, JLAST 7822 DOUBLE PRECISION ALTSGN, ESTOLD, TEMP, XS 7823 INTEGER IDAMAX 7824 DOUBLE PRECISION DASUM 7825 EXTERNAL IDAMAX, DASUM 7826 EXTERNAL DCOPY 7827 INTRINSIC ABS, DBLE, NINT 7828 IF( KASE.EQ.0 ) THEN 7829 DO 10 I = 1, N 7830 X( I ) = ONE / DBLE( N ) 7831 10 CONTINUE 7832 KASE = 1 7833 ISAVE( 1 ) = 1 7834 RETURN 7835 END IF 7836 GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 ) 7837 20 CONTINUE 7838 IF( N.EQ.1 ) THEN 7839 V( 1 ) = X( 1 ) 7840 EST = ABS( V( 1 ) ) 7841 GO TO 150 7842 END IF 7843 EST = DASUM( N, X, 1 ) 7844 DO 30 I = 1, N 7845 IF( X(I).GE.ZERO ) THEN 7846 X(I) = ONE 7847 ELSE 7848 X(I) = -ONE 7849 END IF 7850 ISGN( I ) = NINT( X( I ) ) 7851 30 CONTINUE 7852 KASE = 2 7853 ISAVE( 1 ) = 2 7854 RETURN 7855 40 CONTINUE 7856 ISAVE( 2 ) = IDAMAX( N, X, 1 ) 7857 ISAVE( 3 ) = 2 7858 50 CONTINUE 7859 DO 60 I = 1, N 7860 X( I ) = ZERO 7861 60 CONTINUE 7862 X( ISAVE( 2 ) ) = ONE 7863 KASE = 1 7864 ISAVE( 1 ) = 3 7865 RETURN 7866 70 CONTINUE 7867 CALL DCOPY( N, X, 1, V, 1 ) 7868 ESTOLD = EST 7869 EST = DASUM( N, V, 1 ) 7870 DO 80 I = 1, N 7871 IF( X(I).GE.ZERO ) THEN 7872 XS = ONE 7873 ELSE 7874 XS = -ONE 7875 END IF 7876 IF( NINT( XS ).NE.ISGN( I ) ) 7877 $ GO TO 90 7878 80 CONTINUE 7879 GO TO 120 7880 90 CONTINUE 7881 IF( EST.LE.ESTOLD ) 7882 $ GO TO 120 7883 DO 100 I = 1, N 7884 IF( X(I).GE.ZERO ) THEN 7885 X(I) = ONE 7886 ELSE 7887 X(I) = -ONE 7888 END IF 7889 ISGN( I ) = NINT( X( I ) ) 7890 100 CONTINUE 7891 KASE = 2 7892 ISAVE( 1 ) = 4 7893 RETURN 7894 110 CONTINUE 7895 JLAST = ISAVE( 2 ) 7896 ISAVE( 2 ) = IDAMAX( N, X, 1 ) 7897 IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. 7898 $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN 7899 ISAVE( 3 ) = ISAVE( 3 ) + 1 7900 GO TO 50 7901 END IF 7902 120 CONTINUE 7903 ALTSGN = ONE 7904 DO 130 I = 1, N 7905 X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) 7906 ALTSGN = -ALTSGN 7907 130 CONTINUE 7908 KASE = 1 7909 ISAVE( 1 ) = 5 7910 RETURN 7911 140 CONTINUE 7912 TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) 7913 IF( TEMP.GT.EST ) THEN 7914 CALL DCOPY( N, X, 1, V, 1 ) 7915 EST = TEMP 7916 END IF 7917 150 CONTINUE 7918 KASE = 0 7919 RETURN 7920 END 7921! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlacpy.f 7922 SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) 7923 CHARACTER UPLO 7924 INTEGER LDA, LDB, M, N 7925 DOUBLE PRECISION A( LDA, * ), B( LDB, * ) 7926 INTEGER I, J 7927 LOGICAL LSAME 7928 EXTERNAL LSAME 7929 INTRINSIC MIN 7930 IF( LSAME( UPLO, 'U' ) ) THEN 7931 DO 20 J = 1, N 7932 DO 10 I = 1, MIN( J, M ) 7933 B( I, J ) = A( I, J ) 7934 10 CONTINUE 7935 20 CONTINUE 7936 ELSE IF( LSAME( UPLO, 'L' ) ) THEN 7937 DO 40 J = 1, N 7938 DO 30 I = J, M 7939 B( I, J ) = A( I, J ) 7940 30 CONTINUE 7941 40 CONTINUE 7942 ELSE 7943 DO 60 J = 1, N 7944 DO 50 I = 1, M 7945 B( I, J ) = A( I, J ) 7946 50 CONTINUE 7947 60 CONTINUE 7948 END IF 7949 RETURN 7950 END 7951! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dladiv.f 7952 SUBROUTINE DLADIV( A, B, C, D, P, Q ) 7953 DOUBLE PRECISION A, B, C, D, P, Q 7954 DOUBLE PRECISION BS 7955 PARAMETER ( BS = 2.0D0 ) 7956 DOUBLE PRECISION HALF 7957 PARAMETER ( HALF = 0.5D0 ) 7958 DOUBLE PRECISION TWO 7959 PARAMETER ( TWO = 2.0D0 ) 7960 DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS 7961 DOUBLE PRECISION DLAMCH 7962 EXTERNAL DLAMCH 7963 EXTERNAL DLADIV1 7964 INTRINSIC ABS, MAX 7965 AA = A 7966 BB = B 7967 CC = C 7968 DD = D 7969 AB = MAX( ABS(A), ABS(B) ) 7970 CD = MAX( ABS(C), ABS(D) ) 7971 S = 1.0D0 7972 OV = DLAMCH( 'Overflow threshold' ) 7973 UN = DLAMCH( 'Safe minimum' ) 7974 EPS = DLAMCH( 'Epsilon' ) 7975 BE = BS / (EPS*EPS) 7976 IF( AB >= HALF*OV ) THEN 7977 AA = HALF * AA 7978 BB = HALF * BB 7979 S = TWO * S 7980 END IF 7981 IF( CD >= HALF*OV ) THEN 7982 CC = HALF * CC 7983 DD = HALF * DD 7984 S = HALF * S 7985 END IF 7986 IF( AB <= UN*BS/EPS ) THEN 7987 AA = AA * BE 7988 BB = BB * BE 7989 S = S / BE 7990 END IF 7991 IF( CD <= UN*BS/EPS ) THEN 7992 CC = CC * BE 7993 DD = DD * BE 7994 S = S * BE 7995 END IF 7996 IF( ABS( D ).LE.ABS( C ) ) THEN 7997 CALL DLADIV1(AA, BB, CC, DD, P, Q) 7998 ELSE 7999 CALL DLADIV1(BB, AA, DD, CC, P, Q) 8000 Q = -Q 8001 END IF 8002 P = P * S 8003 Q = Q * S 8004 RETURN 8005 END 8006 SUBROUTINE DLADIV1( A, B, C, D, P, Q ) 8007 DOUBLE PRECISION A, B, C, D, P, Q 8008 DOUBLE PRECISION ONE 8009 PARAMETER ( ONE = 1.0D0 ) 8010 DOUBLE PRECISION R, T 8011 DOUBLE PRECISION DLADIV2 8012 EXTERNAL DLADIV2 8013 R = D / C 8014 T = ONE / (C + D * R) 8015 P = DLADIV2(A, B, C, D, R, T) 8016 A = -A 8017 Q = DLADIV2(B, A, C, D, R, T) 8018 RETURN 8019 END 8020 DOUBLE PRECISION FUNCTION DLADIV2( A, B, C, D, R, T ) 8021 DOUBLE PRECISION A, B, C, D, R, T 8022 DOUBLE PRECISION ZERO 8023 PARAMETER ( ZERO = 0.0D0 ) 8024 DOUBLE PRECISION BR 8025 IF( R.NE.ZERO ) THEN 8026 BR = B * R 8027 IF( BR.NE.ZERO ) THEN 8028 DLADIV2 = (A + BR) * T 8029 ELSE 8030 DLADIV2 = A * T + (B * T) * R 8031 END IF 8032 ELSE 8033 DLADIV2 = (A + D * (B / C)) * T 8034 END IF 8035 RETURN 8036 END 8037! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlae2.f 8038 SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) 8039 DOUBLE PRECISION A, B, C, RT1, RT2 8040 DOUBLE PRECISION ONE 8041 PARAMETER ( ONE = 1.0D0 ) 8042 DOUBLE PRECISION TWO 8043 PARAMETER ( TWO = 2.0D0 ) 8044 DOUBLE PRECISION ZERO 8045 PARAMETER ( ZERO = 0.0D0 ) 8046 DOUBLE PRECISION HALF 8047 PARAMETER ( HALF = 0.5D0 ) 8048 DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB 8049 INTRINSIC ABS, SQRT 8050 SM = A + C 8051 DF = A - C 8052 ADF = ABS( DF ) 8053 TB = B + B 8054 AB = ABS( TB ) 8055 IF( ABS( A ).GT.ABS( C ) ) THEN 8056 ACMX = A 8057 ACMN = C 8058 ELSE 8059 ACMX = C 8060 ACMN = A 8061 END IF 8062 IF( ADF.GT.AB ) THEN 8063 RT = ADF*SQRT( ONE+( AB / ADF )**2 ) 8064 ELSE IF( ADF.LT.AB ) THEN 8065 RT = AB*SQRT( ONE+( ADF / AB )**2 ) 8066 ELSE 8067 RT = AB*SQRT( TWO ) 8068 END IF 8069 IF( SM.LT.ZERO ) THEN 8070 RT1 = HALF*( SM-RT ) 8071 RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B 8072 ELSE IF( SM.GT.ZERO ) THEN 8073 RT1 = HALF*( SM+RT ) 8074 RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B 8075 ELSE 8076 RT1 = HALF*RT 8077 RT2 = -HALF*RT 8078 END IF 8079 RETURN 8080 END 8081! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaebz.f 8082 SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, 8083 $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, 8084 $ NAB, WORK, IWORK, INFO ) 8085 INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX 8086 DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL 8087 INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) 8088 DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), 8089 $ WORK( * ) 8090 DOUBLE PRECISION ZERO, TWO, HALF 8091 PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, 8092 $ HALF = 1.0D0 / TWO ) 8093 INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL, 8094 $ KLNEW 8095 DOUBLE PRECISION TMP1, TMP2 8096 INTRINSIC ABS, MAX, MIN 8097 INFO = 0 8098 IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN 8099 INFO = -1 8100 RETURN 8101 END IF 8102 IF( IJOB.EQ.1 ) THEN 8103 MOUT = 0 8104 DO 30 JI = 1, MINP 8105 DO 20 JP = 1, 2 8106 TMP1 = D( 1 ) - AB( JI, JP ) 8107 IF( ABS( TMP1 ).LT.PIVMIN ) 8108 $ TMP1 = -PIVMIN 8109 NAB( JI, JP ) = 0 8110 IF( TMP1.LE.ZERO ) 8111 $ NAB( JI, JP ) = 1 8112 DO 10 J = 2, N 8113 TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP ) 8114 IF( ABS( TMP1 ).LT.PIVMIN ) 8115 $ TMP1 = -PIVMIN 8116 IF( TMP1.LE.ZERO ) 8117 $ NAB( JI, JP ) = NAB( JI, JP ) + 1 8118 10 CONTINUE 8119 20 CONTINUE 8120 MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 ) 8121 30 CONTINUE 8122 RETURN 8123 END IF 8124 KF = 1 8125 KL = MINP 8126 IF( IJOB.EQ.2 ) THEN 8127 DO 40 JI = 1, MINP 8128 C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) 8129 40 CONTINUE 8130 END IF 8131 DO 130 JIT = 1, NITMAX 8132 IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN 8133 DO 60 JI = KF, KL 8134 WORK( JI ) = D( 1 ) - C( JI ) 8135 IWORK( JI ) = 0 8136 IF( WORK( JI ).LE.PIVMIN ) THEN 8137 IWORK( JI ) = 1 8138 WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) 8139 END IF 8140 DO 50 J = 2, N 8141 WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI ) 8142 IF( WORK( JI ).LE.PIVMIN ) THEN 8143 IWORK( JI ) = IWORK( JI ) + 1 8144 WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) 8145 END IF 8146 50 CONTINUE 8147 60 CONTINUE 8148 IF( IJOB.LE.2 ) THEN 8149 KLNEW = KL 8150 DO 70 JI = KF, KL 8151 IWORK( JI ) = MIN( NAB( JI, 2 ), 8152 $ MAX( NAB( JI, 1 ), IWORK( JI ) ) ) 8153 IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN 8154 AB( JI, 2 ) = C( JI ) 8155 ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN 8156 AB( JI, 1 ) = C( JI ) 8157 ELSE 8158 KLNEW = KLNEW + 1 8159 IF( KLNEW.LE.MMAX ) THEN 8160 AB( KLNEW, 2 ) = AB( JI, 2 ) 8161 NAB( KLNEW, 2 ) = NAB( JI, 2 ) 8162 AB( KLNEW, 1 ) = C( JI ) 8163 NAB( KLNEW, 1 ) = IWORK( JI ) 8164 AB( JI, 2 ) = C( JI ) 8165 NAB( JI, 2 ) = IWORK( JI ) 8166 ELSE 8167 INFO = MMAX + 1 8168 END IF 8169 END IF 8170 70 CONTINUE 8171 IF( INFO.NE.0 ) 8172 $ RETURN 8173 KL = KLNEW 8174 ELSE 8175 DO 80 JI = KF, KL 8176 IF( IWORK( JI ).LE.NVAL( JI ) ) THEN 8177 AB( JI, 1 ) = C( JI ) 8178 NAB( JI, 1 ) = IWORK( JI ) 8179 END IF 8180 IF( IWORK( JI ).GE.NVAL( JI ) ) THEN 8181 AB( JI, 2 ) = C( JI ) 8182 NAB( JI, 2 ) = IWORK( JI ) 8183 END IF 8184 80 CONTINUE 8185 END IF 8186 ELSE 8187 KLNEW = KL 8188 DO 100 JI = KF, KL 8189 TMP1 = C( JI ) 8190 TMP2 = D( 1 ) - TMP1 8191 ITMP1 = 0 8192 IF( TMP2.LE.PIVMIN ) THEN 8193 ITMP1 = 1 8194 TMP2 = MIN( TMP2, -PIVMIN ) 8195 END IF 8196 DO 90 J = 2, N 8197 TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1 8198 IF( TMP2.LE.PIVMIN ) THEN 8199 ITMP1 = ITMP1 + 1 8200 TMP2 = MIN( TMP2, -PIVMIN ) 8201 END IF 8202 90 CONTINUE 8203 IF( IJOB.LE.2 ) THEN 8204 ITMP1 = MIN( NAB( JI, 2 ), 8205 $ MAX( NAB( JI, 1 ), ITMP1 ) ) 8206 IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN 8207 AB( JI, 2 ) = TMP1 8208 ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN 8209 AB( JI, 1 ) = TMP1 8210 ELSE IF( KLNEW.LT.MMAX ) THEN 8211 KLNEW = KLNEW + 1 8212 AB( KLNEW, 2 ) = AB( JI, 2 ) 8213 NAB( KLNEW, 2 ) = NAB( JI, 2 ) 8214 AB( KLNEW, 1 ) = TMP1 8215 NAB( KLNEW, 1 ) = ITMP1 8216 AB( JI, 2 ) = TMP1 8217 NAB( JI, 2 ) = ITMP1 8218 ELSE 8219 INFO = MMAX + 1 8220 RETURN 8221 END IF 8222 ELSE 8223 IF( ITMP1.LE.NVAL( JI ) ) THEN 8224 AB( JI, 1 ) = TMP1 8225 NAB( JI, 1 ) = ITMP1 8226 END IF 8227 IF( ITMP1.GE.NVAL( JI ) ) THEN 8228 AB( JI, 2 ) = TMP1 8229 NAB( JI, 2 ) = ITMP1 8230 END IF 8231 END IF 8232 100 CONTINUE 8233 KL = KLNEW 8234 END IF 8235 KFNEW = KF 8236 DO 110 JI = KF, KL 8237 TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) ) 8238 TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) ) 8239 IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR. 8240 $ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN 8241 IF( JI.GT.KFNEW ) THEN 8242 TMP1 = AB( JI, 1 ) 8243 TMP2 = AB( JI, 2 ) 8244 ITMP1 = NAB( JI, 1 ) 8245 ITMP2 = NAB( JI, 2 ) 8246 AB( JI, 1 ) = AB( KFNEW, 1 ) 8247 AB( JI, 2 ) = AB( KFNEW, 2 ) 8248 NAB( JI, 1 ) = NAB( KFNEW, 1 ) 8249 NAB( JI, 2 ) = NAB( KFNEW, 2 ) 8250 AB( KFNEW, 1 ) = TMP1 8251 AB( KFNEW, 2 ) = TMP2 8252 NAB( KFNEW, 1 ) = ITMP1 8253 NAB( KFNEW, 2 ) = ITMP2 8254 IF( IJOB.EQ.3 ) THEN 8255 ITMP1 = NVAL( JI ) 8256 NVAL( JI ) = NVAL( KFNEW ) 8257 NVAL( KFNEW ) = ITMP1 8258 END IF 8259 END IF 8260 KFNEW = KFNEW + 1 8261 END IF 8262 110 CONTINUE 8263 KF = KFNEW 8264 DO 120 JI = KF, KL 8265 C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) 8266 120 CONTINUE 8267 IF( KF.GT.KL ) 8268 $ GO TO 140 8269 130 CONTINUE 8270 140 CONTINUE 8271 INFO = MAX( KL+1-KF, 0 ) 8272 MOUT = KL 8273 RETURN 8274 END 8275! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaed0.f 8276 SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, 8277 $ WORK, IWORK, INFO ) 8278 INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ 8279 INTEGER IWORK( * ) 8280 DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ), 8281 $ WORK( * ) 8282 DOUBLE PRECISION ZERO, ONE, TWO 8283 PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 ) 8284 INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM, 8285 $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM, 8286 $ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1, 8287 $ SPM2, SUBMAT, SUBPBS, TLVLS 8288 DOUBLE PRECISION TEMP 8289 EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR, 8290 $ XERBLA 8291 INTEGER ILAENV 8292 EXTERNAL ILAENV 8293 INTRINSIC ABS, DBLE, INT, LOG, MAX 8294 INFO = 0 8295 IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN 8296 INFO = -1 8297 ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN 8298 INFO = -2 8299 ELSE IF( N.LT.0 ) THEN 8300 INFO = -3 8301 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN 8302 INFO = -7 8303 ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN 8304 INFO = -9 8305 END IF 8306 IF( INFO.NE.0 ) THEN 8307 CALL XERBLA( 'DLAED0', -INFO ) 8308 RETURN 8309 END IF 8310 IF( N.EQ.0 ) 8311 $ RETURN 8312 SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 ) 8313 IWORK( 1 ) = N 8314 SUBPBS = 1 8315 TLVLS = 0 8316 10 CONTINUE 8317 IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN 8318 DO 20 J = SUBPBS, 1, -1 8319 IWORK( 2*J ) = ( IWORK( J )+1 ) / 2 8320 IWORK( 2*J-1 ) = IWORK( J ) / 2 8321 20 CONTINUE 8322 TLVLS = TLVLS + 1 8323 SUBPBS = 2*SUBPBS 8324 GO TO 10 8325 END IF 8326 DO 30 J = 2, SUBPBS 8327 IWORK( J ) = IWORK( J ) + IWORK( J-1 ) 8328 30 CONTINUE 8329 SPM1 = SUBPBS - 1 8330 DO 40 I = 1, SPM1 8331 SUBMAT = IWORK( I ) + 1 8332 SMM1 = SUBMAT - 1 8333 D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) ) 8334 D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) ) 8335 40 CONTINUE 8336 INDXQ = 4*N + 3 8337 IF( ICOMPQ.NE.2 ) THEN 8338 TEMP = LOG( DBLE( N ) ) / LOG( TWO ) 8339 LGN = INT( TEMP ) 8340 IF( 2**LGN.LT.N ) 8341 $ LGN = LGN + 1 8342 IF( 2**LGN.LT.N ) 8343 $ LGN = LGN + 1 8344 IPRMPT = INDXQ + N + 1 8345 IPERM = IPRMPT + N*LGN 8346 IQPTR = IPERM + N*LGN 8347 IGIVPT = IQPTR + N + 2 8348 IGIVCL = IGIVPT + N*LGN 8349 IGIVNM = 1 8350 IQ = IGIVNM + 2*N*LGN 8351 IWREM = IQ + N**2 + 1 8352 DO 50 I = 0, SUBPBS 8353 IWORK( IPRMPT+I ) = 1 8354 IWORK( IGIVPT+I ) = 1 8355 50 CONTINUE 8356 IWORK( IQPTR ) = 1 8357 END IF 8358 CURR = 0 8359 DO 70 I = 0, SPM1 8360 IF( I.EQ.0 ) THEN 8361 SUBMAT = 1 8362 MATSIZ = IWORK( 1 ) 8363 ELSE 8364 SUBMAT = IWORK( I ) + 1 8365 MATSIZ = IWORK( I+1 ) - IWORK( I ) 8366 END IF 8367 IF( ICOMPQ.EQ.2 ) THEN 8368 CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), 8369 $ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO ) 8370 IF( INFO.NE.0 ) 8371 $ GO TO 130 8372 ELSE 8373 CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), 8374 $ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK, 8375 $ INFO ) 8376 IF( INFO.NE.0 ) 8377 $ GO TO 130 8378 IF( ICOMPQ.EQ.1 ) THEN 8379 CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE, 8380 $ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+ 8381 $ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ), 8382 $ LDQS ) 8383 END IF 8384 IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2 8385 CURR = CURR + 1 8386 END IF 8387 K = 1 8388 DO 60 J = SUBMAT, IWORK( I+1 ) 8389 IWORK( INDXQ+J ) = K 8390 K = K + 1 8391 60 CONTINUE 8392 70 CONTINUE 8393 CURLVL = 1 8394 80 CONTINUE 8395 IF( SUBPBS.GT.1 ) THEN 8396 SPM2 = SUBPBS - 2 8397 DO 90 I = 0, SPM2, 2 8398 IF( I.EQ.0 ) THEN 8399 SUBMAT = 1 8400 MATSIZ = IWORK( 2 ) 8401 MSD2 = IWORK( 1 ) 8402 CURPRB = 0 8403 ELSE 8404 SUBMAT = IWORK( I ) + 1 8405 MATSIZ = IWORK( I+2 ) - IWORK( I ) 8406 MSD2 = MATSIZ / 2 8407 CURPRB = CURPRB + 1 8408 END IF 8409 IF( ICOMPQ.EQ.2 ) THEN 8410 CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ), 8411 $ LDQ, IWORK( INDXQ+SUBMAT ), 8412 $ E( SUBMAT+MSD2-1 ), MSD2, WORK, 8413 $ IWORK( SUBPBS+1 ), INFO ) 8414 ELSE 8415 CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB, 8416 $ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS, 8417 $ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ), 8418 $ MSD2, WORK( IQ ), IWORK( IQPTR ), 8419 $ IWORK( IPRMPT ), IWORK( IPERM ), 8420 $ IWORK( IGIVPT ), IWORK( IGIVCL ), 8421 $ WORK( IGIVNM ), WORK( IWREM ), 8422 $ IWORK( SUBPBS+1 ), INFO ) 8423 END IF 8424 IF( INFO.NE.0 ) 8425 $ GO TO 130 8426 IWORK( I / 2+1 ) = IWORK( I+2 ) 8427 90 CONTINUE 8428 SUBPBS = SUBPBS / 2 8429 CURLVL = CURLVL + 1 8430 GO TO 80 8431 END IF 8432 IF( ICOMPQ.EQ.1 ) THEN 8433 DO 100 I = 1, N 8434 J = IWORK( INDXQ+I ) 8435 WORK( I ) = D( J ) 8436 CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 ) 8437 100 CONTINUE 8438 CALL DCOPY( N, WORK, 1, D, 1 ) 8439 ELSE IF( ICOMPQ.EQ.2 ) THEN 8440 DO 110 I = 1, N 8441 J = IWORK( INDXQ+I ) 8442 WORK( I ) = D( J ) 8443 CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 ) 8444 110 CONTINUE 8445 CALL DCOPY( N, WORK, 1, D, 1 ) 8446 CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ ) 8447 ELSE 8448 DO 120 I = 1, N 8449 J = IWORK( INDXQ+I ) 8450 WORK( I ) = D( J ) 8451 120 CONTINUE 8452 CALL DCOPY( N, WORK, 1, D, 1 ) 8453 END IF 8454 GO TO 140 8455 130 CONTINUE 8456 INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 8457 140 CONTINUE 8458 RETURN 8459 END 8460! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaed1.f 8461 SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, 8462 $ INFO ) 8463 INTEGER CUTPNT, INFO, LDQ, N 8464 DOUBLE PRECISION RHO 8465 INTEGER INDXQ( * ), IWORK( * ) 8466 DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * ) 8467 INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS, 8468 $ IW, IZ, K, N1, N2, ZPP1 8469 EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA 8470 INTRINSIC MAX, MIN 8471 INFO = 0 8472 IF( N.LT.0 ) THEN 8473 INFO = -1 8474 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN 8475 INFO = -4 8476 ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN 8477 INFO = -7 8478 END IF 8479 IF( INFO.NE.0 ) THEN 8480 CALL XERBLA( 'DLAED1', -INFO ) 8481 RETURN 8482 END IF 8483 IF( N.EQ.0 ) 8484 $ RETURN 8485 IZ = 1 8486 IDLMDA = IZ + N 8487 IW = IDLMDA + N 8488 IQ2 = IW + N 8489 INDX = 1 8490 INDXC = INDX + N 8491 COLTYP = INDXC + N 8492 INDXP = COLTYP + N 8493 CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 ) 8494 ZPP1 = CUTPNT + 1 8495 CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 ) 8496 CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ), 8497 $ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ), 8498 $ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ), 8499 $ IWORK( COLTYP ), INFO ) 8500 IF( INFO.NE.0 ) 8501 $ GO TO 20 8502 IF( K.NE.0 ) THEN 8503 IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT + 8504 $ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2 8505 CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ), 8506 $ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ), 8507 $ WORK( IW ), WORK( IS ), INFO ) 8508 IF( INFO.NE.0 ) 8509 $ GO TO 20 8510 N1 = K 8511 N2 = N - K 8512 CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) 8513 ELSE 8514 DO 10 I = 1, N 8515 INDXQ( I ) = I 8516 10 CONTINUE 8517 END IF 8518 20 CONTINUE 8519 RETURN 8520 END 8521! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaed2.f 8522 SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, 8523 $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) 8524 INTEGER INFO, K, LDQ, N, N1 8525 DOUBLE PRECISION RHO 8526 INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ), 8527 $ INDXQ( * ) 8528 DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), 8529 $ W( * ), Z( * ) 8530 DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT 8531 PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, 8532 $ TWO = 2.0D0, EIGHT = 8.0D0 ) 8533 INTEGER CTOT( 4 ), PSM( 4 ) 8534 INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1, 8535 $ N2, NJ, PJ 8536 DOUBLE PRECISION C, EPS, S, T, TAU, TOL 8537 INTEGER IDAMAX 8538 DOUBLE PRECISION DLAMCH, DLAPY2 8539 EXTERNAL IDAMAX, DLAMCH, DLAPY2 8540 EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA 8541 INTRINSIC ABS, MAX, MIN, SQRT 8542 INFO = 0 8543 IF( N.LT.0 ) THEN 8544 INFO = -2 8545 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN 8546 INFO = -6 8547 ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN 8548 INFO = -3 8549 END IF 8550 IF( INFO.NE.0 ) THEN 8551 CALL XERBLA( 'DLAED2', -INFO ) 8552 RETURN 8553 END IF 8554 IF( N.EQ.0 ) 8555 $ RETURN 8556 N2 = N - N1 8557 N1P1 = N1 + 1 8558 IF( RHO.LT.ZERO ) THEN 8559 CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) 8560 END IF 8561 T = ONE / SQRT( TWO ) 8562 CALL DSCAL( N, T, Z, 1 ) 8563 RHO = ABS( TWO*RHO ) 8564 DO 10 I = N1P1, N 8565 INDXQ( I ) = INDXQ( I ) + N1 8566 10 CONTINUE 8567 DO 20 I = 1, N 8568 DLAMDA( I ) = D( INDXQ( I ) ) 8569 20 CONTINUE 8570 CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC ) 8571 DO 30 I = 1, N 8572 INDX( I ) = INDXQ( INDXC( I ) ) 8573 30 CONTINUE 8574 IMAX = IDAMAX( N, Z, 1 ) 8575 JMAX = IDAMAX( N, D, 1 ) 8576 EPS = DLAMCH( 'Epsilon' ) 8577 TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) ) 8578 IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN 8579 K = 0 8580 IQ2 = 1 8581 DO 40 J = 1, N 8582 I = INDX( J ) 8583 CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 ) 8584 DLAMDA( J ) = D( I ) 8585 IQ2 = IQ2 + N 8586 40 CONTINUE 8587 CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ ) 8588 CALL DCOPY( N, DLAMDA, 1, D, 1 ) 8589 GO TO 190 8590 END IF 8591 DO 50 I = 1, N1 8592 COLTYP( I ) = 1 8593 50 CONTINUE 8594 DO 60 I = N1P1, N 8595 COLTYP( I ) = 3 8596 60 CONTINUE 8597 K = 0 8598 K2 = N + 1 8599 DO 70 J = 1, N 8600 NJ = INDX( J ) 8601 IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN 8602 K2 = K2 - 1 8603 COLTYP( NJ ) = 4 8604 INDXP( K2 ) = NJ 8605 IF( J.EQ.N ) 8606 $ GO TO 100 8607 ELSE 8608 PJ = NJ 8609 GO TO 80 8610 END IF 8611 70 CONTINUE 8612 80 CONTINUE 8613 J = J + 1 8614 NJ = INDX( J ) 8615 IF( J.GT.N ) 8616 $ GO TO 100 8617 IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN 8618 K2 = K2 - 1 8619 COLTYP( NJ ) = 4 8620 INDXP( K2 ) = NJ 8621 ELSE 8622 S = Z( PJ ) 8623 C = Z( NJ ) 8624 TAU = DLAPY2( C, S ) 8625 T = D( NJ ) - D( PJ ) 8626 C = C / TAU 8627 S = -S / TAU 8628 IF( ABS( T*C*S ).LE.TOL ) THEN 8629 Z( NJ ) = TAU 8630 Z( PJ ) = ZERO 8631 IF( COLTYP( NJ ).NE.COLTYP( PJ ) ) 8632 $ COLTYP( NJ ) = 2 8633 COLTYP( PJ ) = 4 8634 CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S ) 8635 T = D( PJ )*C**2 + D( NJ )*S**2 8636 D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2 8637 D( PJ ) = T 8638 K2 = K2 - 1 8639 I = 1 8640 90 CONTINUE 8641 IF( K2+I.LE.N ) THEN 8642 IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN 8643 INDXP( K2+I-1 ) = INDXP( K2+I ) 8644 INDXP( K2+I ) = PJ 8645 I = I + 1 8646 GO TO 90 8647 ELSE 8648 INDXP( K2+I-1 ) = PJ 8649 END IF 8650 ELSE 8651 INDXP( K2+I-1 ) = PJ 8652 END IF 8653 PJ = NJ 8654 ELSE 8655 K = K + 1 8656 DLAMDA( K ) = D( PJ ) 8657 W( K ) = Z( PJ ) 8658 INDXP( K ) = PJ 8659 PJ = NJ 8660 END IF 8661 END IF 8662 GO TO 80 8663 100 CONTINUE 8664 K = K + 1 8665 DLAMDA( K ) = D( PJ ) 8666 W( K ) = Z( PJ ) 8667 INDXP( K ) = PJ 8668 DO 110 J = 1, 4 8669 CTOT( J ) = 0 8670 110 CONTINUE 8671 DO 120 J = 1, N 8672 CT = COLTYP( J ) 8673 CTOT( CT ) = CTOT( CT ) + 1 8674 120 CONTINUE 8675 PSM( 1 ) = 1 8676 PSM( 2 ) = 1 + CTOT( 1 ) 8677 PSM( 3 ) = PSM( 2 ) + CTOT( 2 ) 8678 PSM( 4 ) = PSM( 3 ) + CTOT( 3 ) 8679 K = N - CTOT( 4 ) 8680 DO 130 J = 1, N 8681 JS = INDXP( J ) 8682 CT = COLTYP( JS ) 8683 INDX( PSM( CT ) ) = JS 8684 INDXC( PSM( CT ) ) = J 8685 PSM( CT ) = PSM( CT ) + 1 8686 130 CONTINUE 8687 I = 1 8688 IQ1 = 1 8689 IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1 8690 DO 140 J = 1, CTOT( 1 ) 8691 JS = INDX( I ) 8692 CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) 8693 Z( I ) = D( JS ) 8694 I = I + 1 8695 IQ1 = IQ1 + N1 8696 140 CONTINUE 8697 DO 150 J = 1, CTOT( 2 ) 8698 JS = INDX( I ) 8699 CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 ) 8700 CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) 8701 Z( I ) = D( JS ) 8702 I = I + 1 8703 IQ1 = IQ1 + N1 8704 IQ2 = IQ2 + N2 8705 150 CONTINUE 8706 DO 160 J = 1, CTOT( 3 ) 8707 JS = INDX( I ) 8708 CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 ) 8709 Z( I ) = D( JS ) 8710 I = I + 1 8711 IQ2 = IQ2 + N2 8712 160 CONTINUE 8713 IQ1 = IQ2 8714 DO 170 J = 1, CTOT( 4 ) 8715 JS = INDX( I ) 8716 CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 ) 8717 IQ2 = IQ2 + N 8718 Z( I ) = D( JS ) 8719 I = I + 1 8720 170 CONTINUE 8721 IF( K.LT.N ) THEN 8722 CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, 8723 $ Q( 1, K+1 ), LDQ ) 8724 CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 ) 8725 END IF 8726 DO 180 J = 1, 4 8727 COLTYP( J ) = CTOT( J ) 8728 180 CONTINUE 8729 190 CONTINUE 8730 RETURN 8731 END 8732! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaed3.f 8733 SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, 8734 $ CTOT, W, S, INFO ) 8735 INTEGER INFO, K, LDQ, N, N1 8736 DOUBLE PRECISION RHO 8737 INTEGER CTOT( * ), INDX( * ) 8738 DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ), 8739 $ S( * ), W( * ) 8740 DOUBLE PRECISION ONE, ZERO 8741 PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) 8742 INTEGER I, II, IQ2, J, N12, N2, N23 8743 DOUBLE PRECISION TEMP 8744 DOUBLE PRECISION DLAMC3, DNRM2 8745 EXTERNAL DLAMC3, DNRM2 8746 EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA 8747 INTRINSIC MAX, SIGN, SQRT 8748 INFO = 0 8749 IF( K.LT.0 ) THEN 8750 INFO = -1 8751 ELSE IF( N.LT.K ) THEN 8752 INFO = -2 8753 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN 8754 INFO = -6 8755 END IF 8756 IF( INFO.NE.0 ) THEN 8757 CALL XERBLA( 'DLAED3', -INFO ) 8758 RETURN 8759 END IF 8760 IF( K.EQ.0 ) 8761 $ RETURN 8762 DO 10 I = 1, K 8763 DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) 8764 10 CONTINUE 8765 DO 20 J = 1, K 8766 CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) 8767 IF( INFO.NE.0 ) 8768 $ GO TO 120 8769 20 CONTINUE 8770 IF( K.EQ.1 ) 8771 $ GO TO 110 8772 IF( K.EQ.2 ) THEN 8773 DO 30 J = 1, K 8774 W( 1 ) = Q( 1, J ) 8775 W( 2 ) = Q( 2, J ) 8776 II = INDX( 1 ) 8777 Q( 1, J ) = W( II ) 8778 II = INDX( 2 ) 8779 Q( 2, J ) = W( II ) 8780 30 CONTINUE 8781 GO TO 110 8782 END IF 8783 CALL DCOPY( K, W, 1, S, 1 ) 8784 CALL DCOPY( K, Q, LDQ+1, W, 1 ) 8785 DO 60 J = 1, K 8786 DO 40 I = 1, J - 1 8787 W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) 8788 40 CONTINUE 8789 DO 50 I = J + 1, K 8790 W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) 8791 50 CONTINUE 8792 60 CONTINUE 8793 DO 70 I = 1, K 8794 W( I ) = SIGN( SQRT( -W( I ) ), S( I ) ) 8795 70 CONTINUE 8796 DO 100 J = 1, K 8797 DO 80 I = 1, K 8798 S( I ) = W( I ) / Q( I, J ) 8799 80 CONTINUE 8800 TEMP = DNRM2( K, S, 1 ) 8801 DO 90 I = 1, K 8802 II = INDX( I ) 8803 Q( I, J ) = S( II ) / TEMP 8804 90 CONTINUE 8805 100 CONTINUE 8806 110 CONTINUE 8807 N2 = N - N1 8808 N12 = CTOT( 1 ) + CTOT( 2 ) 8809 N23 = CTOT( 2 ) + CTOT( 3 ) 8810 CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 ) 8811 IQ2 = N1*N12 + 1 8812 IF( N23.NE.0 ) THEN 8813 CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23, 8814 $ ZERO, Q( N1+1, 1 ), LDQ ) 8815 ELSE 8816 CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ ) 8817 END IF 8818 CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 ) 8819 IF( N12.NE.0 ) THEN 8820 CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q, 8821 $ LDQ ) 8822 ELSE 8823 CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ ) 8824 END IF 8825 120 CONTINUE 8826 RETURN 8827 END 8828! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaed4.f 8829 SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) 8830 INTEGER I, INFO, N 8831 DOUBLE PRECISION DLAM, RHO 8832 DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) 8833 INTEGER MAXIT 8834 PARAMETER ( MAXIT = 30 ) 8835 DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN 8836 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 8837 $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0, 8838 $ TEN = 10.0D0 ) 8839 LOGICAL ORGATI, SWTCH, SWTCH3 8840 INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER 8841 DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW, 8842 $ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI, 8843 $ RHOINV, TAU, TEMP, TEMP1, W 8844 DOUBLE PRECISION ZZ( 3 ) 8845 DOUBLE PRECISION DLAMCH 8846 EXTERNAL DLAMCH 8847 EXTERNAL DLAED5, DLAED6 8848 INTRINSIC ABS, MAX, MIN, SQRT 8849 INFO = 0 8850 IF( N.EQ.1 ) THEN 8851 DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 ) 8852 DELTA( 1 ) = ONE 8853 RETURN 8854 END IF 8855 IF( N.EQ.2 ) THEN 8856 CALL DLAED5( I, D, Z, DELTA, RHO, DLAM ) 8857 RETURN 8858 END IF 8859 EPS = DLAMCH( 'Epsilon' ) 8860 RHOINV = ONE / RHO 8861 IF( I.EQ.N ) THEN 8862 II = N - 1 8863 NITER = 1 8864 MIDPT = RHO / TWO 8865 DO 10 J = 1, N 8866 DELTA( J ) = ( D( J )-D( I ) ) - MIDPT 8867 10 CONTINUE 8868 PSI = ZERO 8869 DO 20 J = 1, N - 2 8870 PSI = PSI + Z( J )*Z( J ) / DELTA( J ) 8871 20 CONTINUE 8872 C = RHOINV + PSI 8873 W = C + Z( II )*Z( II ) / DELTA( II ) + 8874 $ Z( N )*Z( N ) / DELTA( N ) 8875 IF( W.LE.ZERO ) THEN 8876 TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) + 8877 $ Z( N )*Z( N ) / RHO 8878 IF( C.LE.TEMP ) THEN 8879 TAU = RHO 8880 ELSE 8881 DEL = D( N ) - D( N-1 ) 8882 A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) 8883 B = Z( N )*Z( N )*DEL 8884 IF( A.LT.ZERO ) THEN 8885 TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) 8886 ELSE 8887 TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) 8888 END IF 8889 END IF 8890 DLTLB = MIDPT 8891 DLTUB = RHO 8892 ELSE 8893 DEL = D( N ) - D( N-1 ) 8894 A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N ) 8895 B = Z( N )*Z( N )*DEL 8896 IF( A.LT.ZERO ) THEN 8897 TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A ) 8898 ELSE 8899 TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C ) 8900 END IF 8901 DLTLB = ZERO 8902 DLTUB = MIDPT 8903 END IF 8904 DO 30 J = 1, N 8905 DELTA( J ) = ( D( J )-D( I ) ) - TAU 8906 30 CONTINUE 8907 DPSI = ZERO 8908 PSI = ZERO 8909 ERRETM = ZERO 8910 DO 40 J = 1, II 8911 TEMP = Z( J ) / DELTA( J ) 8912 PSI = PSI + Z( J )*TEMP 8913 DPSI = DPSI + TEMP*TEMP 8914 ERRETM = ERRETM + PSI 8915 40 CONTINUE 8916 ERRETM = ABS( ERRETM ) 8917 TEMP = Z( N ) / DELTA( N ) 8918 PHI = Z( N )*TEMP 8919 DPHI = TEMP*TEMP 8920 ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + 8921 $ ABS( TAU )*( DPSI+DPHI ) 8922 W = RHOINV + PHI + PSI 8923 IF( ABS( W ).LE.EPS*ERRETM ) THEN 8924 DLAM = D( I ) + TAU 8925 GO TO 250 8926 END IF 8927 IF( W.LE.ZERO ) THEN 8928 DLTLB = MAX( DLTLB, TAU ) 8929 ELSE 8930 DLTUB = MIN( DLTUB, TAU ) 8931 END IF 8932 NITER = NITER + 1 8933 C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI 8934 A = ( DELTA( N-1 )+DELTA( N ) )*W - 8935 $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) 8936 B = DELTA( N-1 )*DELTA( N )*W 8937 IF( C.LT.ZERO ) 8938 $ C = ABS( C ) 8939 IF( C.EQ.ZERO ) THEN 8940 ETA = DLTUB - TAU 8941 ELSE IF( A.GE.ZERO ) THEN 8942 ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) 8943 ELSE 8944 ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) 8945 END IF 8946 IF( W*ETA.GT.ZERO ) 8947 $ ETA = -W / ( DPSI+DPHI ) 8948 TEMP = TAU + ETA 8949 IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN 8950 IF( W.LT.ZERO ) THEN 8951 ETA = ( DLTUB-TAU ) / TWO 8952 ELSE 8953 ETA = ( DLTLB-TAU ) / TWO 8954 END IF 8955 END IF 8956 DO 50 J = 1, N 8957 DELTA( J ) = DELTA( J ) - ETA 8958 50 CONTINUE 8959 TAU = TAU + ETA 8960 DPSI = ZERO 8961 PSI = ZERO 8962 ERRETM = ZERO 8963 DO 60 J = 1, II 8964 TEMP = Z( J ) / DELTA( J ) 8965 PSI = PSI + Z( J )*TEMP 8966 DPSI = DPSI + TEMP*TEMP 8967 ERRETM = ERRETM + PSI 8968 60 CONTINUE 8969 ERRETM = ABS( ERRETM ) 8970 TEMP = Z( N ) / DELTA( N ) 8971 PHI = Z( N )*TEMP 8972 DPHI = TEMP*TEMP 8973 ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + 8974 $ ABS( TAU )*( DPSI+DPHI ) 8975 W = RHOINV + PHI + PSI 8976 ITER = NITER + 1 8977 DO 90 NITER = ITER, MAXIT 8978 IF( ABS( W ).LE.EPS*ERRETM ) THEN 8979 DLAM = D( I ) + TAU 8980 GO TO 250 8981 END IF 8982 IF( W.LE.ZERO ) THEN 8983 DLTLB = MAX( DLTLB, TAU ) 8984 ELSE 8985 DLTUB = MIN( DLTUB, TAU ) 8986 END IF 8987 C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI 8988 A = ( DELTA( N-1 )+DELTA( N ) )*W - 8989 $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI ) 8990 B = DELTA( N-1 )*DELTA( N )*W 8991 IF( A.GE.ZERO ) THEN 8992 ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) 8993 ELSE 8994 ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) 8995 END IF 8996 IF( W*ETA.GT.ZERO ) 8997 $ ETA = -W / ( DPSI+DPHI ) 8998 TEMP = TAU + ETA 8999 IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN 9000 IF( W.LT.ZERO ) THEN 9001 ETA = ( DLTUB-TAU ) / TWO 9002 ELSE 9003 ETA = ( DLTLB-TAU ) / TWO 9004 END IF 9005 END IF 9006 DO 70 J = 1, N 9007 DELTA( J ) = DELTA( J ) - ETA 9008 70 CONTINUE 9009 TAU = TAU + ETA 9010 DPSI = ZERO 9011 PSI = ZERO 9012 ERRETM = ZERO 9013 DO 80 J = 1, II 9014 TEMP = Z( J ) / DELTA( J ) 9015 PSI = PSI + Z( J )*TEMP 9016 DPSI = DPSI + TEMP*TEMP 9017 ERRETM = ERRETM + PSI 9018 80 CONTINUE 9019 ERRETM = ABS( ERRETM ) 9020 TEMP = Z( N ) / DELTA( N ) 9021 PHI = Z( N )*TEMP 9022 DPHI = TEMP*TEMP 9023 ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV + 9024 $ ABS( TAU )*( DPSI+DPHI ) 9025 W = RHOINV + PHI + PSI 9026 90 CONTINUE 9027 INFO = 1 9028 DLAM = D( I ) + TAU 9029 GO TO 250 9030 ELSE 9031 NITER = 1 9032 IP1 = I + 1 9033 DEL = D( IP1 ) - D( I ) 9034 MIDPT = DEL / TWO 9035 DO 100 J = 1, N 9036 DELTA( J ) = ( D( J )-D( I ) ) - MIDPT 9037 100 CONTINUE 9038 PSI = ZERO 9039 DO 110 J = 1, I - 1 9040 PSI = PSI + Z( J )*Z( J ) / DELTA( J ) 9041 110 CONTINUE 9042 PHI = ZERO 9043 DO 120 J = N, I + 2, -1 9044 PHI = PHI + Z( J )*Z( J ) / DELTA( J ) 9045 120 CONTINUE 9046 C = RHOINV + PSI + PHI 9047 W = C + Z( I )*Z( I ) / DELTA( I ) + 9048 $ Z( IP1 )*Z( IP1 ) / DELTA( IP1 ) 9049 IF( W.GT.ZERO ) THEN 9050 ORGATI = .TRUE. 9051 A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 ) 9052 B = Z( I )*Z( I )*DEL 9053 IF( A.GT.ZERO ) THEN 9054 TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) 9055 ELSE 9056 TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) 9057 END IF 9058 DLTLB = ZERO 9059 DLTUB = MIDPT 9060 ELSE 9061 ORGATI = .FALSE. 9062 A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 ) 9063 B = Z( IP1 )*Z( IP1 )*DEL 9064 IF( A.LT.ZERO ) THEN 9065 TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) ) 9066 ELSE 9067 TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C ) 9068 END IF 9069 DLTLB = -MIDPT 9070 DLTUB = ZERO 9071 END IF 9072 IF( ORGATI ) THEN 9073 DO 130 J = 1, N 9074 DELTA( J ) = ( D( J )-D( I ) ) - TAU 9075 130 CONTINUE 9076 ELSE 9077 DO 140 J = 1, N 9078 DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU 9079 140 CONTINUE 9080 END IF 9081 IF( ORGATI ) THEN 9082 II = I 9083 ELSE 9084 II = I + 1 9085 END IF 9086 IIM1 = II - 1 9087 IIP1 = II + 1 9088 DPSI = ZERO 9089 PSI = ZERO 9090 ERRETM = ZERO 9091 DO 150 J = 1, IIM1 9092 TEMP = Z( J ) / DELTA( J ) 9093 PSI = PSI + Z( J )*TEMP 9094 DPSI = DPSI + TEMP*TEMP 9095 ERRETM = ERRETM + PSI 9096 150 CONTINUE 9097 ERRETM = ABS( ERRETM ) 9098 DPHI = ZERO 9099 PHI = ZERO 9100 DO 160 J = N, IIP1, -1 9101 TEMP = Z( J ) / DELTA( J ) 9102 PHI = PHI + Z( J )*TEMP 9103 DPHI = DPHI + TEMP*TEMP 9104 ERRETM = ERRETM + PHI 9105 160 CONTINUE 9106 W = RHOINV + PHI + PSI 9107 SWTCH3 = .FALSE. 9108 IF( ORGATI ) THEN 9109 IF( W.LT.ZERO ) 9110 $ SWTCH3 = .TRUE. 9111 ELSE 9112 IF( W.GT.ZERO ) 9113 $ SWTCH3 = .TRUE. 9114 END IF 9115 IF( II.EQ.1 .OR. II.EQ.N ) 9116 $ SWTCH3 = .FALSE. 9117 TEMP = Z( II ) / DELTA( II ) 9118 DW = DPSI + DPHI + TEMP*TEMP 9119 TEMP = Z( II )*TEMP 9120 W = W + TEMP 9121 ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + 9122 $ THREE*ABS( TEMP ) + ABS( TAU )*DW 9123 IF( ABS( W ).LE.EPS*ERRETM ) THEN 9124 IF( ORGATI ) THEN 9125 DLAM = D( I ) + TAU 9126 ELSE 9127 DLAM = D( IP1 ) + TAU 9128 END IF 9129 GO TO 250 9130 END IF 9131 IF( W.LE.ZERO ) THEN 9132 DLTLB = MAX( DLTLB, TAU ) 9133 ELSE 9134 DLTUB = MIN( DLTUB, TAU ) 9135 END IF 9136 NITER = NITER + 1 9137 IF( .NOT.SWTCH3 ) THEN 9138 IF( ORGATI ) THEN 9139 C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )* 9140 $ ( Z( I ) / DELTA( I ) )**2 9141 ELSE 9142 C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* 9143 $ ( Z( IP1 ) / DELTA( IP1 ) )**2 9144 END IF 9145 A = ( DELTA( I )+DELTA( IP1 ) )*W - 9146 $ DELTA( I )*DELTA( IP1 )*DW 9147 B = DELTA( I )*DELTA( IP1 )*W 9148 IF( C.EQ.ZERO ) THEN 9149 IF( A.EQ.ZERO ) THEN 9150 IF( ORGATI ) THEN 9151 A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )* 9152 $ ( DPSI+DPHI ) 9153 ELSE 9154 A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )* 9155 $ ( DPSI+DPHI ) 9156 END IF 9157 END IF 9158 ETA = B / A 9159 ELSE IF( A.LE.ZERO ) THEN 9160 ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) 9161 ELSE 9162 ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) 9163 END IF 9164 ELSE 9165 TEMP = RHOINV + PSI + PHI 9166 IF( ORGATI ) THEN 9167 TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) 9168 TEMP1 = TEMP1*TEMP1 9169 C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - 9170 $ ( D( IIM1 )-D( IIP1 ) )*TEMP1 9171 ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) 9172 ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* 9173 $ ( ( DPSI-TEMP1 )+DPHI ) 9174 ELSE 9175 TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) 9176 TEMP1 = TEMP1*TEMP1 9177 C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - 9178 $ ( D( IIP1 )-D( IIM1 ) )*TEMP1 9179 ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* 9180 $ ( DPSI+( DPHI-TEMP1 ) ) 9181 ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) 9182 END IF 9183 ZZ( 2 ) = Z( II )*Z( II ) 9184 CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, 9185 $ INFO ) 9186 IF( INFO.NE.0 ) 9187 $ GO TO 250 9188 END IF 9189 IF( W*ETA.GE.ZERO ) 9190 $ ETA = -W / DW 9191 TEMP = TAU + ETA 9192 IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN 9193 IF( W.LT.ZERO ) THEN 9194 ETA = ( DLTUB-TAU ) / TWO 9195 ELSE 9196 ETA = ( DLTLB-TAU ) / TWO 9197 END IF 9198 END IF 9199 PREW = W 9200 DO 180 J = 1, N 9201 DELTA( J ) = DELTA( J ) - ETA 9202 180 CONTINUE 9203 DPSI = ZERO 9204 PSI = ZERO 9205 ERRETM = ZERO 9206 DO 190 J = 1, IIM1 9207 TEMP = Z( J ) / DELTA( J ) 9208 PSI = PSI + Z( J )*TEMP 9209 DPSI = DPSI + TEMP*TEMP 9210 ERRETM = ERRETM + PSI 9211 190 CONTINUE 9212 ERRETM = ABS( ERRETM ) 9213 DPHI = ZERO 9214 PHI = ZERO 9215 DO 200 J = N, IIP1, -1 9216 TEMP = Z( J ) / DELTA( J ) 9217 PHI = PHI + Z( J )*TEMP 9218 DPHI = DPHI + TEMP*TEMP 9219 ERRETM = ERRETM + PHI 9220 200 CONTINUE 9221 TEMP = Z( II ) / DELTA( II ) 9222 DW = DPSI + DPHI + TEMP*TEMP 9223 TEMP = Z( II )*TEMP 9224 W = RHOINV + PHI + PSI + TEMP 9225 ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + 9226 $ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW 9227 SWTCH = .FALSE. 9228 IF( ORGATI ) THEN 9229 IF( -W.GT.ABS( PREW ) / TEN ) 9230 $ SWTCH = .TRUE. 9231 ELSE 9232 IF( W.GT.ABS( PREW ) / TEN ) 9233 $ SWTCH = .TRUE. 9234 END IF 9235 TAU = TAU + ETA 9236 ITER = NITER + 1 9237 DO 240 NITER = ITER, MAXIT 9238 IF( ABS( W ).LE.EPS*ERRETM ) THEN 9239 IF( ORGATI ) THEN 9240 DLAM = D( I ) + TAU 9241 ELSE 9242 DLAM = D( IP1 ) + TAU 9243 END IF 9244 GO TO 250 9245 END IF 9246 IF( W.LE.ZERO ) THEN 9247 DLTLB = MAX( DLTLB, TAU ) 9248 ELSE 9249 DLTUB = MIN( DLTUB, TAU ) 9250 END IF 9251 IF( .NOT.SWTCH3 ) THEN 9252 IF( .NOT.SWTCH ) THEN 9253 IF( ORGATI ) THEN 9254 C = W - DELTA( IP1 )*DW - 9255 $ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2 9256 ELSE 9257 C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )* 9258 $ ( Z( IP1 ) / DELTA( IP1 ) )**2 9259 END IF 9260 ELSE 9261 TEMP = Z( II ) / DELTA( II ) 9262 IF( ORGATI ) THEN 9263 DPSI = DPSI + TEMP*TEMP 9264 ELSE 9265 DPHI = DPHI + TEMP*TEMP 9266 END IF 9267 C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI 9268 END IF 9269 A = ( DELTA( I )+DELTA( IP1 ) )*W - 9270 $ DELTA( I )*DELTA( IP1 )*DW 9271 B = DELTA( I )*DELTA( IP1 )*W 9272 IF( C.EQ.ZERO ) THEN 9273 IF( A.EQ.ZERO ) THEN 9274 IF( .NOT.SWTCH ) THEN 9275 IF( ORGATI ) THEN 9276 A = Z( I )*Z( I ) + DELTA( IP1 )* 9277 $ DELTA( IP1 )*( DPSI+DPHI ) 9278 ELSE 9279 A = Z( IP1 )*Z( IP1 ) + 9280 $ DELTA( I )*DELTA( I )*( DPSI+DPHI ) 9281 END IF 9282 ELSE 9283 A = DELTA( I )*DELTA( I )*DPSI + 9284 $ DELTA( IP1 )*DELTA( IP1 )*DPHI 9285 END IF 9286 END IF 9287 ETA = B / A 9288 ELSE IF( A.LE.ZERO ) THEN 9289 ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) 9290 ELSE 9291 ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) 9292 END IF 9293 ELSE 9294 TEMP = RHOINV + PSI + PHI 9295 IF( SWTCH ) THEN 9296 C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI 9297 ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI 9298 ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI 9299 ELSE 9300 IF( ORGATI ) THEN 9301 TEMP1 = Z( IIM1 ) / DELTA( IIM1 ) 9302 TEMP1 = TEMP1*TEMP1 9303 C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) - 9304 $ ( D( IIM1 )-D( IIP1 ) )*TEMP1 9305 ZZ( 1 ) = Z( IIM1 )*Z( IIM1 ) 9306 ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )* 9307 $ ( ( DPSI-TEMP1 )+DPHI ) 9308 ELSE 9309 TEMP1 = Z( IIP1 ) / DELTA( IIP1 ) 9310 TEMP1 = TEMP1*TEMP1 9311 C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) - 9312 $ ( D( IIP1 )-D( IIM1 ) )*TEMP1 9313 ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )* 9314 $ ( DPSI+( DPHI-TEMP1 ) ) 9315 ZZ( 3 ) = Z( IIP1 )*Z( IIP1 ) 9316 END IF 9317 END IF 9318 CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA, 9319 $ INFO ) 9320 IF( INFO.NE.0 ) 9321 $ GO TO 250 9322 END IF 9323 IF( W*ETA.GE.ZERO ) 9324 $ ETA = -W / DW 9325 TEMP = TAU + ETA 9326 IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN 9327 IF( W.LT.ZERO ) THEN 9328 ETA = ( DLTUB-TAU ) / TWO 9329 ELSE 9330 ETA = ( DLTLB-TAU ) / TWO 9331 END IF 9332 END IF 9333 DO 210 J = 1, N 9334 DELTA( J ) = DELTA( J ) - ETA 9335 210 CONTINUE 9336 TAU = TAU + ETA 9337 PREW = W 9338 DPSI = ZERO 9339 PSI = ZERO 9340 ERRETM = ZERO 9341 DO 220 J = 1, IIM1 9342 TEMP = Z( J ) / DELTA( J ) 9343 PSI = PSI + Z( J )*TEMP 9344 DPSI = DPSI + TEMP*TEMP 9345 ERRETM = ERRETM + PSI 9346 220 CONTINUE 9347 ERRETM = ABS( ERRETM ) 9348 DPHI = ZERO 9349 PHI = ZERO 9350 DO 230 J = N, IIP1, -1 9351 TEMP = Z( J ) / DELTA( J ) 9352 PHI = PHI + Z( J )*TEMP 9353 DPHI = DPHI + TEMP*TEMP 9354 ERRETM = ERRETM + PHI 9355 230 CONTINUE 9356 TEMP = Z( II ) / DELTA( II ) 9357 DW = DPSI + DPHI + TEMP*TEMP 9358 TEMP = Z( II )*TEMP 9359 W = RHOINV + PHI + PSI + TEMP 9360 ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV + 9361 $ THREE*ABS( TEMP ) + ABS( TAU )*DW 9362 IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN ) 9363 $ SWTCH = .NOT.SWTCH 9364 240 CONTINUE 9365 INFO = 1 9366 IF( ORGATI ) THEN 9367 DLAM = D( I ) + TAU 9368 ELSE 9369 DLAM = D( IP1 ) + TAU 9370 END IF 9371 END IF 9372 250 CONTINUE 9373 RETURN 9374 END 9375! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaed5.f 9376 SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) 9377 INTEGER I 9378 DOUBLE PRECISION DLAM, RHO 9379 DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 ) 9380 DOUBLE PRECISION ZERO, ONE, TWO, FOUR 9381 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 9382 $ FOUR = 4.0D0 ) 9383 DOUBLE PRECISION B, C, DEL, TAU, TEMP, W 9384 INTRINSIC ABS, SQRT 9385 DEL = D( 2 ) - D( 1 ) 9386 IF( I.EQ.1 ) THEN 9387 W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL 9388 IF( W.GT.ZERO ) THEN 9389 B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) 9390 C = RHO*Z( 1 )*Z( 1 )*DEL 9391 TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) ) 9392 DLAM = D( 1 ) + TAU 9393 DELTA( 1 ) = -Z( 1 ) / TAU 9394 DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) 9395 ELSE 9396 B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) 9397 C = RHO*Z( 2 )*Z( 2 )*DEL 9398 IF( B.GT.ZERO ) THEN 9399 TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) ) 9400 ELSE 9401 TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO 9402 END IF 9403 DLAM = D( 2 ) + TAU 9404 DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) 9405 DELTA( 2 ) = -Z( 2 ) / TAU 9406 END IF 9407 TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) 9408 DELTA( 1 ) = DELTA( 1 ) / TEMP 9409 DELTA( 2 ) = DELTA( 2 ) / TEMP 9410 ELSE 9411 B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) ) 9412 C = RHO*Z( 2 )*Z( 2 )*DEL 9413 IF( B.GT.ZERO ) THEN 9414 TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO 9415 ELSE 9416 TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) ) 9417 END IF 9418 DLAM = D( 2 ) + TAU 9419 DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) 9420 DELTA( 2 ) = -Z( 2 ) / TAU 9421 TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) 9422 DELTA( 1 ) = DELTA( 1 ) / TEMP 9423 DELTA( 2 ) = DELTA( 2 ) / TEMP 9424 END IF 9425 RETURN 9426 END 9427! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaed6.f 9428 SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) 9429 LOGICAL ORGATI 9430 INTEGER INFO, KNITER 9431 DOUBLE PRECISION FINIT, RHO, TAU 9432 DOUBLE PRECISION D( 3 ), Z( 3 ) 9433 INTEGER MAXIT 9434 PARAMETER ( MAXIT = 40 ) 9435 DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT 9436 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 9437 $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 ) 9438 DOUBLE PRECISION DLAMCH 9439 EXTERNAL DLAMCH 9440 DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 ) 9441 LOGICAL SCALE 9442 INTEGER I, ITER, NITER 9443 DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F, 9444 $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1, 9445 $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4, 9446 $ LBD, UBD 9447 INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT 9448 INFO = 0 9449 IF( ORGATI ) THEN 9450 LBD = D(2) 9451 UBD = D(3) 9452 ELSE 9453 LBD = D(1) 9454 UBD = D(2) 9455 END IF 9456 IF( FINIT .LT. ZERO )THEN 9457 LBD = ZERO 9458 ELSE 9459 UBD = ZERO 9460 END IF 9461 NITER = 1 9462 TAU = ZERO 9463 IF( KNITER.EQ.2 ) THEN 9464 IF( ORGATI ) THEN 9465 TEMP = ( D( 3 )-D( 2 ) ) / TWO 9466 C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP ) 9467 A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 ) 9468 B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 ) 9469 ELSE 9470 TEMP = ( D( 1 )-D( 2 ) ) / TWO 9471 C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP ) 9472 A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 ) 9473 B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 ) 9474 END IF 9475 TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) 9476 A = A / TEMP 9477 B = B / TEMP 9478 C = C / TEMP 9479 IF( C.EQ.ZERO ) THEN 9480 TAU = B / A 9481 ELSE IF( A.LE.ZERO ) THEN 9482 TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) 9483 ELSE 9484 TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) 9485 END IF 9486 IF( TAU .LT. LBD .OR. TAU .GT. UBD ) 9487 $ TAU = ( LBD+UBD )/TWO 9488 IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN 9489 TAU = ZERO 9490 ELSE 9491 TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) + 9492 $ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) + 9493 $ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) ) 9494 IF( TEMP .LE. ZERO )THEN 9495 LBD = TAU 9496 ELSE 9497 UBD = TAU 9498 END IF 9499 IF( ABS( FINIT ).LE.ABS( TEMP ) ) 9500 $ TAU = ZERO 9501 END IF 9502 END IF 9503 EPS = DLAMCH( 'Epsilon' ) 9504 BASE = DLAMCH( 'Base' ) 9505 SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) / 9506 $ THREE ) ) 9507 SMINV1 = ONE / SMALL1 9508 SMALL2 = SMALL1*SMALL1 9509 SMINV2 = SMINV1*SMINV1 9510 IF( ORGATI ) THEN 9511 TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) ) 9512 ELSE 9513 TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) ) 9514 END IF 9515 SCALE = .FALSE. 9516 IF( TEMP.LE.SMALL1 ) THEN 9517 SCALE = .TRUE. 9518 IF( TEMP.LE.SMALL2 ) THEN 9519 SCLFAC = SMINV2 9520 SCLINV = SMALL2 9521 ELSE 9522 SCLFAC = SMINV1 9523 SCLINV = SMALL1 9524 END IF 9525 DO 10 I = 1, 3 9526 DSCALE( I ) = D( I )*SCLFAC 9527 ZSCALE( I ) = Z( I )*SCLFAC 9528 10 CONTINUE 9529 TAU = TAU*SCLFAC 9530 LBD = LBD*SCLFAC 9531 UBD = UBD*SCLFAC 9532 ELSE 9533 DO 20 I = 1, 3 9534 DSCALE( I ) = D( I ) 9535 ZSCALE( I ) = Z( I ) 9536 20 CONTINUE 9537 END IF 9538 FC = ZERO 9539 DF = ZERO 9540 DDF = ZERO 9541 DO 30 I = 1, 3 9542 TEMP = ONE / ( DSCALE( I )-TAU ) 9543 TEMP1 = ZSCALE( I )*TEMP 9544 TEMP2 = TEMP1*TEMP 9545 TEMP3 = TEMP2*TEMP 9546 FC = FC + TEMP1 / DSCALE( I ) 9547 DF = DF + TEMP2 9548 DDF = DDF + TEMP3 9549 30 CONTINUE 9550 F = FINIT + TAU*FC 9551 IF( ABS( F ).LE.ZERO ) 9552 $ GO TO 60 9553 IF( F .LE. ZERO )THEN 9554 LBD = TAU 9555 ELSE 9556 UBD = TAU 9557 END IF 9558 ITER = NITER + 1 9559 DO 50 NITER = ITER, MAXIT 9560 IF( ORGATI ) THEN 9561 TEMP1 = DSCALE( 2 ) - TAU 9562 TEMP2 = DSCALE( 3 ) - TAU 9563 ELSE 9564 TEMP1 = DSCALE( 1 ) - TAU 9565 TEMP2 = DSCALE( 2 ) - TAU 9566 END IF 9567 A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF 9568 B = TEMP1*TEMP2*F 9569 C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF 9570 TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) ) 9571 A = A / TEMP 9572 B = B / TEMP 9573 C = C / TEMP 9574 IF( C.EQ.ZERO ) THEN 9575 ETA = B / A 9576 ELSE IF( A.LE.ZERO ) THEN 9577 ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C ) 9578 ELSE 9579 ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) 9580 END IF 9581 IF( F*ETA.GE.ZERO ) THEN 9582 ETA = -F / DF 9583 END IF 9584 TAU = TAU + ETA 9585 IF( TAU .LT. LBD .OR. TAU .GT. UBD ) 9586 $ TAU = ( LBD + UBD )/TWO 9587 FC = ZERO 9588 ERRETM = ZERO 9589 DF = ZERO 9590 DDF = ZERO 9591 DO 40 I = 1, 3 9592 IF ( ( DSCALE( I )-TAU ).NE.ZERO ) THEN 9593 TEMP = ONE / ( DSCALE( I )-TAU ) 9594 TEMP1 = ZSCALE( I )*TEMP 9595 TEMP2 = TEMP1*TEMP 9596 TEMP3 = TEMP2*TEMP 9597 TEMP4 = TEMP1 / DSCALE( I ) 9598 FC = FC + TEMP4 9599 ERRETM = ERRETM + ABS( TEMP4 ) 9600 DF = DF + TEMP2 9601 DDF = DDF + TEMP3 9602 ELSE 9603 GO TO 60 9604 END IF 9605 40 CONTINUE 9606 F = FINIT + TAU*FC 9607 ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) + 9608 $ ABS( TAU )*DF 9609 IF( ( ABS( F ).LE.FOUR*EPS*ERRETM ) .OR. 9610 $ ( (UBD-LBD).LE.FOUR*EPS*ABS(TAU) ) ) 9611 $ GO TO 60 9612 IF( F .LE. ZERO )THEN 9613 LBD = TAU 9614 ELSE 9615 UBD = TAU 9616 END IF 9617 50 CONTINUE 9618 INFO = 1 9619 60 CONTINUE 9620 IF( SCALE ) 9621 $ TAU = TAU*SCLINV 9622 RETURN 9623 END 9624! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaed7.f 9625 SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, 9626 $ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, 9627 $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, 9628 $ INFO ) 9629 INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N, 9630 $ QSIZ, TLVLS 9631 DOUBLE PRECISION RHO 9632 INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), 9633 $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) 9634 DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ), 9635 $ QSTORE( * ), WORK( * ) 9636 DOUBLE PRECISION ONE, ZERO 9637 PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) 9638 INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP, 9639 $ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR 9640 EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA 9641 INTRINSIC MAX, MIN 9642 INFO = 0 9643 IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN 9644 INFO = -1 9645 ELSE IF( N.LT.0 ) THEN 9646 INFO = -2 9647 ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN 9648 INFO = -3 9649 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN 9650 INFO = -9 9651 ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN 9652 INFO = -12 9653 END IF 9654 IF( INFO.NE.0 ) THEN 9655 CALL XERBLA( 'DLAED7', -INFO ) 9656 RETURN 9657 END IF 9658 IF( N.EQ.0 ) 9659 $ RETURN 9660 IF( ICOMPQ.EQ.1 ) THEN 9661 LDQ2 = QSIZ 9662 ELSE 9663 LDQ2 = N 9664 END IF 9665 IZ = 1 9666 IDLMDA = IZ + N 9667 IW = IDLMDA + N 9668 IQ2 = IW + N 9669 IS = IQ2 + N*LDQ2 9670 INDX = 1 9671 INDXC = INDX + N 9672 COLTYP = INDXC + N 9673 INDXP = COLTYP + N 9674 PTR = 1 + 2**TLVLS 9675 DO 10 I = 1, CURLVL - 1 9676 PTR = PTR + 2**( TLVLS-I ) 9677 10 CONTINUE 9678 CURR = PTR + CURPBM 9679 CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, 9680 $ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ), 9681 $ WORK( IZ+N ), INFO ) 9682 IF( CURLVL.EQ.TLVLS ) THEN 9683 QPTR( CURR ) = 1 9684 PRMPTR( CURR ) = 1 9685 GIVPTR( CURR ) = 1 9686 END IF 9687 CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, 9688 $ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2, 9689 $ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ), 9690 $ GIVCOL( 1, GIVPTR( CURR ) ), 9691 $ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ), 9692 $ IWORK( INDX ), INFO ) 9693 PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N 9694 GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR ) 9695 IF( K.NE.0 ) THEN 9696 CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ), 9697 $ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO ) 9698 IF( INFO.NE.0 ) 9699 $ GO TO 30 9700 IF( ICOMPQ.EQ.1 ) THEN 9701 CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2, 9702 $ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ ) 9703 END IF 9704 QPTR( CURR+1 ) = QPTR( CURR ) + K**2 9705 N1 = K 9706 N2 = N - K 9707 CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) 9708 ELSE 9709 QPTR( CURR+1 ) = QPTR( CURR ) 9710 DO 20 I = 1, N 9711 INDXQ( I ) = I 9712 20 CONTINUE 9713 END IF 9714 30 CONTINUE 9715 RETURN 9716 END 9717! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaed8.f 9718 SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, 9719 $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, 9720 $ GIVCOL, GIVNUM, INDXP, INDX, INFO ) 9721 INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N, 9722 $ QSIZ 9723 DOUBLE PRECISION RHO 9724 INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), 9725 $ INDXQ( * ), PERM( * ) 9726 DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), 9727 $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) 9728 DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT 9729 PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, 9730 $ TWO = 2.0D0, EIGHT = 8.0D0 ) 9731 INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 9732 DOUBLE PRECISION C, EPS, S, T, TAU, TOL 9733 INTEGER IDAMAX 9734 DOUBLE PRECISION DLAMCH, DLAPY2 9735 EXTERNAL IDAMAX, DLAMCH, DLAPY2 9736 EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA 9737 INTRINSIC ABS, MAX, MIN, SQRT 9738 INFO = 0 9739 IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN 9740 INFO = -1 9741 ELSE IF( N.LT.0 ) THEN 9742 INFO = -3 9743 ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN 9744 INFO = -4 9745 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN 9746 INFO = -7 9747 ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN 9748 INFO = -10 9749 ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN 9750 INFO = -14 9751 END IF 9752 IF( INFO.NE.0 ) THEN 9753 CALL XERBLA( 'DLAED8', -INFO ) 9754 RETURN 9755 END IF 9756 GIVPTR = 0 9757 IF( N.EQ.0 ) 9758 $ RETURN 9759 N1 = CUTPNT 9760 N2 = N - N1 9761 N1P1 = N1 + 1 9762 IF( RHO.LT.ZERO ) THEN 9763 CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) 9764 END IF 9765 T = ONE / SQRT( TWO ) 9766 DO 10 J = 1, N 9767 INDX( J ) = J 9768 10 CONTINUE 9769 CALL DSCAL( N, T, Z, 1 ) 9770 RHO = ABS( TWO*RHO ) 9771 DO 20 I = CUTPNT + 1, N 9772 INDXQ( I ) = INDXQ( I ) + CUTPNT 9773 20 CONTINUE 9774 DO 30 I = 1, N 9775 DLAMDA( I ) = D( INDXQ( I ) ) 9776 W( I ) = Z( INDXQ( I ) ) 9777 30 CONTINUE 9778 I = 1 9779 J = CUTPNT + 1 9780 CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX ) 9781 DO 40 I = 1, N 9782 D( I ) = DLAMDA( INDX( I ) ) 9783 Z( I ) = W( INDX( I ) ) 9784 40 CONTINUE 9785 IMAX = IDAMAX( N, Z, 1 ) 9786 JMAX = IDAMAX( N, D, 1 ) 9787 EPS = DLAMCH( 'Epsilon' ) 9788 TOL = EIGHT*EPS*ABS( D( JMAX ) ) 9789 IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN 9790 K = 0 9791 IF( ICOMPQ.EQ.0 ) THEN 9792 DO 50 J = 1, N 9793 PERM( J ) = INDXQ( INDX( J ) ) 9794 50 CONTINUE 9795 ELSE 9796 DO 60 J = 1, N 9797 PERM( J ) = INDXQ( INDX( J ) ) 9798 CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) 9799 60 CONTINUE 9800 CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), 9801 $ LDQ ) 9802 END IF 9803 RETURN 9804 END IF 9805 K = 0 9806 K2 = N + 1 9807 DO 70 J = 1, N 9808 IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN 9809 K2 = K2 - 1 9810 INDXP( K2 ) = J 9811 IF( J.EQ.N ) 9812 $ GO TO 110 9813 ELSE 9814 JLAM = J 9815 GO TO 80 9816 END IF 9817 70 CONTINUE 9818 80 CONTINUE 9819 J = J + 1 9820 IF( J.GT.N ) 9821 $ GO TO 100 9822 IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN 9823 K2 = K2 - 1 9824 INDXP( K2 ) = J 9825 ELSE 9826 S = Z( JLAM ) 9827 C = Z( J ) 9828 TAU = DLAPY2( C, S ) 9829 T = D( J ) - D( JLAM ) 9830 C = C / TAU 9831 S = -S / TAU 9832 IF( ABS( T*C*S ).LE.TOL ) THEN 9833 Z( J ) = TAU 9834 Z( JLAM ) = ZERO 9835 GIVPTR = GIVPTR + 1 9836 GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) 9837 GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) 9838 GIVNUM( 1, GIVPTR ) = C 9839 GIVNUM( 2, GIVPTR ) = S 9840 IF( ICOMPQ.EQ.1 ) THEN 9841 CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, 9842 $ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S ) 9843 END IF 9844 T = D( JLAM )*C*C + D( J )*S*S 9845 D( J ) = D( JLAM )*S*S + D( J )*C*C 9846 D( JLAM ) = T 9847 K2 = K2 - 1 9848 I = 1 9849 90 CONTINUE 9850 IF( K2+I.LE.N ) THEN 9851 IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN 9852 INDXP( K2+I-1 ) = INDXP( K2+I ) 9853 INDXP( K2+I ) = JLAM 9854 I = I + 1 9855 GO TO 90 9856 ELSE 9857 INDXP( K2+I-1 ) = JLAM 9858 END IF 9859 ELSE 9860 INDXP( K2+I-1 ) = JLAM 9861 END IF 9862 JLAM = J 9863 ELSE 9864 K = K + 1 9865 W( K ) = Z( JLAM ) 9866 DLAMDA( K ) = D( JLAM ) 9867 INDXP( K ) = JLAM 9868 JLAM = J 9869 END IF 9870 END IF 9871 GO TO 80 9872 100 CONTINUE 9873 K = K + 1 9874 W( K ) = Z( JLAM ) 9875 DLAMDA( K ) = D( JLAM ) 9876 INDXP( K ) = JLAM 9877 110 CONTINUE 9878 IF( ICOMPQ.EQ.0 ) THEN 9879 DO 120 J = 1, N 9880 JP = INDXP( J ) 9881 DLAMDA( J ) = D( JP ) 9882 PERM( J ) = INDXQ( INDX( JP ) ) 9883 120 CONTINUE 9884 ELSE 9885 DO 130 J = 1, N 9886 JP = INDXP( J ) 9887 DLAMDA( J ) = D( JP ) 9888 PERM( J ) = INDXQ( INDX( JP ) ) 9889 CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) 9890 130 CONTINUE 9891 END IF 9892 IF( K.LT.N ) THEN 9893 IF( ICOMPQ.EQ.0 ) THEN 9894 CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) 9895 ELSE 9896 CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) 9897 CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, 9898 $ Q( 1, K+1 ), LDQ ) 9899 END IF 9900 END IF 9901 RETURN 9902 END 9903! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaed9.f 9904 SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, 9905 $ S, LDS, INFO ) 9906 INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N 9907 DOUBLE PRECISION RHO 9908 DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ), 9909 $ W( * ) 9910 INTEGER I, J 9911 DOUBLE PRECISION TEMP 9912 DOUBLE PRECISION DLAMC3, DNRM2 9913 EXTERNAL DLAMC3, DNRM2 9914 EXTERNAL DCOPY, DLAED4, XERBLA 9915 INTRINSIC MAX, SIGN, SQRT 9916 INFO = 0 9917 IF( K.LT.0 ) THEN 9918 INFO = -1 9919 ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN 9920 INFO = -2 9921 ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) ) 9922 $ THEN 9923 INFO = -3 9924 ELSE IF( N.LT.K ) THEN 9925 INFO = -4 9926 ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN 9927 INFO = -7 9928 ELSE IF( LDS.LT.MAX( 1, K ) ) THEN 9929 INFO = -12 9930 END IF 9931 IF( INFO.NE.0 ) THEN 9932 CALL XERBLA( 'DLAED9', -INFO ) 9933 RETURN 9934 END IF 9935 IF( K.EQ.0 ) 9936 $ RETURN 9937 DO 10 I = 1, N 9938 DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I ) 9939 10 CONTINUE 9940 DO 20 J = KSTART, KSTOP 9941 CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO ) 9942 IF( INFO.NE.0 ) 9943 $ GO TO 120 9944 20 CONTINUE 9945 IF( K.EQ.1 .OR. K.EQ.2 ) THEN 9946 DO 40 I = 1, K 9947 DO 30 J = 1, K 9948 S( J, I ) = Q( J, I ) 9949 30 CONTINUE 9950 40 CONTINUE 9951 GO TO 120 9952 END IF 9953 CALL DCOPY( K, W, 1, S, 1 ) 9954 CALL DCOPY( K, Q, LDQ+1, W, 1 ) 9955 DO 70 J = 1, K 9956 DO 50 I = 1, J - 1 9957 W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) 9958 50 CONTINUE 9959 DO 60 I = J + 1, K 9960 W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) ) 9961 60 CONTINUE 9962 70 CONTINUE 9963 DO 80 I = 1, K 9964 W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) ) 9965 80 CONTINUE 9966 DO 110 J = 1, K 9967 DO 90 I = 1, K 9968 Q( I, J ) = W( I ) / Q( I, J ) 9969 90 CONTINUE 9970 TEMP = DNRM2( K, Q( 1, J ), 1 ) 9971 DO 100 I = 1, K 9972 S( I, J ) = Q( I, J ) / TEMP 9973 100 CONTINUE 9974 110 CONTINUE 9975 120 CONTINUE 9976 RETURN 9977 END 9978! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaeda.f 9979 SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, 9980 $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) 9981 INTEGER CURLVL, CURPBM, INFO, N, TLVLS 9982 INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ), 9983 $ PRMPTR( * ), QPTR( * ) 9984 DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * ) 9985 DOUBLE PRECISION ZERO, HALF, ONE 9986 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) 9987 INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2, 9988 $ PTR, ZPTR1 9989 EXTERNAL DCOPY, DGEMV, DROT, XERBLA 9990 INTRINSIC DBLE, INT, SQRT 9991 INFO = 0 9992 IF( N.LT.0 ) THEN 9993 INFO = -1 9994 END IF 9995 IF( INFO.NE.0 ) THEN 9996 CALL XERBLA( 'DLAEDA', -INFO ) 9997 RETURN 9998 END IF 9999 IF( N.EQ.0 ) 10000 $ RETURN 10001 MID = N / 2 + 1 10002 PTR = 1 10003 CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1 10004 BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) 10005 BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) ) 10006 DO 10 K = 1, MID - BSIZ1 - 1 10007 Z( K ) = ZERO 10008 10 CONTINUE 10009 CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1, 10010 $ Z( MID-BSIZ1 ), 1 ) 10011 CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 ) 10012 DO 20 K = MID + BSIZ2, N 10013 Z( K ) = ZERO 10014 20 CONTINUE 10015 PTR = 2**TLVLS + 1 10016 DO 70 K = 1, CURLVL - 1 10017 CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1 10018 PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) 10019 PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) 10020 ZPTR1 = MID - PSIZ1 10021 DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1 10022 CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1, 10023 $ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ), 10024 $ GIVNUM( 2, I ) ) 10025 30 CONTINUE 10026 DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1 10027 CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1, 10028 $ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ), 10029 $ GIVNUM( 2, I ) ) 10030 40 CONTINUE 10031 PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR ) 10032 PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 ) 10033 DO 50 I = 0, PSIZ1 - 1 10034 ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 ) 10035 50 CONTINUE 10036 DO 60 I = 0, PSIZ2 - 1 10037 ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 ) 10038 60 CONTINUE 10039 BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) ) 10040 BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+ 10041 $ 1 ) ) ) ) 10042 IF( BSIZ1.GT.0 ) THEN 10043 CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ), 10044 $ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 ) 10045 END IF 10046 CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ), 10047 $ 1 ) 10048 IF( BSIZ2.GT.0 ) THEN 10049 CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ), 10050 $ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 ) 10051 END IF 10052 CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1, 10053 $ Z( MID+BSIZ2 ), 1 ) 10054 PTR = PTR + 2**( TLVLS-K ) 10055 70 CONTINUE 10056 RETURN 10057 END 10058! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaev2.f 10059 SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) 10060 DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 10061 DOUBLE PRECISION ONE 10062 PARAMETER ( ONE = 1.0D0 ) 10063 DOUBLE PRECISION TWO 10064 PARAMETER ( TWO = 2.0D0 ) 10065 DOUBLE PRECISION ZERO 10066 PARAMETER ( ZERO = 0.0D0 ) 10067 DOUBLE PRECISION HALF 10068 PARAMETER ( HALF = 0.5D0 ) 10069 INTEGER SGN1, SGN2 10070 DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, 10071 $ TB, TN 10072 INTRINSIC ABS, SQRT 10073 SM = A + C 10074 DF = A - C 10075 ADF = ABS( DF ) 10076 TB = B + B 10077 AB = ABS( TB ) 10078 IF( ABS( A ).GT.ABS( C ) ) THEN 10079 ACMX = A 10080 ACMN = C 10081 ELSE 10082 ACMX = C 10083 ACMN = A 10084 END IF 10085 IF( ADF.GT.AB ) THEN 10086 RT = ADF*SQRT( ONE+( AB / ADF )**2 ) 10087 ELSE IF( ADF.LT.AB ) THEN 10088 RT = AB*SQRT( ONE+( ADF / AB )**2 ) 10089 ELSE 10090 RT = AB*SQRT( TWO ) 10091 END IF 10092 IF( SM.LT.ZERO ) THEN 10093 RT1 = HALF*( SM-RT ) 10094 SGN1 = -1 10095 RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B 10096 ELSE IF( SM.GT.ZERO ) THEN 10097 RT1 = HALF*( SM+RT ) 10098 SGN1 = 1 10099 RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B 10100 ELSE 10101 RT1 = HALF*RT 10102 RT2 = -HALF*RT 10103 SGN1 = 1 10104 END IF 10105 IF( DF.GE.ZERO ) THEN 10106 CS = DF + RT 10107 SGN2 = 1 10108 ELSE 10109 CS = DF - RT 10110 SGN2 = -1 10111 END IF 10112 ACS = ABS( CS ) 10113 IF( ACS.GT.AB ) THEN 10114 CT = -TB / CS 10115 SN1 = ONE / SQRT( ONE+CT*CT ) 10116 CS1 = CT*SN1 10117 ELSE 10118 IF( AB.EQ.ZERO ) THEN 10119 CS1 = ONE 10120 SN1 = ZERO 10121 ELSE 10122 TN = -CS / TB 10123 CS1 = ONE / SQRT( ONE+TN*TN ) 10124 SN1 = TN*CS1 10125 END IF 10126 END IF 10127 IF( SGN1.EQ.SGN2 ) THEN 10128 TN = CS1 10129 CS1 = -SN1 10130 SN1 = TN 10131 END IF 10132 RETURN 10133 END 10134! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlagtf.f 10135 SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) 10136 INTEGER INFO, N 10137 DOUBLE PRECISION LAMBDA, TOL 10138 INTEGER IN( * ) 10139 DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ) 10140 DOUBLE PRECISION ZERO 10141 PARAMETER ( ZERO = 0.0D+0 ) 10142 INTEGER K 10143 DOUBLE PRECISION EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL 10144 INTRINSIC ABS, MAX 10145 DOUBLE PRECISION DLAMCH 10146 EXTERNAL DLAMCH 10147 EXTERNAL XERBLA 10148 INFO = 0 10149 IF( N.LT.0 ) THEN 10150 INFO = -1 10151 CALL XERBLA( 'DLAGTF', -INFO ) 10152 RETURN 10153 END IF 10154 IF( N.EQ.0 ) 10155 $ RETURN 10156 A( 1 ) = A( 1 ) - LAMBDA 10157 IN( N ) = 0 10158 IF( N.EQ.1 ) THEN 10159 IF( A( 1 ).EQ.ZERO ) 10160 $ IN( 1 ) = 1 10161 RETURN 10162 END IF 10163 EPS = DLAMCH( 'Epsilon' ) 10164 TL = MAX( TOL, EPS ) 10165 SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) ) 10166 DO 10 K = 1, N - 1 10167 A( K+1 ) = A( K+1 ) - LAMBDA 10168 SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) ) 10169 IF( K.LT.( N-1 ) ) 10170 $ SCALE2 = SCALE2 + ABS( B( K+1 ) ) 10171 IF( A( K ).EQ.ZERO ) THEN 10172 PIV1 = ZERO 10173 ELSE 10174 PIV1 = ABS( A( K ) ) / SCALE1 10175 END IF 10176 IF( C( K ).EQ.ZERO ) THEN 10177 IN( K ) = 0 10178 PIV2 = ZERO 10179 SCALE1 = SCALE2 10180 IF( K.LT.( N-1 ) ) 10181 $ D( K ) = ZERO 10182 ELSE 10183 PIV2 = ABS( C( K ) ) / SCALE2 10184 IF( PIV2.LE.PIV1 ) THEN 10185 IN( K ) = 0 10186 SCALE1 = SCALE2 10187 C( K ) = C( K ) / A( K ) 10188 A( K+1 ) = A( K+1 ) - C( K )*B( K ) 10189 IF( K.LT.( N-1 ) ) 10190 $ D( K ) = ZERO 10191 ELSE 10192 IN( K ) = 1 10193 MULT = A( K ) / C( K ) 10194 A( K ) = C( K ) 10195 TEMP = A( K+1 ) 10196 A( K+1 ) = B( K ) - MULT*TEMP 10197 IF( K.LT.( N-1 ) ) THEN 10198 D( K ) = B( K+1 ) 10199 B( K+1 ) = -MULT*D( K ) 10200 END IF 10201 B( K ) = TEMP 10202 C( K ) = MULT 10203 END IF 10204 END IF 10205 IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) ) 10206 $ IN( N ) = K 10207 10 CONTINUE 10208 IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) ) 10209 $ IN( N ) = N 10210 RETURN 10211 END 10212! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlagts.f 10213 SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) 10214 INTEGER INFO, JOB, N 10215 DOUBLE PRECISION TOL 10216 INTEGER IN( * ) 10217 DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * ) 10218 DOUBLE PRECISION ONE, ZERO 10219 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 10220 INTEGER K 10221 DOUBLE PRECISION ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP 10222 INTRINSIC ABS, MAX, SIGN 10223 DOUBLE PRECISION DLAMCH 10224 EXTERNAL DLAMCH 10225 EXTERNAL XERBLA 10226 INFO = 0 10227 IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN 10228 INFO = -1 10229 ELSE IF( N.LT.0 ) THEN 10230 INFO = -2 10231 END IF 10232 IF( INFO.NE.0 ) THEN 10233 CALL XERBLA( 'DLAGTS', -INFO ) 10234 RETURN 10235 END IF 10236 IF( N.EQ.0 ) 10237 $ RETURN 10238 EPS = DLAMCH( 'Epsilon' ) 10239 SFMIN = DLAMCH( 'Safe minimum' ) 10240 BIGNUM = ONE / SFMIN 10241 IF( JOB.LT.0 ) THEN 10242 IF( TOL.LE.ZERO ) THEN 10243 TOL = ABS( A( 1 ) ) 10244 IF( N.GT.1 ) 10245 $ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) ) 10246 DO 10 K = 3, N 10247 TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ), 10248 $ ABS( D( K-2 ) ) ) 10249 10 CONTINUE 10250 TOL = TOL*EPS 10251 IF( TOL.EQ.ZERO ) 10252 $ TOL = EPS 10253 END IF 10254 END IF 10255 IF( ABS( JOB ).EQ.1 ) THEN 10256 DO 20 K = 2, N 10257 IF( IN( K-1 ).EQ.0 ) THEN 10258 Y( K ) = Y( K ) - C( K-1 )*Y( K-1 ) 10259 ELSE 10260 TEMP = Y( K-1 ) 10261 Y( K-1 ) = Y( K ) 10262 Y( K ) = TEMP - C( K-1 )*Y( K ) 10263 END IF 10264 20 CONTINUE 10265 IF( JOB.EQ.1 ) THEN 10266 DO 30 K = N, 1, -1 10267 IF( K.LE.N-2 ) THEN 10268 TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) 10269 ELSE IF( K.EQ.N-1 ) THEN 10270 TEMP = Y( K ) - B( K )*Y( K+1 ) 10271 ELSE 10272 TEMP = Y( K ) 10273 END IF 10274 AK = A( K ) 10275 ABSAK = ABS( AK ) 10276 IF( ABSAK.LT.ONE ) THEN 10277 IF( ABSAK.LT.SFMIN ) THEN 10278 IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) 10279 $ THEN 10280 INFO = K 10281 RETURN 10282 ELSE 10283 TEMP = TEMP*BIGNUM 10284 AK = AK*BIGNUM 10285 END IF 10286 ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN 10287 INFO = K 10288 RETURN 10289 END IF 10290 END IF 10291 Y( K ) = TEMP / AK 10292 30 CONTINUE 10293 ELSE 10294 DO 50 K = N, 1, -1 10295 IF( K.LE.N-2 ) THEN 10296 TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) 10297 ELSE IF( K.EQ.N-1 ) THEN 10298 TEMP = Y( K ) - B( K )*Y( K+1 ) 10299 ELSE 10300 TEMP = Y( K ) 10301 END IF 10302 AK = A( K ) 10303 PERT = SIGN( TOL, AK ) 10304 40 CONTINUE 10305 ABSAK = ABS( AK ) 10306 IF( ABSAK.LT.ONE ) THEN 10307 IF( ABSAK.LT.SFMIN ) THEN 10308 IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) 10309 $ THEN 10310 AK = AK + PERT 10311 PERT = 2*PERT 10312 GO TO 40 10313 ELSE 10314 TEMP = TEMP*BIGNUM 10315 AK = AK*BIGNUM 10316 END IF 10317 ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN 10318 AK = AK + PERT 10319 PERT = 2*PERT 10320 GO TO 40 10321 END IF 10322 END IF 10323 Y( K ) = TEMP / AK 10324 50 CONTINUE 10325 END IF 10326 ELSE 10327 IF( JOB.EQ.2 ) THEN 10328 DO 60 K = 1, N 10329 IF( K.GE.3 ) THEN 10330 TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) 10331 ELSE IF( K.EQ.2 ) THEN 10332 TEMP = Y( K ) - B( K-1 )*Y( K-1 ) 10333 ELSE 10334 TEMP = Y( K ) 10335 END IF 10336 AK = A( K ) 10337 ABSAK = ABS( AK ) 10338 IF( ABSAK.LT.ONE ) THEN 10339 IF( ABSAK.LT.SFMIN ) THEN 10340 IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) 10341 $ THEN 10342 INFO = K 10343 RETURN 10344 ELSE 10345 TEMP = TEMP*BIGNUM 10346 AK = AK*BIGNUM 10347 END IF 10348 ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN 10349 INFO = K 10350 RETURN 10351 END IF 10352 END IF 10353 Y( K ) = TEMP / AK 10354 60 CONTINUE 10355 ELSE 10356 DO 80 K = 1, N 10357 IF( K.GE.3 ) THEN 10358 TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) 10359 ELSE IF( K.EQ.2 ) THEN 10360 TEMP = Y( K ) - B( K-1 )*Y( K-1 ) 10361 ELSE 10362 TEMP = Y( K ) 10363 END IF 10364 AK = A( K ) 10365 PERT = SIGN( TOL, AK ) 10366 70 CONTINUE 10367 ABSAK = ABS( AK ) 10368 IF( ABSAK.LT.ONE ) THEN 10369 IF( ABSAK.LT.SFMIN ) THEN 10370 IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) 10371 $ THEN 10372 AK = AK + PERT 10373 PERT = 2*PERT 10374 GO TO 70 10375 ELSE 10376 TEMP = TEMP*BIGNUM 10377 AK = AK*BIGNUM 10378 END IF 10379 ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN 10380 AK = AK + PERT 10381 PERT = 2*PERT 10382 GO TO 70 10383 END IF 10384 END IF 10385 Y( K ) = TEMP / AK 10386 80 CONTINUE 10387 END IF 10388 DO 90 K = N, 2, -1 10389 IF( IN( K-1 ).EQ.0 ) THEN 10390 Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K ) 10391 ELSE 10392 TEMP = Y( K-1 ) 10393 Y( K-1 ) = Y( K ) 10394 Y( K ) = TEMP - C( K-1 )*Y( K ) 10395 END IF 10396 90 CONTINUE 10397 END IF 10398 END 10399! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaisnan.f 10400 LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 ) 10401 DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2 10402 DLAISNAN = (DIN1.NE.DIN2) 10403 RETURN 10404 END 10405! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlamrg.f 10406 SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) 10407 INTEGER DTRD1, DTRD2, N1, N2 10408 INTEGER INDEX( * ) 10409 DOUBLE PRECISION A( * ) 10410 INTEGER I, IND1, IND2, N1SV, N2SV 10411 N1SV = N1 10412 N2SV = N2 10413 IF( DTRD1.GT.0 ) THEN 10414 IND1 = 1 10415 ELSE 10416 IND1 = N1 10417 END IF 10418 IF( DTRD2.GT.0 ) THEN 10419 IND2 = 1 + N1 10420 ELSE 10421 IND2 = N1 + N2 10422 END IF 10423 I = 1 10424 10 CONTINUE 10425 IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN 10426 IF( A( IND1 ).LE.A( IND2 ) ) THEN 10427 INDEX( I ) = IND1 10428 I = I + 1 10429 IND1 = IND1 + DTRD1 10430 N1SV = N1SV - 1 10431 ELSE 10432 INDEX( I ) = IND2 10433 I = I + 1 10434 IND2 = IND2 + DTRD2 10435 N2SV = N2SV - 1 10436 END IF 10437 GO TO 10 10438 END IF 10439 IF( N1SV.EQ.0 ) THEN 10440 DO 20 N1SV = 1, N2SV 10441 INDEX( I ) = IND2 10442 I = I + 1 10443 IND2 = IND2 + DTRD2 10444 20 CONTINUE 10445 ELSE 10446 DO 30 N2SV = 1, N1SV 10447 INDEX( I ) = IND1 10448 I = I + 1 10449 IND1 = IND1 + DTRD1 10450 30 CONTINUE 10451 END IF 10452 RETURN 10453 END 10454! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaneg.f 10455 INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R ) 10456 INTEGER N, R 10457 DOUBLE PRECISION PIVMIN, SIGMA 10458 DOUBLE PRECISION D( * ), LLD( * ) 10459 DOUBLE PRECISION ZERO, ONE 10460 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 10461 INTEGER BLKLEN 10462 PARAMETER ( BLKLEN = 128 ) 10463 INTEGER BJ, J, NEG1, NEG2, NEGCNT 10464 DOUBLE PRECISION BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP 10465 LOGICAL SAWNAN 10466 INTRINSIC MIN, MAX 10467 LOGICAL DISNAN 10468 EXTERNAL DISNAN 10469 NEGCNT = 0 10470 T = -SIGMA 10471 DO 210 BJ = 1, R-1, BLKLEN 10472 NEG1 = 0 10473 BSAV = T 10474 DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1) 10475 DPLUS = D( J ) + T 10476 IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1 10477 TMP = T / DPLUS 10478 T = TMP * LLD( J ) - SIGMA 10479 21 CONTINUE 10480 SAWNAN = DISNAN( T ) 10481 IF( SAWNAN ) THEN 10482 NEG1 = 0 10483 T = BSAV 10484 DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1) 10485 DPLUS = D( J ) + T 10486 IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1 10487 TMP = T / DPLUS 10488 IF (DISNAN(TMP)) TMP = ONE 10489 T = TMP * LLD(J) - SIGMA 10490 22 CONTINUE 10491 END IF 10492 NEGCNT = NEGCNT + NEG1 10493 210 CONTINUE 10494 P = D( N ) - SIGMA 10495 DO 230 BJ = N-1, R, -BLKLEN 10496 NEG2 = 0 10497 BSAV = P 10498 DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1 10499 DMINUS = LLD( J ) + P 10500 IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1 10501 TMP = P / DMINUS 10502 P = TMP * D( J ) - SIGMA 10503 23 CONTINUE 10504 SAWNAN = DISNAN( P ) 10505 IF( SAWNAN ) THEN 10506 NEG2 = 0 10507 P = BSAV 10508 DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1 10509 DMINUS = LLD( J ) + P 10510 IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1 10511 TMP = P / DMINUS 10512 IF (DISNAN(TMP)) TMP = ONE 10513 P = TMP * D(J) - SIGMA 10514 24 CONTINUE 10515 END IF 10516 NEGCNT = NEGCNT + NEG2 10517 230 CONTINUE 10518 GAMMA = (T + SIGMA) + P 10519 IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1 10520 DLANEG = NEGCNT 10521 END 10522! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlangb.f 10523 DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, 10524 $ WORK ) 10525 IMPLICIT NONE 10526 CHARACTER NORM 10527 INTEGER KL, KU, LDAB, N 10528 DOUBLE PRECISION AB( LDAB, * ), WORK( * ) 10529 DOUBLE PRECISION ONE, ZERO 10530 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 10531 INTEGER I, J, K, L 10532 DOUBLE PRECISION SUM, VALUE, TEMP 10533 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 10534 LOGICAL LSAME, DISNAN 10535 EXTERNAL LSAME, DISNAN 10536 EXTERNAL DLASSQ, DCOMBSSQ 10537 INTRINSIC ABS, MAX, MIN, SQRT 10538 IF( N.EQ.0 ) THEN 10539 VALUE = ZERO 10540 ELSE IF( LSAME( NORM, 'M' ) ) THEN 10541 VALUE = ZERO 10542 DO 20 J = 1, N 10543 DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) 10544 TEMP = ABS( AB( I, J ) ) 10545 IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 10546 10 CONTINUE 10547 20 CONTINUE 10548 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 10549 VALUE = ZERO 10550 DO 40 J = 1, N 10551 SUM = ZERO 10552 DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) 10553 SUM = SUM + ABS( AB( I, J ) ) 10554 30 CONTINUE 10555 IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10556 40 CONTINUE 10557 ELSE IF( LSAME( NORM, 'I' ) ) THEN 10558 DO 50 I = 1, N 10559 WORK( I ) = ZERO 10560 50 CONTINUE 10561 DO 70 J = 1, N 10562 K = KU + 1 - J 10563 DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL ) 10564 WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) ) 10565 60 CONTINUE 10566 70 CONTINUE 10567 VALUE = ZERO 10568 DO 80 I = 1, N 10569 TEMP = WORK( I ) 10570 IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 10571 80 CONTINUE 10572 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 10573 SSQ( 1 ) = ZERO 10574 SSQ( 2 ) = ONE 10575 DO 90 J = 1, N 10576 L = MAX( 1, J-KU ) 10577 K = KU + 1 - J + L 10578 COLSSQ( 1 ) = ZERO 10579 COLSSQ( 2 ) = ONE 10580 CALL DLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, 10581 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 10582 CALL DCOMBSSQ( SSQ, COLSSQ ) 10583 90 CONTINUE 10584 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 10585 END IF 10586 DLANGB = VALUE 10587 RETURN 10588 END 10589! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlange.f 10590 DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) 10591 IMPLICIT NONE 10592 CHARACTER NORM 10593 INTEGER LDA, M, N 10594 DOUBLE PRECISION A( LDA, * ), WORK( * ) 10595 DOUBLE PRECISION ONE, ZERO 10596 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 10597 INTEGER I, J 10598 DOUBLE PRECISION SUM, VALUE, TEMP 10599 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 10600 EXTERNAL DLASSQ, DCOMBSSQ 10601 LOGICAL LSAME, DISNAN 10602 EXTERNAL LSAME, DISNAN 10603 INTRINSIC ABS, MIN, SQRT 10604 IF( MIN( M, N ).EQ.0 ) THEN 10605 VALUE = ZERO 10606 ELSE IF( LSAME( NORM, 'M' ) ) THEN 10607 VALUE = ZERO 10608 DO 20 J = 1, N 10609 DO 10 I = 1, M 10610 TEMP = ABS( A( I, J ) ) 10611 IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 10612 10 CONTINUE 10613 20 CONTINUE 10614 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 10615 VALUE = ZERO 10616 DO 40 J = 1, N 10617 SUM = ZERO 10618 DO 30 I = 1, M 10619 SUM = SUM + ABS( A( I, J ) ) 10620 30 CONTINUE 10621 IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10622 40 CONTINUE 10623 ELSE IF( LSAME( NORM, 'I' ) ) THEN 10624 DO 50 I = 1, M 10625 WORK( I ) = ZERO 10626 50 CONTINUE 10627 DO 70 J = 1, N 10628 DO 60 I = 1, M 10629 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 10630 60 CONTINUE 10631 70 CONTINUE 10632 VALUE = ZERO 10633 DO 80 I = 1, M 10634 TEMP = WORK( I ) 10635 IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 10636 80 CONTINUE 10637 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 10638 SSQ( 1 ) = ZERO 10639 SSQ( 2 ) = ONE 10640 DO 90 J = 1, N 10641 COLSSQ( 1 ) = ZERO 10642 COLSSQ( 2 ) = ONE 10643 CALL DLASSQ( M, A( 1, J ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 10644 CALL DCOMBSSQ( SSQ, COLSSQ ) 10645 90 CONTINUE 10646 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 10647 END IF 10648 DLANGE = VALUE 10649 RETURN 10650 END 10651! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlangt.f 10652 DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) 10653 CHARACTER NORM 10654 INTEGER N 10655 DOUBLE PRECISION D( * ), DL( * ), DU( * ) 10656 DOUBLE PRECISION ONE, ZERO 10657 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 10658 INTEGER I 10659 DOUBLE PRECISION ANORM, SCALE, SUM, TEMP 10660 LOGICAL LSAME, DISNAN 10661 EXTERNAL LSAME, DISNAN 10662 EXTERNAL DLASSQ 10663 INTRINSIC ABS, SQRT 10664 IF( N.LE.0 ) THEN 10665 ANORM = ZERO 10666 ELSE IF( LSAME( NORM, 'M' ) ) THEN 10667 ANORM = ABS( D( N ) ) 10668 DO 10 I = 1, N - 1 10669 IF( ANORM.LT.ABS( DL( I ) ) .OR. DISNAN( ABS( DL( I ) ) ) ) 10670 $ ANORM = ABS(DL(I)) 10671 IF( ANORM.LT.ABS( D( I ) ) .OR. DISNAN( ABS( D( I ) ) ) ) 10672 $ ANORM = ABS(D(I)) 10673 IF( ANORM.LT.ABS( DU( I ) ) .OR. DISNAN (ABS( DU( I ) ) ) ) 10674 $ ANORM = ABS(DU(I)) 10675 10 CONTINUE 10676 ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN 10677 IF( N.EQ.1 ) THEN 10678 ANORM = ABS( D( 1 ) ) 10679 ELSE 10680 ANORM = ABS( D( 1 ) )+ABS( DL( 1 ) ) 10681 TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) 10682 IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP 10683 DO 20 I = 2, N - 1 10684 TEMP = ABS( D( I ) )+ABS( DL( I ) )+ABS( DU( I-1 ) ) 10685 IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP 10686 20 CONTINUE 10687 END IF 10688 ELSE IF( LSAME( NORM, 'I' ) ) THEN 10689 IF( N.EQ.1 ) THEN 10690 ANORM = ABS( D( 1 ) ) 10691 ELSE 10692 ANORM = ABS( D( 1 ) )+ABS( DU( 1 ) ) 10693 TEMP = ABS( D( N ) )+ABS( DL( N-1 ) ) 10694 IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP 10695 DO 30 I = 2, N - 1 10696 TEMP = ABS( D( I ) )+ABS( DU( I ) )+ABS( DL( I-1 ) ) 10697 IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP 10698 30 CONTINUE 10699 END IF 10700 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 10701 SCALE = ZERO 10702 SUM = ONE 10703 CALL DLASSQ( N, D, 1, SCALE, SUM ) 10704 IF( N.GT.1 ) THEN 10705 CALL DLASSQ( N-1, DL, 1, SCALE, SUM ) 10706 CALL DLASSQ( N-1, DU, 1, SCALE, SUM ) 10707 END IF 10708 ANORM = SCALE*SQRT( SUM ) 10709 END IF 10710 DLANGT = ANORM 10711 RETURN 10712 END 10713! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlanhs.f 10714 DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) 10715 IMPLICIT NONE 10716 CHARACTER NORM 10717 INTEGER LDA, N 10718 DOUBLE PRECISION A( LDA, * ), WORK( * ) 10719 DOUBLE PRECISION ONE, ZERO 10720 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 10721 INTEGER I, J 10722 DOUBLE PRECISION SUM, VALUE 10723 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 10724 LOGICAL LSAME, DISNAN 10725 EXTERNAL LSAME, DISNAN 10726 EXTERNAL DLASSQ, DCOMBSSQ 10727 INTRINSIC ABS, MIN, SQRT 10728 IF( N.EQ.0 ) THEN 10729 VALUE = ZERO 10730 ELSE IF( LSAME( NORM, 'M' ) ) THEN 10731 VALUE = ZERO 10732 DO 20 J = 1, N 10733 DO 10 I = 1, MIN( N, J+1 ) 10734 SUM = ABS( A( I, J ) ) 10735 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10736 10 CONTINUE 10737 20 CONTINUE 10738 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 10739 VALUE = ZERO 10740 DO 40 J = 1, N 10741 SUM = ZERO 10742 DO 30 I = 1, MIN( N, J+1 ) 10743 SUM = SUM + ABS( A( I, J ) ) 10744 30 CONTINUE 10745 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10746 40 CONTINUE 10747 ELSE IF( LSAME( NORM, 'I' ) ) THEN 10748 DO 50 I = 1, N 10749 WORK( I ) = ZERO 10750 50 CONTINUE 10751 DO 70 J = 1, N 10752 DO 60 I = 1, MIN( N, J+1 ) 10753 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 10754 60 CONTINUE 10755 70 CONTINUE 10756 VALUE = ZERO 10757 DO 80 I = 1, N 10758 SUM = WORK( I ) 10759 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10760 80 CONTINUE 10761 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 10762 SSQ( 1 ) = ZERO 10763 SSQ( 2 ) = ONE 10764 DO 90 J = 1, N 10765 COLSSQ( 1 ) = ZERO 10766 COLSSQ( 2 ) = ONE 10767 CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, 10768 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 10769 CALL DCOMBSSQ( SSQ, COLSSQ ) 10770 90 CONTINUE 10771 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 10772 END IF 10773 DLANHS = VALUE 10774 RETURN 10775 END 10776! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlansb.f 10777 DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, 10778 $ WORK ) 10779 IMPLICIT NONE 10780 CHARACTER NORM, UPLO 10781 INTEGER K, LDAB, N 10782 DOUBLE PRECISION AB( LDAB, * ), WORK( * ) 10783 DOUBLE PRECISION ONE, ZERO 10784 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 10785 INTEGER I, J, L 10786 DOUBLE PRECISION ABSA, SUM, VALUE 10787 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 10788 LOGICAL LSAME, DISNAN 10789 EXTERNAL LSAME, DISNAN 10790 EXTERNAL DLASSQ, DCOMBSSQ 10791 INTRINSIC ABS, MAX, MIN, SQRT 10792 IF( N.EQ.0 ) THEN 10793 VALUE = ZERO 10794 ELSE IF( LSAME( NORM, 'M' ) ) THEN 10795 VALUE = ZERO 10796 IF( LSAME( UPLO, 'U' ) ) THEN 10797 DO 20 J = 1, N 10798 DO 10 I = MAX( K+2-J, 1 ), K + 1 10799 SUM = ABS( AB( I, J ) ) 10800 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10801 10 CONTINUE 10802 20 CONTINUE 10803 ELSE 10804 DO 40 J = 1, N 10805 DO 30 I = 1, MIN( N+1-J, K+1 ) 10806 SUM = ABS( AB( I, J ) ) 10807 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10808 30 CONTINUE 10809 40 CONTINUE 10810 END IF 10811 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 10812 $ ( NORM.EQ.'1' ) ) THEN 10813 VALUE = ZERO 10814 IF( LSAME( UPLO, 'U' ) ) THEN 10815 DO 60 J = 1, N 10816 SUM = ZERO 10817 L = K + 1 - J 10818 DO 50 I = MAX( 1, J-K ), J - 1 10819 ABSA = ABS( AB( L+I, J ) ) 10820 SUM = SUM + ABSA 10821 WORK( I ) = WORK( I ) + ABSA 10822 50 CONTINUE 10823 WORK( J ) = SUM + ABS( AB( K+1, J ) ) 10824 60 CONTINUE 10825 DO 70 I = 1, N 10826 SUM = WORK( I ) 10827 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10828 70 CONTINUE 10829 ELSE 10830 DO 80 I = 1, N 10831 WORK( I ) = ZERO 10832 80 CONTINUE 10833 DO 100 J = 1, N 10834 SUM = WORK( J ) + ABS( AB( 1, J ) ) 10835 L = 1 - J 10836 DO 90 I = J + 1, MIN( N, J+K ) 10837 ABSA = ABS( AB( L+I, J ) ) 10838 SUM = SUM + ABSA 10839 WORK( I ) = WORK( I ) + ABSA 10840 90 CONTINUE 10841 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 10842 100 CONTINUE 10843 END IF 10844 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 10845 SSQ( 1 ) = ZERO 10846 SSQ( 2 ) = ONE 10847 IF( K.GT.0 ) THEN 10848 IF( LSAME( UPLO, 'U' ) ) THEN 10849 DO 110 J = 2, N 10850 COLSSQ( 1 ) = ZERO 10851 COLSSQ( 2 ) = ONE 10852 CALL DLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), 10853 $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 10854 CALL DCOMBSSQ( SSQ, COLSSQ ) 10855 110 CONTINUE 10856 L = K + 1 10857 ELSE 10858 DO 120 J = 1, N - 1 10859 COLSSQ( 1 ) = ZERO 10860 COLSSQ( 2 ) = ONE 10861 CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, 10862 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 10863 CALL DCOMBSSQ( SSQ, COLSSQ ) 10864 120 CONTINUE 10865 L = 1 10866 END IF 10867 SSQ( 2 ) = 2*SSQ( 2 ) 10868 ELSE 10869 L = 1 10870 END IF 10871 COLSSQ( 1 ) = ZERO 10872 COLSSQ( 2 ) = ONE 10873 CALL DLASSQ( N, AB( L, 1 ), LDAB, COLSSQ( 1 ), COLSSQ( 2 ) ) 10874 CALL DCOMBSSQ( SSQ, COLSSQ ) 10875 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 10876 END IF 10877 DLANSB = VALUE 10878 RETURN 10879 END 10880! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlansf.f 10881 DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) 10882 CHARACTER NORM, TRANSR, UPLO 10883 INTEGER N 10884 DOUBLE PRECISION A( 0: * ), WORK( 0: * ) 10885 DOUBLE PRECISION ONE, ZERO 10886 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 10887 INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA 10888 DOUBLE PRECISION SCALE, S, VALUE, AA, TEMP 10889 LOGICAL LSAME, DISNAN 10890 EXTERNAL LSAME, DISNAN 10891 EXTERNAL DLASSQ 10892 INTRINSIC ABS, MAX, SQRT 10893 IF( N.EQ.0 ) THEN 10894 DLANSF = ZERO 10895 RETURN 10896 ELSE IF( N.EQ.1 ) THEN 10897 DLANSF = ABS( A(0) ) 10898 RETURN 10899 END IF 10900 NOE = 1 10901 IF( MOD( N, 2 ).EQ.0 ) 10902 $ NOE = 0 10903 IFM = 1 10904 IF( LSAME( TRANSR, 'T' ) ) 10905 $ IFM = 0 10906 ILU = 1 10907 IF( LSAME( UPLO, 'U' ) ) 10908 $ ILU = 0 10909 IF( IFM.EQ.1 ) THEN 10910 IF( NOE.EQ.1 ) THEN 10911 LDA = N 10912 ELSE 10913 LDA = N + 1 10914 END IF 10915 ELSE 10916 LDA = ( N+1 ) / 2 10917 END IF 10918 IF( LSAME( NORM, 'M' ) ) THEN 10919 K = ( N+1 ) / 2 10920 VALUE = ZERO 10921 IF( NOE.EQ.1 ) THEN 10922 IF( IFM.EQ.1 ) THEN 10923 DO J = 0, K - 1 10924 DO I = 0, N - 1 10925 TEMP = ABS( A( I+J*LDA ) ) 10926 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 10927 $ VALUE = TEMP 10928 END DO 10929 END DO 10930 ELSE 10931 DO J = 0, N - 1 10932 DO I = 0, K - 1 10933 TEMP = ABS( A( I+J*LDA ) ) 10934 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 10935 $ VALUE = TEMP 10936 END DO 10937 END DO 10938 END IF 10939 ELSE 10940 IF( IFM.EQ.1 ) THEN 10941 DO J = 0, K - 1 10942 DO I = 0, N 10943 TEMP = ABS( A( I+J*LDA ) ) 10944 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 10945 $ VALUE = TEMP 10946 END DO 10947 END DO 10948 ELSE 10949 DO J = 0, N 10950 DO I = 0, K - 1 10951 TEMP = ABS( A( I+J*LDA ) ) 10952 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 10953 $ VALUE = TEMP 10954 END DO 10955 END DO 10956 END IF 10957 END IF 10958 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 10959 $ ( NORM.EQ.'1' ) ) THEN 10960 IF( IFM.EQ.1 ) THEN 10961 K = N / 2 10962 IF( NOE.EQ.1 ) THEN 10963 IF( ILU.EQ.0 ) THEN 10964 DO I = 0, K - 1 10965 WORK( I ) = ZERO 10966 END DO 10967 DO J = 0, K 10968 S = ZERO 10969 DO I = 0, K + J - 1 10970 AA = ABS( A( I+J*LDA ) ) 10971 S = S + AA 10972 WORK( I ) = WORK( I ) + AA 10973 END DO 10974 AA = ABS( A( I+J*LDA ) ) 10975 WORK( J+K ) = S + AA 10976 IF( I.EQ.K+K ) 10977 $ GO TO 10 10978 I = I + 1 10979 AA = ABS( A( I+J*LDA ) ) 10980 WORK( J ) = WORK( J ) + AA 10981 S = ZERO 10982 DO L = J + 1, K - 1 10983 I = I + 1 10984 AA = ABS( A( I+J*LDA ) ) 10985 S = S + AA 10986 WORK( L ) = WORK( L ) + AA 10987 END DO 10988 WORK( J ) = WORK( J ) + S 10989 END DO 10990 10 CONTINUE 10991 VALUE = WORK( 0 ) 10992 DO I = 1, N-1 10993 TEMP = WORK( I ) 10994 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 10995 $ VALUE = TEMP 10996 END DO 10997 ELSE 10998 K = K + 1 10999 DO I = K, N - 1 11000 WORK( I ) = ZERO 11001 END DO 11002 DO J = K - 1, 0, -1 11003 S = ZERO 11004 DO I = 0, J - 2 11005 AA = ABS( A( I+J*LDA ) ) 11006 S = S + AA 11007 WORK( I+K ) = WORK( I+K ) + AA 11008 END DO 11009 IF( J.GT.0 ) THEN 11010 AA = ABS( A( I+J*LDA ) ) 11011 S = S + AA 11012 WORK( I+K ) = WORK( I+K ) + S 11013 I = I + 1 11014 END IF 11015 AA = ABS( A( I+J*LDA ) ) 11016 WORK( J ) = AA 11017 S = ZERO 11018 DO L = J + 1, N - 1 11019 I = I + 1 11020 AA = ABS( A( I+J*LDA ) ) 11021 S = S + AA 11022 WORK( L ) = WORK( L ) + AA 11023 END DO 11024 WORK( J ) = WORK( J ) + S 11025 END DO 11026 VALUE = WORK( 0 ) 11027 DO I = 1, N-1 11028 TEMP = WORK( I ) 11029 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 11030 $ VALUE = TEMP 11031 END DO 11032 END IF 11033 ELSE 11034 IF( ILU.EQ.0 ) THEN 11035 DO I = 0, K - 1 11036 WORK( I ) = ZERO 11037 END DO 11038 DO J = 0, K - 1 11039 S = ZERO 11040 DO I = 0, K + J - 1 11041 AA = ABS( A( I+J*LDA ) ) 11042 S = S + AA 11043 WORK( I ) = WORK( I ) + AA 11044 END DO 11045 AA = ABS( A( I+J*LDA ) ) 11046 WORK( J+K ) = S + AA 11047 I = I + 1 11048 AA = ABS( A( I+J*LDA ) ) 11049 WORK( J ) = WORK( J ) + AA 11050 S = ZERO 11051 DO L = J + 1, K - 1 11052 I = I + 1 11053 AA = ABS( A( I+J*LDA ) ) 11054 S = S + AA 11055 WORK( L ) = WORK( L ) + AA 11056 END DO 11057 WORK( J ) = WORK( J ) + S 11058 END DO 11059 VALUE = WORK( 0 ) 11060 DO I = 1, N-1 11061 TEMP = WORK( I ) 11062 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 11063 $ VALUE = TEMP 11064 END DO 11065 ELSE 11066 DO I = K, N - 1 11067 WORK( I ) = ZERO 11068 END DO 11069 DO J = K - 1, 0, -1 11070 S = ZERO 11071 DO I = 0, J - 1 11072 AA = ABS( A( I+J*LDA ) ) 11073 S = S + AA 11074 WORK( I+K ) = WORK( I+K ) + AA 11075 END DO 11076 AA = ABS( A( I+J*LDA ) ) 11077 S = S + AA 11078 WORK( I+K ) = WORK( I+K ) + S 11079 I = I + 1 11080 AA = ABS( A( I+J*LDA ) ) 11081 WORK( J ) = AA 11082 S = ZERO 11083 DO L = J + 1, N - 1 11084 I = I + 1 11085 AA = ABS( A( I+J*LDA ) ) 11086 S = S + AA 11087 WORK( L ) = WORK( L ) + AA 11088 END DO 11089 WORK( J ) = WORK( J ) + S 11090 END DO 11091 VALUE = WORK( 0 ) 11092 DO I = 1, N-1 11093 TEMP = WORK( I ) 11094 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 11095 $ VALUE = TEMP 11096 END DO 11097 END IF 11098 END IF 11099 ELSE 11100 K = N / 2 11101 IF( NOE.EQ.1 ) THEN 11102 IF( ILU.EQ.0 ) THEN 11103 N1 = K 11104 K = K + 1 11105 DO I = N1, N - 1 11106 WORK( I ) = ZERO 11107 END DO 11108 DO J = 0, N1 - 1 11109 S = ZERO 11110 DO I = 0, K - 1 11111 AA = ABS( A( I+J*LDA ) ) 11112 WORK( I+N1 ) = WORK( I+N1 ) + AA 11113 S = S + AA 11114 END DO 11115 WORK( J ) = S 11116 END DO 11117 S = ABS( A( 0+J*LDA ) ) 11118 DO I = 1, K - 1 11119 AA = ABS( A( I+J*LDA ) ) 11120 WORK( I+N1 ) = WORK( I+N1 ) + AA 11121 S = S + AA 11122 END DO 11123 WORK( J ) = WORK( J ) + S 11124 DO J = K, N - 1 11125 S = ZERO 11126 DO I = 0, J - K - 1 11127 AA = ABS( A( I+J*LDA ) ) 11128 WORK( I ) = WORK( I ) + AA 11129 S = S + AA 11130 END DO 11131 AA = ABS( A( I+J*LDA ) ) 11132 S = S + AA 11133 WORK( J-K ) = WORK( J-K ) + S 11134 I = I + 1 11135 S = ABS( A( I+J*LDA ) ) 11136 DO L = J + 1, N - 1 11137 I = I + 1 11138 AA = ABS( A( I+J*LDA ) ) 11139 WORK( L ) = WORK( L ) + AA 11140 S = S + AA 11141 END DO 11142 WORK( J ) = WORK( J ) + S 11143 END DO 11144 VALUE = WORK( 0 ) 11145 DO I = 1, N-1 11146 TEMP = WORK( I ) 11147 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 11148 $ VALUE = TEMP 11149 END DO 11150 ELSE 11151 K = K + 1 11152 DO I = K, N - 1 11153 WORK( I ) = ZERO 11154 END DO 11155 DO J = 0, K - 2 11156 S = ZERO 11157 DO I = 0, J - 1 11158 AA = ABS( A( I+J*LDA ) ) 11159 WORK( I ) = WORK( I ) + AA 11160 S = S + AA 11161 END DO 11162 AA = ABS( A( I+J*LDA ) ) 11163 S = S + AA 11164 WORK( J ) = S 11165 I = I + 1 11166 AA = ABS( A( I+J*LDA ) ) 11167 S = AA 11168 DO L = K + J + 1, N - 1 11169 I = I + 1 11170 AA = ABS( A( I+J*LDA ) ) 11171 S = S + AA 11172 WORK( L ) = WORK( L ) + AA 11173 END DO 11174 WORK( K+J ) = WORK( K+J ) + S 11175 END DO 11176 S = ZERO 11177 DO I = 0, K - 2 11178 AA = ABS( A( I+J*LDA ) ) 11179 WORK( I ) = WORK( I ) + AA 11180 S = S + AA 11181 END DO 11182 AA = ABS( A( I+J*LDA ) ) 11183 S = S + AA 11184 WORK( I ) = S 11185 DO J = K, N - 1 11186 S = ZERO 11187 DO I = 0, K - 1 11188 AA = ABS( A( I+J*LDA ) ) 11189 WORK( I ) = WORK( I ) + AA 11190 S = S + AA 11191 END DO 11192 WORK( J ) = WORK( J ) + S 11193 END DO 11194 VALUE = WORK( 0 ) 11195 DO I = 1, N-1 11196 TEMP = WORK( I ) 11197 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 11198 $ VALUE = TEMP 11199 END DO 11200 END IF 11201 ELSE 11202 IF( ILU.EQ.0 ) THEN 11203 DO I = K, N - 1 11204 WORK( I ) = ZERO 11205 END DO 11206 DO J = 0, K - 1 11207 S = ZERO 11208 DO I = 0, K - 1 11209 AA = ABS( A( I+J*LDA ) ) 11210 WORK( I+K ) = WORK( I+K ) + AA 11211 S = S + AA 11212 END DO 11213 WORK( J ) = S 11214 END DO 11215 AA = ABS( A( 0+J*LDA ) ) 11216 S = AA 11217 DO I = 1, K - 1 11218 AA = ABS( A( I+J*LDA ) ) 11219 WORK( I+K ) = WORK( I+K ) + AA 11220 S = S + AA 11221 END DO 11222 WORK( J ) = WORK( J ) + S 11223 DO J = K + 1, N - 1 11224 S = ZERO 11225 DO I = 0, J - 2 - K 11226 AA = ABS( A( I+J*LDA ) ) 11227 WORK( I ) = WORK( I ) + AA 11228 S = S + AA 11229 END DO 11230 AA = ABS( A( I+J*LDA ) ) 11231 S = S + AA 11232 WORK( J-K-1 ) = WORK( J-K-1 ) + S 11233 I = I + 1 11234 AA = ABS( A( I+J*LDA ) ) 11235 S = AA 11236 DO L = J + 1, N - 1 11237 I = I + 1 11238 AA = ABS( A( I+J*LDA ) ) 11239 WORK( L ) = WORK( L ) + AA 11240 S = S + AA 11241 END DO 11242 WORK( J ) = WORK( J ) + S 11243 END DO 11244 S = ZERO 11245 DO I = 0, K - 2 11246 AA = ABS( A( I+J*LDA ) ) 11247 WORK( I ) = WORK( I ) + AA 11248 S = S + AA 11249 END DO 11250 AA = ABS( A( I+J*LDA ) ) 11251 S = S + AA 11252 WORK( I ) = WORK( I ) + S 11253 VALUE = WORK( 0 ) 11254 DO I = 1, N-1 11255 TEMP = WORK( I ) 11256 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 11257 $ VALUE = TEMP 11258 END DO 11259 ELSE 11260 DO I = K, N - 1 11261 WORK( I ) = ZERO 11262 END DO 11263 S = ABS( A( 0 ) ) 11264 DO I = 1, K - 1 11265 AA = ABS( A( I ) ) 11266 WORK( I+K ) = WORK( I+K ) + AA 11267 S = S + AA 11268 END DO 11269 WORK( K ) = WORK( K ) + S 11270 DO J = 1, K - 1 11271 S = ZERO 11272 DO I = 0, J - 2 11273 AA = ABS( A( I+J*LDA ) ) 11274 WORK( I ) = WORK( I ) + AA 11275 S = S + AA 11276 END DO 11277 AA = ABS( A( I+J*LDA ) ) 11278 S = S + AA 11279 WORK( J-1 ) = S 11280 I = I + 1 11281 AA = ABS( A( I+J*LDA ) ) 11282 S = AA 11283 DO L = K + J + 1, N - 1 11284 I = I + 1 11285 AA = ABS( A( I+J*LDA ) ) 11286 S = S + AA 11287 WORK( L ) = WORK( L ) + AA 11288 END DO 11289 WORK( K+J ) = WORK( K+J ) + S 11290 END DO 11291 S = ZERO 11292 DO I = 0, K - 2 11293 AA = ABS( A( I+J*LDA ) ) 11294 WORK( I ) = WORK( I ) + AA 11295 S = S + AA 11296 END DO 11297 AA = ABS( A( I+J*LDA ) ) 11298 S = S + AA 11299 WORK( I ) = S 11300 DO J = K + 1, N 11301 S = ZERO 11302 DO I = 0, K - 1 11303 AA = ABS( A( I+J*LDA ) ) 11304 WORK( I ) = WORK( I ) + AA 11305 S = S + AA 11306 END DO 11307 WORK( J-1 ) = WORK( J-1 ) + S 11308 END DO 11309 VALUE = WORK( 0 ) 11310 DO I = 1, N-1 11311 TEMP = WORK( I ) 11312 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 11313 $ VALUE = TEMP 11314 END DO 11315 END IF 11316 END IF 11317 END IF 11318 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 11319 K = ( N+1 ) / 2 11320 SCALE = ZERO 11321 S = ONE 11322 IF( NOE.EQ.1 ) THEN 11323 IF( IFM.EQ.1 ) THEN 11324 IF( ILU.EQ.0 ) THEN 11325 DO J = 0, K - 3 11326 CALL DLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S ) 11327 END DO 11328 DO J = 0, K - 1 11329 CALL DLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S ) 11330 END DO 11331 S = S + S 11332 CALL DLASSQ( K-1, A( K ), LDA+1, SCALE, S ) 11333 CALL DLASSQ( K, A( K-1 ), LDA+1, SCALE, S ) 11334 ELSE 11335 DO J = 0, K - 1 11336 CALL DLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S ) 11337 END DO 11338 DO J = 0, K - 2 11339 CALL DLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S ) 11340 END DO 11341 S = S + S 11342 CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) 11343 CALL DLASSQ( K-1, A( 0+LDA ), LDA+1, SCALE, S ) 11344 END IF 11345 ELSE 11346 IF( ILU.EQ.0 ) THEN 11347 DO J = 1, K - 2 11348 CALL DLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S ) 11349 END DO 11350 DO J = 0, K - 2 11351 CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 11352 END DO 11353 DO J = 0, K - 2 11354 CALL DLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1, 11355 $ SCALE, S ) 11356 END DO 11357 S = S + S 11358 CALL DLASSQ( K-1, A( 0+K*LDA ), LDA+1, SCALE, S ) 11359 CALL DLASSQ( K, A( 0+( K-1 )*LDA ), LDA+1, SCALE, S ) 11360 ELSE 11361 DO J = 1, K - 1 11362 CALL DLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) 11363 END DO 11364 DO J = K, N - 1 11365 CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 11366 END DO 11367 DO J = 0, K - 3 11368 CALL DLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S ) 11369 END DO 11370 S = S + S 11371 CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) 11372 CALL DLASSQ( K-1, A( 1 ), LDA+1, SCALE, S ) 11373 END IF 11374 END IF 11375 ELSE 11376 IF( IFM.EQ.1 ) THEN 11377 IF( ILU.EQ.0 ) THEN 11378 DO J = 0, K - 2 11379 CALL DLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S ) 11380 END DO 11381 DO J = 0, K - 1 11382 CALL DLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S ) 11383 END DO 11384 S = S + S 11385 CALL DLASSQ( K, A( K+1 ), LDA+1, SCALE, S ) 11386 CALL DLASSQ( K, A( K ), LDA+1, SCALE, S ) 11387 ELSE 11388 DO J = 0, K - 1 11389 CALL DLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S ) 11390 END DO 11391 DO J = 1, K - 1 11392 CALL DLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) 11393 END DO 11394 S = S + S 11395 CALL DLASSQ( K, A( 1 ), LDA+1, SCALE, S ) 11396 CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) 11397 END IF 11398 ELSE 11399 IF( ILU.EQ.0 ) THEN 11400 DO J = 1, K - 1 11401 CALL DLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S ) 11402 END DO 11403 DO J = 0, K - 1 11404 CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 11405 END DO 11406 DO J = 0, K - 2 11407 CALL DLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE, 11408 $ S ) 11409 END DO 11410 S = S + S 11411 CALL DLASSQ( K, A( 0+( K+1 )*LDA ), LDA+1, SCALE, S ) 11412 CALL DLASSQ( K, A( 0+K*LDA ), LDA+1, SCALE, S ) 11413 ELSE 11414 DO J = 1, K - 1 11415 CALL DLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S ) 11416 END DO 11417 DO J = K + 1, N 11418 CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 11419 END DO 11420 DO J = 0, K - 2 11421 CALL DLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S ) 11422 END DO 11423 S = S + S 11424 CALL DLASSQ( K, A( LDA ), LDA+1, SCALE, S ) 11425 CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) 11426 END IF 11427 END IF 11428 END IF 11429 VALUE = SCALE*SQRT( S ) 11430 END IF 11431 DLANSF = VALUE 11432 RETURN 11433 END 11434! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlansp.f 11435 DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) 11436 IMPLICIT NONE 11437 CHARACTER NORM, UPLO 11438 INTEGER N 11439 DOUBLE PRECISION AP( * ), WORK( * ) 11440 DOUBLE PRECISION ONE, ZERO 11441 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 11442 INTEGER I, J, K 11443 DOUBLE PRECISION ABSA, SUM, VALUE 11444 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 11445 LOGICAL LSAME, DISNAN 11446 EXTERNAL LSAME, DISNAN 11447 EXTERNAL DLASSQ, DCOMBSSQ 11448 INTRINSIC ABS, SQRT 11449 IF( N.EQ.0 ) THEN 11450 VALUE = ZERO 11451 ELSE IF( LSAME( NORM, 'M' ) ) THEN 11452 VALUE = ZERO 11453 IF( LSAME( UPLO, 'U' ) ) THEN 11454 K = 1 11455 DO 20 J = 1, N 11456 DO 10 I = K, K + J - 1 11457 SUM = ABS( AP( I ) ) 11458 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11459 10 CONTINUE 11460 K = K + J 11461 20 CONTINUE 11462 ELSE 11463 K = 1 11464 DO 40 J = 1, N 11465 DO 30 I = K, K + N - J 11466 SUM = ABS( AP( I ) ) 11467 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11468 30 CONTINUE 11469 K = K + N - J + 1 11470 40 CONTINUE 11471 END IF 11472 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 11473 $ ( NORM.EQ.'1' ) ) THEN 11474 VALUE = ZERO 11475 K = 1 11476 IF( LSAME( UPLO, 'U' ) ) THEN 11477 DO 60 J = 1, N 11478 SUM = ZERO 11479 DO 50 I = 1, J - 1 11480 ABSA = ABS( AP( K ) ) 11481 SUM = SUM + ABSA 11482 WORK( I ) = WORK( I ) + ABSA 11483 K = K + 1 11484 50 CONTINUE 11485 WORK( J ) = SUM + ABS( AP( K ) ) 11486 K = K + 1 11487 60 CONTINUE 11488 DO 70 I = 1, N 11489 SUM = WORK( I ) 11490 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11491 70 CONTINUE 11492 ELSE 11493 DO 80 I = 1, N 11494 WORK( I ) = ZERO 11495 80 CONTINUE 11496 DO 100 J = 1, N 11497 SUM = WORK( J ) + ABS( AP( K ) ) 11498 K = K + 1 11499 DO 90 I = J + 1, N 11500 ABSA = ABS( AP( K ) ) 11501 SUM = SUM + ABSA 11502 WORK( I ) = WORK( I ) + ABSA 11503 K = K + 1 11504 90 CONTINUE 11505 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11506 100 CONTINUE 11507 END IF 11508 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 11509 SSQ( 1 ) = ZERO 11510 SSQ( 2 ) = ONE 11511 K = 2 11512 IF( LSAME( UPLO, 'U' ) ) THEN 11513 DO 110 J = 2, N 11514 COLSSQ( 1 ) = ZERO 11515 COLSSQ( 2 ) = ONE 11516 CALL DLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 11517 CALL DCOMBSSQ( SSQ, COLSSQ ) 11518 K = K + J 11519 110 CONTINUE 11520 ELSE 11521 DO 120 J = 1, N - 1 11522 COLSSQ( 1 ) = ZERO 11523 COLSSQ( 2 ) = ONE 11524 CALL DLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 11525 CALL DCOMBSSQ( SSQ, COLSSQ ) 11526 K = K + N - J + 1 11527 120 CONTINUE 11528 END IF 11529 SSQ( 2 ) = 2*SSQ( 2 ) 11530 K = 1 11531 COLSSQ( 1 ) = ZERO 11532 COLSSQ( 2 ) = ONE 11533 DO 130 I = 1, N 11534 IF( AP( K ).NE.ZERO ) THEN 11535 ABSA = ABS( AP( K ) ) 11536 IF( COLSSQ( 1 ).LT.ABSA ) THEN 11537 COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 11538 COLSSQ( 1 ) = ABSA 11539 ELSE 11540 COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 11541 END IF 11542 END IF 11543 IF( LSAME( UPLO, 'U' ) ) THEN 11544 K = K + I + 1 11545 ELSE 11546 K = K + N - I + 1 11547 END IF 11548 130 CONTINUE 11549 CALL DCOMBSSQ( SSQ, COLSSQ ) 11550 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 11551 END IF 11552 DLANSP = VALUE 11553 RETURN 11554 END 11555! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlanst.f 11556 DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) 11557 CHARACTER NORM 11558 INTEGER N 11559 DOUBLE PRECISION D( * ), E( * ) 11560 DOUBLE PRECISION ONE, ZERO 11561 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 11562 INTEGER I 11563 DOUBLE PRECISION ANORM, SCALE, SUM 11564 LOGICAL LSAME, DISNAN 11565 EXTERNAL LSAME, DISNAN 11566 EXTERNAL DLASSQ 11567 INTRINSIC ABS, SQRT 11568 IF( N.LE.0 ) THEN 11569 ANORM = ZERO 11570 ELSE IF( LSAME( NORM, 'M' ) ) THEN 11571 ANORM = ABS( D( N ) ) 11572 DO 10 I = 1, N - 1 11573 SUM = ABS( D( I ) ) 11574 IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 11575 SUM = ABS( E( I ) ) 11576 IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 11577 10 CONTINUE 11578 ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. 11579 $ LSAME( NORM, 'I' ) ) THEN 11580 IF( N.EQ.1 ) THEN 11581 ANORM = ABS( D( 1 ) ) 11582 ELSE 11583 ANORM = ABS( D( 1 ) )+ABS( E( 1 ) ) 11584 SUM = ABS( E( N-1 ) )+ABS( D( N ) ) 11585 IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 11586 DO 20 I = 2, N - 1 11587 SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) ) 11588 IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 11589 20 CONTINUE 11590 END IF 11591 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 11592 SCALE = ZERO 11593 SUM = ONE 11594 IF( N.GT.1 ) THEN 11595 CALL DLASSQ( N-1, E, 1, SCALE, SUM ) 11596 SUM = 2*SUM 11597 END IF 11598 CALL DLASSQ( N, D, 1, SCALE, SUM ) 11599 ANORM = SCALE*SQRT( SUM ) 11600 END IF 11601 DLANST = ANORM 11602 RETURN 11603 END 11604! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlansy.f 11605 DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) 11606 IMPLICIT NONE 11607 CHARACTER NORM, UPLO 11608 INTEGER LDA, N 11609 DOUBLE PRECISION A( LDA, * ), WORK( * ) 11610 DOUBLE PRECISION ONE, ZERO 11611 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 11612 INTEGER I, J 11613 DOUBLE PRECISION ABSA, SUM, VALUE 11614 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 11615 LOGICAL LSAME, DISNAN 11616 EXTERNAL LSAME, DISNAN 11617 EXTERNAL DLASSQ, DCOMBSSQ 11618 INTRINSIC ABS, SQRT 11619 IF( N.EQ.0 ) THEN 11620 VALUE = ZERO 11621 ELSE IF( LSAME( NORM, 'M' ) ) THEN 11622 VALUE = ZERO 11623 IF( LSAME( UPLO, 'U' ) ) THEN 11624 DO 20 J = 1, N 11625 DO 10 I = 1, J 11626 SUM = ABS( A( I, J ) ) 11627 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11628 10 CONTINUE 11629 20 CONTINUE 11630 ELSE 11631 DO 40 J = 1, N 11632 DO 30 I = J, N 11633 SUM = ABS( A( I, J ) ) 11634 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11635 30 CONTINUE 11636 40 CONTINUE 11637 END IF 11638 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 11639 $ ( NORM.EQ.'1' ) ) THEN 11640 VALUE = ZERO 11641 IF( LSAME( UPLO, 'U' ) ) THEN 11642 DO 60 J = 1, N 11643 SUM = ZERO 11644 DO 50 I = 1, J - 1 11645 ABSA = ABS( A( I, J ) ) 11646 SUM = SUM + ABSA 11647 WORK( I ) = WORK( I ) + ABSA 11648 50 CONTINUE 11649 WORK( J ) = SUM + ABS( A( J, J ) ) 11650 60 CONTINUE 11651 DO 70 I = 1, N 11652 SUM = WORK( I ) 11653 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11654 70 CONTINUE 11655 ELSE 11656 DO 80 I = 1, N 11657 WORK( I ) = ZERO 11658 80 CONTINUE 11659 DO 100 J = 1, N 11660 SUM = WORK( J ) + ABS( A( J, J ) ) 11661 DO 90 I = J + 1, N 11662 ABSA = ABS( A( I, J ) ) 11663 SUM = SUM + ABSA 11664 WORK( I ) = WORK( I ) + ABSA 11665 90 CONTINUE 11666 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11667 100 CONTINUE 11668 END IF 11669 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 11670 SSQ( 1 ) = ZERO 11671 SSQ( 2 ) = ONE 11672 IF( LSAME( UPLO, 'U' ) ) THEN 11673 DO 110 J = 2, N 11674 COLSSQ( 1 ) = ZERO 11675 COLSSQ( 2 ) = ONE 11676 CALL DLASSQ( J-1, A( 1, J ), 1, COLSSQ(1), COLSSQ(2) ) 11677 CALL DCOMBSSQ( SSQ, COLSSQ ) 11678 110 CONTINUE 11679 ELSE 11680 DO 120 J = 1, N - 1 11681 COLSSQ( 1 ) = ZERO 11682 COLSSQ( 2 ) = ONE 11683 CALL DLASSQ( N-J, A( J+1, J ), 1, COLSSQ(1), COLSSQ(2) ) 11684 CALL DCOMBSSQ( SSQ, COLSSQ ) 11685 120 CONTINUE 11686 END IF 11687 SSQ( 2 ) = 2*SSQ( 2 ) 11688 COLSSQ( 1 ) = ZERO 11689 COLSSQ( 2 ) = ONE 11690 CALL DLASSQ( N, A, LDA+1, COLSSQ( 1 ), COLSSQ( 2 ) ) 11691 CALL DCOMBSSQ( SSQ, COLSSQ ) 11692 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 11693 END IF 11694 DLANSY = VALUE 11695 RETURN 11696 END 11697! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlantb.f 11698 DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, 11699 $ LDAB, WORK ) 11700 IMPLICIT NONE 11701 CHARACTER DIAG, NORM, UPLO 11702 INTEGER K, LDAB, N 11703 DOUBLE PRECISION AB( LDAB, * ), WORK( * ) 11704 DOUBLE PRECISION ONE, ZERO 11705 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 11706 LOGICAL UDIAG 11707 INTEGER I, J, L 11708 DOUBLE PRECISION SUM, VALUE 11709 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 11710 LOGICAL LSAME, DISNAN 11711 EXTERNAL LSAME, DISNAN 11712 EXTERNAL DLASSQ, DCOMBSSQ 11713 INTRINSIC ABS, MAX, MIN, SQRT 11714 IF( N.EQ.0 ) THEN 11715 VALUE = ZERO 11716 ELSE IF( LSAME( NORM, 'M' ) ) THEN 11717 IF( LSAME( DIAG, 'U' ) ) THEN 11718 VALUE = ONE 11719 IF( LSAME( UPLO, 'U' ) ) THEN 11720 DO 20 J = 1, N 11721 DO 10 I = MAX( K+2-J, 1 ), K 11722 SUM = ABS( AB( I, J ) ) 11723 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11724 10 CONTINUE 11725 20 CONTINUE 11726 ELSE 11727 DO 40 J = 1, N 11728 DO 30 I = 2, MIN( N+1-J, K+1 ) 11729 SUM = ABS( AB( I, J ) ) 11730 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11731 30 CONTINUE 11732 40 CONTINUE 11733 END IF 11734 ELSE 11735 VALUE = ZERO 11736 IF( LSAME( UPLO, 'U' ) ) THEN 11737 DO 60 J = 1, N 11738 DO 50 I = MAX( K+2-J, 1 ), K + 1 11739 SUM = ABS( AB( I, J ) ) 11740 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11741 50 CONTINUE 11742 60 CONTINUE 11743 ELSE 11744 DO 80 J = 1, N 11745 DO 70 I = 1, MIN( N+1-J, K+1 ) 11746 SUM = ABS( AB( I, J ) ) 11747 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11748 70 CONTINUE 11749 80 CONTINUE 11750 END IF 11751 END IF 11752 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 11753 VALUE = ZERO 11754 UDIAG = LSAME( DIAG, 'U' ) 11755 IF( LSAME( UPLO, 'U' ) ) THEN 11756 DO 110 J = 1, N 11757 IF( UDIAG ) THEN 11758 SUM = ONE 11759 DO 90 I = MAX( K+2-J, 1 ), K 11760 SUM = SUM + ABS( AB( I, J ) ) 11761 90 CONTINUE 11762 ELSE 11763 SUM = ZERO 11764 DO 100 I = MAX( K+2-J, 1 ), K + 1 11765 SUM = SUM + ABS( AB( I, J ) ) 11766 100 CONTINUE 11767 END IF 11768 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11769 110 CONTINUE 11770 ELSE 11771 DO 140 J = 1, N 11772 IF( UDIAG ) THEN 11773 SUM = ONE 11774 DO 120 I = 2, MIN( N+1-J, K+1 ) 11775 SUM = SUM + ABS( AB( I, J ) ) 11776 120 CONTINUE 11777 ELSE 11778 SUM = ZERO 11779 DO 130 I = 1, MIN( N+1-J, K+1 ) 11780 SUM = SUM + ABS( AB( I, J ) ) 11781 130 CONTINUE 11782 END IF 11783 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11784 140 CONTINUE 11785 END IF 11786 ELSE IF( LSAME( NORM, 'I' ) ) THEN 11787 VALUE = ZERO 11788 IF( LSAME( UPLO, 'U' ) ) THEN 11789 IF( LSAME( DIAG, 'U' ) ) THEN 11790 DO 150 I = 1, N 11791 WORK( I ) = ONE 11792 150 CONTINUE 11793 DO 170 J = 1, N 11794 L = K + 1 - J 11795 DO 160 I = MAX( 1, J-K ), J - 1 11796 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 11797 160 CONTINUE 11798 170 CONTINUE 11799 ELSE 11800 DO 180 I = 1, N 11801 WORK( I ) = ZERO 11802 180 CONTINUE 11803 DO 200 J = 1, N 11804 L = K + 1 - J 11805 DO 190 I = MAX( 1, J-K ), J 11806 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 11807 190 CONTINUE 11808 200 CONTINUE 11809 END IF 11810 ELSE 11811 IF( LSAME( DIAG, 'U' ) ) THEN 11812 DO 210 I = 1, N 11813 WORK( I ) = ONE 11814 210 CONTINUE 11815 DO 230 J = 1, N 11816 L = 1 - J 11817 DO 220 I = J + 1, MIN( N, J+K ) 11818 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 11819 220 CONTINUE 11820 230 CONTINUE 11821 ELSE 11822 DO 240 I = 1, N 11823 WORK( I ) = ZERO 11824 240 CONTINUE 11825 DO 260 J = 1, N 11826 L = 1 - J 11827 DO 250 I = J, MIN( N, J+K ) 11828 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 11829 250 CONTINUE 11830 260 CONTINUE 11831 END IF 11832 END IF 11833 DO 270 I = 1, N 11834 SUM = WORK( I ) 11835 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11836 270 CONTINUE 11837 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 11838 IF( LSAME( UPLO, 'U' ) ) THEN 11839 IF( LSAME( DIAG, 'U' ) ) THEN 11840 SSQ( 1 ) = ONE 11841 SSQ( 2 ) = N 11842 IF( K.GT.0 ) THEN 11843 DO 280 J = 2, N 11844 COLSSQ( 1 ) = ZERO 11845 COLSSQ( 2 ) = ONE 11846 CALL DLASSQ( MIN( J-1, K ), 11847 $ AB( MAX( K+2-J, 1 ), J ), 1, 11848 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 11849 CALL DCOMBSSQ( SSQ, COLSSQ ) 11850 280 CONTINUE 11851 END IF 11852 ELSE 11853 SSQ( 1 ) = ZERO 11854 SSQ( 2 ) = ONE 11855 DO 290 J = 1, N 11856 COLSSQ( 1 ) = ZERO 11857 COLSSQ( 2 ) = ONE 11858 CALL DLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), 11859 $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 11860 CALL DCOMBSSQ( SSQ, COLSSQ ) 11861 290 CONTINUE 11862 END IF 11863 ELSE 11864 IF( LSAME( DIAG, 'U' ) ) THEN 11865 SSQ( 1 ) = ONE 11866 SSQ( 2 ) = N 11867 IF( K.GT.0 ) THEN 11868 DO 300 J = 1, N - 1 11869 COLSSQ( 1 ) = ZERO 11870 COLSSQ( 2 ) = ONE 11871 CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, 11872 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 11873 CALL DCOMBSSQ( SSQ, COLSSQ ) 11874 300 CONTINUE 11875 END IF 11876 ELSE 11877 SSQ( 1 ) = ZERO 11878 SSQ( 2 ) = ONE 11879 DO 310 J = 1, N 11880 COLSSQ( 1 ) = ZERO 11881 COLSSQ( 2 ) = ONE 11882 CALL DLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, 11883 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 11884 CALL DCOMBSSQ( SSQ, COLSSQ ) 11885 310 CONTINUE 11886 END IF 11887 END IF 11888 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 11889 END IF 11890 DLANTB = VALUE 11891 RETURN 11892 END 11893! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlantp.f 11894 DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) 11895 IMPLICIT NONE 11896 CHARACTER DIAG, NORM, UPLO 11897 INTEGER N 11898 DOUBLE PRECISION AP( * ), WORK( * ) 11899 DOUBLE PRECISION ONE, ZERO 11900 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 11901 LOGICAL UDIAG 11902 INTEGER I, J, K 11903 DOUBLE PRECISION SUM, VALUE 11904 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 11905 LOGICAL LSAME, DISNAN 11906 EXTERNAL LSAME, DISNAN 11907 EXTERNAL DLASSQ, DCOMBSSQ 11908 INTRINSIC ABS, SQRT 11909 IF( N.EQ.0 ) THEN 11910 VALUE = ZERO 11911 ELSE IF( LSAME( NORM, 'M' ) ) THEN 11912 K = 1 11913 IF( LSAME( DIAG, 'U' ) ) THEN 11914 VALUE = ONE 11915 IF( LSAME( UPLO, 'U' ) ) THEN 11916 DO 20 J = 1, N 11917 DO 10 I = K, K + J - 2 11918 SUM = ABS( AP( I ) ) 11919 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11920 10 CONTINUE 11921 K = K + J 11922 20 CONTINUE 11923 ELSE 11924 DO 40 J = 1, N 11925 DO 30 I = K + 1, K + N - J 11926 SUM = ABS( AP( I ) ) 11927 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11928 30 CONTINUE 11929 K = K + N - J + 1 11930 40 CONTINUE 11931 END IF 11932 ELSE 11933 VALUE = ZERO 11934 IF( LSAME( UPLO, 'U' ) ) THEN 11935 DO 60 J = 1, N 11936 DO 50 I = K, K + J - 1 11937 SUM = ABS( AP( I ) ) 11938 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11939 50 CONTINUE 11940 K = K + J 11941 60 CONTINUE 11942 ELSE 11943 DO 80 J = 1, N 11944 DO 70 I = K, K + N - J 11945 SUM = ABS( AP( I ) ) 11946 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11947 70 CONTINUE 11948 K = K + N - J + 1 11949 80 CONTINUE 11950 END IF 11951 END IF 11952 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 11953 VALUE = ZERO 11954 K = 1 11955 UDIAG = LSAME( DIAG, 'U' ) 11956 IF( LSAME( UPLO, 'U' ) ) THEN 11957 DO 110 J = 1, N 11958 IF( UDIAG ) THEN 11959 SUM = ONE 11960 DO 90 I = K, K + J - 2 11961 SUM = SUM + ABS( AP( I ) ) 11962 90 CONTINUE 11963 ELSE 11964 SUM = ZERO 11965 DO 100 I = K, K + J - 1 11966 SUM = SUM + ABS( AP( I ) ) 11967 100 CONTINUE 11968 END IF 11969 K = K + J 11970 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11971 110 CONTINUE 11972 ELSE 11973 DO 140 J = 1, N 11974 IF( UDIAG ) THEN 11975 SUM = ONE 11976 DO 120 I = K + 1, K + N - J 11977 SUM = SUM + ABS( AP( I ) ) 11978 120 CONTINUE 11979 ELSE 11980 SUM = ZERO 11981 DO 130 I = K, K + N - J 11982 SUM = SUM + ABS( AP( I ) ) 11983 130 CONTINUE 11984 END IF 11985 K = K + N - J + 1 11986 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 11987 140 CONTINUE 11988 END IF 11989 ELSE IF( LSAME( NORM, 'I' ) ) THEN 11990 K = 1 11991 IF( LSAME( UPLO, 'U' ) ) THEN 11992 IF( LSAME( DIAG, 'U' ) ) THEN 11993 DO 150 I = 1, N 11994 WORK( I ) = ONE 11995 150 CONTINUE 11996 DO 170 J = 1, N 11997 DO 160 I = 1, J - 1 11998 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 11999 K = K + 1 12000 160 CONTINUE 12001 K = K + 1 12002 170 CONTINUE 12003 ELSE 12004 DO 180 I = 1, N 12005 WORK( I ) = ZERO 12006 180 CONTINUE 12007 DO 200 J = 1, N 12008 DO 190 I = 1, J 12009 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 12010 K = K + 1 12011 190 CONTINUE 12012 200 CONTINUE 12013 END IF 12014 ELSE 12015 IF( LSAME( DIAG, 'U' ) ) THEN 12016 DO 210 I = 1, N 12017 WORK( I ) = ONE 12018 210 CONTINUE 12019 DO 230 J = 1, N 12020 K = K + 1 12021 DO 220 I = J + 1, N 12022 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 12023 K = K + 1 12024 220 CONTINUE 12025 230 CONTINUE 12026 ELSE 12027 DO 240 I = 1, N 12028 WORK( I ) = ZERO 12029 240 CONTINUE 12030 DO 260 J = 1, N 12031 DO 250 I = J, N 12032 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 12033 K = K + 1 12034 250 CONTINUE 12035 260 CONTINUE 12036 END IF 12037 END IF 12038 VALUE = ZERO 12039 DO 270 I = 1, N 12040 SUM = WORK( I ) 12041 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 12042 270 CONTINUE 12043 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 12044 IF( LSAME( UPLO, 'U' ) ) THEN 12045 IF( LSAME( DIAG, 'U' ) ) THEN 12046 SSQ( 1 ) = ONE 12047 SSQ( 2 ) = N 12048 K = 2 12049 DO 280 J = 2, N 12050 COLSSQ( 1 ) = ZERO 12051 COLSSQ( 2 ) = ONE 12052 CALL DLASSQ( J-1, AP( K ), 1, 12053 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 12054 CALL DCOMBSSQ( SSQ, COLSSQ ) 12055 K = K + J 12056 280 CONTINUE 12057 ELSE 12058 SSQ( 1 ) = ZERO 12059 SSQ( 2 ) = ONE 12060 K = 1 12061 DO 290 J = 1, N 12062 COLSSQ( 1 ) = ZERO 12063 COLSSQ( 2 ) = ONE 12064 CALL DLASSQ( J, AP( K ), 1, 12065 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 12066 CALL DCOMBSSQ( SSQ, COLSSQ ) 12067 K = K + J 12068 290 CONTINUE 12069 END IF 12070 ELSE 12071 IF( LSAME( DIAG, 'U' ) ) THEN 12072 SSQ( 1 ) = ONE 12073 SSQ( 2 ) = N 12074 K = 2 12075 DO 300 J = 1, N - 1 12076 COLSSQ( 1 ) = ZERO 12077 COLSSQ( 2 ) = ONE 12078 CALL DLASSQ( N-J, AP( K ), 1, 12079 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 12080 CALL DCOMBSSQ( SSQ, COLSSQ ) 12081 K = K + N - J + 1 12082 300 CONTINUE 12083 ELSE 12084 SSQ( 1 ) = ZERO 12085 SSQ( 2 ) = ONE 12086 K = 1 12087 DO 310 J = 1, N 12088 COLSSQ( 1 ) = ZERO 12089 COLSSQ( 2 ) = ONE 12090 CALL DLASSQ( N-J+1, AP( K ), 1, 12091 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 12092 CALL DCOMBSSQ( SSQ, COLSSQ ) 12093 K = K + N - J + 1 12094 310 CONTINUE 12095 END IF 12096 END IF 12097 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 12098 END IF 12099 DLANTP = VALUE 12100 RETURN 12101 END 12102! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlantr.f 12103 DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, 12104 $ WORK ) 12105 IMPLICIT NONE 12106 CHARACTER DIAG, NORM, UPLO 12107 INTEGER LDA, M, N 12108 DOUBLE PRECISION A( LDA, * ), WORK( * ) 12109 DOUBLE PRECISION ONE, ZERO 12110 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 12111 LOGICAL UDIAG 12112 INTEGER I, J 12113 DOUBLE PRECISION SUM, VALUE 12114 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 12115 LOGICAL LSAME, DISNAN 12116 EXTERNAL LSAME, DISNAN 12117 EXTERNAL DLASSQ, DCOMBSSQ 12118 INTRINSIC ABS, MIN, SQRT 12119 IF( MIN( M, N ).EQ.0 ) THEN 12120 VALUE = ZERO 12121 ELSE IF( LSAME( NORM, 'M' ) ) THEN 12122 IF( LSAME( DIAG, 'U' ) ) THEN 12123 VALUE = ONE 12124 IF( LSAME( UPLO, 'U' ) ) THEN 12125 DO 20 J = 1, N 12126 DO 10 I = 1, MIN( M, J-1 ) 12127 SUM = ABS( A( I, J ) ) 12128 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 12129 10 CONTINUE 12130 20 CONTINUE 12131 ELSE 12132 DO 40 J = 1, N 12133 DO 30 I = J + 1, M 12134 SUM = ABS( A( I, J ) ) 12135 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 12136 30 CONTINUE 12137 40 CONTINUE 12138 END IF 12139 ELSE 12140 VALUE = ZERO 12141 IF( LSAME( UPLO, 'U' ) ) THEN 12142 DO 60 J = 1, N 12143 DO 50 I = 1, MIN( M, J ) 12144 SUM = ABS( A( I, J ) ) 12145 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 12146 50 CONTINUE 12147 60 CONTINUE 12148 ELSE 12149 DO 80 J = 1, N 12150 DO 70 I = J, M 12151 SUM = ABS( A( I, J ) ) 12152 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 12153 70 CONTINUE 12154 80 CONTINUE 12155 END IF 12156 END IF 12157 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 12158 VALUE = ZERO 12159 UDIAG = LSAME( DIAG, 'U' ) 12160 IF( LSAME( UPLO, 'U' ) ) THEN 12161 DO 110 J = 1, N 12162 IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN 12163 SUM = ONE 12164 DO 90 I = 1, J - 1 12165 SUM = SUM + ABS( A( I, J ) ) 12166 90 CONTINUE 12167 ELSE 12168 SUM = ZERO 12169 DO 100 I = 1, MIN( M, J ) 12170 SUM = SUM + ABS( A( I, J ) ) 12171 100 CONTINUE 12172 END IF 12173 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 12174 110 CONTINUE 12175 ELSE 12176 DO 140 J = 1, N 12177 IF( UDIAG ) THEN 12178 SUM = ONE 12179 DO 120 I = J + 1, M 12180 SUM = SUM + ABS( A( I, J ) ) 12181 120 CONTINUE 12182 ELSE 12183 SUM = ZERO 12184 DO 130 I = J, M 12185 SUM = SUM + ABS( A( I, J ) ) 12186 130 CONTINUE 12187 END IF 12188 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 12189 140 CONTINUE 12190 END IF 12191 ELSE IF( LSAME( NORM, 'I' ) ) THEN 12192 IF( LSAME( UPLO, 'U' ) ) THEN 12193 IF( LSAME( DIAG, 'U' ) ) THEN 12194 DO 150 I = 1, M 12195 WORK( I ) = ONE 12196 150 CONTINUE 12197 DO 170 J = 1, N 12198 DO 160 I = 1, MIN( M, J-1 ) 12199 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 12200 160 CONTINUE 12201 170 CONTINUE 12202 ELSE 12203 DO 180 I = 1, M 12204 WORK( I ) = ZERO 12205 180 CONTINUE 12206 DO 200 J = 1, N 12207 DO 190 I = 1, MIN( M, J ) 12208 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 12209 190 CONTINUE 12210 200 CONTINUE 12211 END IF 12212 ELSE 12213 IF( LSAME( DIAG, 'U' ) ) THEN 12214 DO 210 I = 1, MIN( M, N ) 12215 WORK( I ) = ONE 12216 210 CONTINUE 12217 DO 220 I = N + 1, M 12218 WORK( I ) = ZERO 12219 220 CONTINUE 12220 DO 240 J = 1, N 12221 DO 230 I = J + 1, M 12222 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 12223 230 CONTINUE 12224 240 CONTINUE 12225 ELSE 12226 DO 250 I = 1, M 12227 WORK( I ) = ZERO 12228 250 CONTINUE 12229 DO 270 J = 1, N 12230 DO 260 I = J, M 12231 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 12232 260 CONTINUE 12233 270 CONTINUE 12234 END IF 12235 END IF 12236 VALUE = ZERO 12237 DO 280 I = 1, M 12238 SUM = WORK( I ) 12239 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 12240 280 CONTINUE 12241 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 12242 IF( LSAME( UPLO, 'U' ) ) THEN 12243 IF( LSAME( DIAG, 'U' ) ) THEN 12244 SSQ( 1 ) = ONE 12245 SSQ( 2 ) = MIN( M, N ) 12246 DO 290 J = 2, N 12247 COLSSQ( 1 ) = ZERO 12248 COLSSQ( 2 ) = ONE 12249 CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, 12250 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 12251 CALL DCOMBSSQ( SSQ, COLSSQ ) 12252 290 CONTINUE 12253 ELSE 12254 SSQ( 1 ) = ZERO 12255 SSQ( 2 ) = ONE 12256 DO 300 J = 1, N 12257 COLSSQ( 1 ) = ZERO 12258 COLSSQ( 2 ) = ONE 12259 CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, 12260 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 12261 CALL DCOMBSSQ( SSQ, COLSSQ ) 12262 300 CONTINUE 12263 END IF 12264 ELSE 12265 IF( LSAME( DIAG, 'U' ) ) THEN 12266 SSQ( 1 ) = ONE 12267 SSQ( 2 ) = MIN( M, N ) 12268 DO 310 J = 1, N 12269 COLSSQ( 1 ) = ZERO 12270 COLSSQ( 2 ) = ONE 12271 CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, 12272 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 12273 CALL DCOMBSSQ( SSQ, COLSSQ ) 12274 310 CONTINUE 12275 ELSE 12276 SSQ( 1 ) = ZERO 12277 SSQ( 2 ) = ONE 12278 DO 320 J = 1, N 12279 COLSSQ( 1 ) = ZERO 12280 COLSSQ( 2 ) = ONE 12281 CALL DLASSQ( M-J+1, A( J, J ), 1, 12282 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 12283 CALL DCOMBSSQ( SSQ, COLSSQ ) 12284 320 CONTINUE 12285 END IF 12286 END IF 12287 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 12288 END IF 12289 DLANTR = VALUE 12290 RETURN 12291 END 12292! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlapy2.f 12293 DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) 12294 DOUBLE PRECISION X, Y 12295 DOUBLE PRECISION ZERO 12296 PARAMETER ( ZERO = 0.0D0 ) 12297 DOUBLE PRECISION ONE 12298 PARAMETER ( ONE = 1.0D0 ) 12299 DOUBLE PRECISION W, XABS, YABS, Z 12300 LOGICAL X_IS_NAN, Y_IS_NAN 12301 LOGICAL DISNAN 12302 EXTERNAL DISNAN 12303 INTRINSIC ABS, MAX, MIN, SQRT 12304 X_IS_NAN = DISNAN( X ) 12305 Y_IS_NAN = DISNAN( Y ) 12306 IF ( X_IS_NAN ) DLAPY2 = X 12307 IF ( Y_IS_NAN ) DLAPY2 = Y 12308 IF ( .NOT.( X_IS_NAN.OR.Y_IS_NAN ) ) THEN 12309 XABS = ABS( X ) 12310 YABS = ABS( Y ) 12311 W = MAX( XABS, YABS ) 12312 Z = MIN( XABS, YABS ) 12313 IF( Z.EQ.ZERO ) THEN 12314 DLAPY2 = W 12315 ELSE 12316 DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) 12317 END IF 12318 END IF 12319 RETURN 12320 END 12321! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlapy3.f 12322 DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) 12323 DOUBLE PRECISION X, Y, Z 12324 DOUBLE PRECISION ZERO 12325 PARAMETER ( ZERO = 0.0D0 ) 12326 DOUBLE PRECISION W, XABS, YABS, ZABS 12327 INTRINSIC ABS, MAX, SQRT 12328 XABS = ABS( X ) 12329 YABS = ABS( Y ) 12330 ZABS = ABS( Z ) 12331 W = MAX( XABS, YABS, ZABS ) 12332 IF( W.EQ.ZERO ) THEN 12333 DLAPY3 = XABS + YABS + ZABS 12334 ELSE 12335 DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ 12336 $ ( ZABS / W )**2 ) 12337 END IF 12338 RETURN 12339 END 12340! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlar1v.f 12341 SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, 12342 $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, 12343 $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) 12344 LOGICAL WANTNC 12345 INTEGER B1, BN, N, NEGCNT, R 12346 DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID, 12347 $ RQCORR, ZTZ 12348 INTEGER ISUPPZ( * ) 12349 DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ), 12350 $ WORK( * ) 12351 DOUBLE PRECISION Z( * ) 12352 DOUBLE PRECISION ZERO, ONE 12353 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 12354 LOGICAL SAWNAN1, SAWNAN2 12355 INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1, 12356 $ R2 12357 DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP 12358 LOGICAL DISNAN 12359 DOUBLE PRECISION DLAMCH 12360 EXTERNAL DISNAN, DLAMCH 12361 INTRINSIC ABS 12362 EPS = DLAMCH( 'Precision' ) 12363 IF( R.EQ.0 ) THEN 12364 R1 = B1 12365 R2 = BN 12366 ELSE 12367 R1 = R 12368 R2 = R 12369 END IF 12370 INDLPL = 0 12371 INDUMN = N 12372 INDS = 2*N + 1 12373 INDP = 3*N + 1 12374 IF( B1.EQ.1 ) THEN 12375 WORK( INDS ) = ZERO 12376 ELSE 12377 WORK( INDS+B1-1 ) = LLD( B1-1 ) 12378 END IF 12379 SAWNAN1 = .FALSE. 12380 NEG1 = 0 12381 S = WORK( INDS+B1-1 ) - LAMBDA 12382 DO 50 I = B1, R1 - 1 12383 DPLUS = D( I ) + S 12384 WORK( INDLPL+I ) = LD( I ) / DPLUS 12385 IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1 12386 WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) 12387 S = WORK( INDS+I ) - LAMBDA 12388 50 CONTINUE 12389 SAWNAN1 = DISNAN( S ) 12390 IF( SAWNAN1 ) GOTO 60 12391 DO 51 I = R1, R2 - 1 12392 DPLUS = D( I ) + S 12393 WORK( INDLPL+I ) = LD( I ) / DPLUS 12394 WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) 12395 S = WORK( INDS+I ) - LAMBDA 12396 51 CONTINUE 12397 SAWNAN1 = DISNAN( S ) 12398 60 CONTINUE 12399 IF( SAWNAN1 ) THEN 12400 NEG1 = 0 12401 S = WORK( INDS+B1-1 ) - LAMBDA 12402 DO 70 I = B1, R1 - 1 12403 DPLUS = D( I ) + S 12404 IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN 12405 WORK( INDLPL+I ) = LD( I ) / DPLUS 12406 IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1 12407 WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) 12408 IF( WORK( INDLPL+I ).EQ.ZERO ) 12409 $ WORK( INDS+I ) = LLD( I ) 12410 S = WORK( INDS+I ) - LAMBDA 12411 70 CONTINUE 12412 DO 71 I = R1, R2 - 1 12413 DPLUS = D( I ) + S 12414 IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN 12415 WORK( INDLPL+I ) = LD( I ) / DPLUS 12416 WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) 12417 IF( WORK( INDLPL+I ).EQ.ZERO ) 12418 $ WORK( INDS+I ) = LLD( I ) 12419 S = WORK( INDS+I ) - LAMBDA 12420 71 CONTINUE 12421 END IF 12422 SAWNAN2 = .FALSE. 12423 NEG2 = 0 12424 WORK( INDP+BN-1 ) = D( BN ) - LAMBDA 12425 DO 80 I = BN - 1, R1, -1 12426 DMINUS = LLD( I ) + WORK( INDP+I ) 12427 TMP = D( I ) / DMINUS 12428 IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1 12429 WORK( INDUMN+I ) = L( I )*TMP 12430 WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA 12431 80 CONTINUE 12432 TMP = WORK( INDP+R1-1 ) 12433 SAWNAN2 = DISNAN( TMP ) 12434 IF( SAWNAN2 ) THEN 12435 NEG2 = 0 12436 DO 100 I = BN-1, R1, -1 12437 DMINUS = LLD( I ) + WORK( INDP+I ) 12438 IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN 12439 TMP = D( I ) / DMINUS 12440 IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1 12441 WORK( INDUMN+I ) = L( I )*TMP 12442 WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA 12443 IF( TMP.EQ.ZERO ) 12444 $ WORK( INDP+I-1 ) = D( I ) - LAMBDA 12445 100 CONTINUE 12446 END IF 12447 MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 ) 12448 IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1 12449 IF( WANTNC ) THEN 12450 NEGCNT = NEG1 + NEG2 12451 ELSE 12452 NEGCNT = -1 12453 ENDIF 12454 IF( ABS(MINGMA).EQ.ZERO ) 12455 $ MINGMA = EPS*WORK( INDS+R1-1 ) 12456 R = R1 12457 DO 110 I = R1, R2 - 1 12458 TMP = WORK( INDS+I ) + WORK( INDP+I ) 12459 IF( TMP.EQ.ZERO ) 12460 $ TMP = EPS*WORK( INDS+I ) 12461 IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN 12462 MINGMA = TMP 12463 R = I + 1 12464 END IF 12465 110 CONTINUE 12466 ISUPPZ( 1 ) = B1 12467 ISUPPZ( 2 ) = BN 12468 Z( R ) = ONE 12469 ZTZ = ONE 12470 IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN 12471 DO 210 I = R-1, B1, -1 12472 Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) ) 12473 IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) 12474 $ THEN 12475 Z( I ) = ZERO 12476 ISUPPZ( 1 ) = I + 1 12477 GOTO 220 12478 ENDIF 12479 ZTZ = ZTZ + Z( I )*Z( I ) 12480 210 CONTINUE 12481 220 CONTINUE 12482 ELSE 12483 DO 230 I = R - 1, B1, -1 12484 IF( Z( I+1 ).EQ.ZERO ) THEN 12485 Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 ) 12486 ELSE 12487 Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) ) 12488 END IF 12489 IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) 12490 $ THEN 12491 Z( I ) = ZERO 12492 ISUPPZ( 1 ) = I + 1 12493 GO TO 240 12494 END IF 12495 ZTZ = ZTZ + Z( I )*Z( I ) 12496 230 CONTINUE 12497 240 CONTINUE 12498 ENDIF 12499 IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN 12500 DO 250 I = R, BN-1 12501 Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) ) 12502 IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) 12503 $ THEN 12504 Z( I+1 ) = ZERO 12505 ISUPPZ( 2 ) = I 12506 GO TO 260 12507 END IF 12508 ZTZ = ZTZ + Z( I+1 )*Z( I+1 ) 12509 250 CONTINUE 12510 260 CONTINUE 12511 ELSE 12512 DO 270 I = R, BN - 1 12513 IF( Z( I ).EQ.ZERO ) THEN 12514 Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 ) 12515 ELSE 12516 Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) ) 12517 END IF 12518 IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) 12519 $ THEN 12520 Z( I+1 ) = ZERO 12521 ISUPPZ( 2 ) = I 12522 GO TO 280 12523 END IF 12524 ZTZ = ZTZ + Z( I+1 )*Z( I+1 ) 12525 270 CONTINUE 12526 280 CONTINUE 12527 END IF 12528 TMP = ONE / ZTZ 12529 NRMINV = SQRT( TMP ) 12530 RESID = ABS( MINGMA )*NRMINV 12531 RQCORR = MINGMA*TMP 12532 RETURN 12533 END 12534! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarf.f 12535 SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) 12536 CHARACTER SIDE 12537 INTEGER INCV, LDC, M, N 12538 DOUBLE PRECISION TAU 12539 DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) 12540 DOUBLE PRECISION ONE, ZERO 12541 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 12542 LOGICAL APPLYLEFT 12543 INTEGER I, LASTV, LASTC 12544 EXTERNAL DGEMV, DGER 12545 LOGICAL LSAME 12546 INTEGER ILADLR, ILADLC 12547 EXTERNAL LSAME, ILADLR, ILADLC 12548 APPLYLEFT = LSAME( SIDE, 'L' ) 12549 LASTV = 0 12550 LASTC = 0 12551 IF( TAU.NE.ZERO ) THEN 12552 IF( APPLYLEFT ) THEN 12553 LASTV = M 12554 ELSE 12555 LASTV = N 12556 END IF 12557 IF( INCV.GT.0 ) THEN 12558 I = 1 + (LASTV-1) * INCV 12559 ELSE 12560 I = 1 12561 END IF 12562 DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) 12563 LASTV = LASTV - 1 12564 I = I - INCV 12565 END DO 12566 IF( APPLYLEFT ) THEN 12567 LASTC = ILADLC(LASTV, N, C, LDC) 12568 ELSE 12569 LASTC = ILADLR(M, LASTV, C, LDC) 12570 END IF 12571 END IF 12572 IF( APPLYLEFT ) THEN 12573 IF( LASTV.GT.0 ) THEN 12574 CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV, 12575 $ ZERO, WORK, 1 ) 12576 CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) 12577 END IF 12578 ELSE 12579 IF( LASTV.GT.0 ) THEN 12580 CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, 12581 $ V, INCV, ZERO, WORK, 1 ) 12582 CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) 12583 END IF 12584 END IF 12585 RETURN 12586 END 12587! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarfb.f 12588 SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, 12589 $ T, LDT, C, LDC, WORK, LDWORK ) 12590 CHARACTER DIRECT, SIDE, STOREV, TRANS 12591 INTEGER K, LDC, LDT, LDV, LDWORK, M, N 12592 DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), 12593 $ WORK( LDWORK, * ) 12594 DOUBLE PRECISION ONE 12595 PARAMETER ( ONE = 1.0D+0 ) 12596 CHARACTER TRANST 12597 INTEGER I, J 12598 LOGICAL LSAME 12599 EXTERNAL LSAME 12600 EXTERNAL DCOPY, DGEMM, DTRMM 12601 IF( M.LE.0 .OR. N.LE.0 ) 12602 $ RETURN 12603 IF( LSAME( TRANS, 'N' ) ) THEN 12604 TRANST = 'T' 12605 ELSE 12606 TRANST = 'N' 12607 END IF 12608 IF( LSAME( STOREV, 'C' ) ) THEN 12609 IF( LSAME( DIRECT, 'F' ) ) THEN 12610 IF( LSAME( SIDE, 'L' ) ) THEN 12611 DO 10 J = 1, K 12612 CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 12613 10 CONTINUE 12614 CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, 12615 $ K, ONE, V, LDV, WORK, LDWORK ) 12616 IF( M.GT.K ) THEN 12617 CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, 12618 $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, 12619 $ ONE, WORK, LDWORK ) 12620 END IF 12621 CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, 12622 $ ONE, T, LDT, WORK, LDWORK ) 12623 IF( M.GT.K ) THEN 12624 CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, 12625 $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, 12626 $ C( K+1, 1 ), LDC ) 12627 END IF 12628 CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, 12629 $ ONE, V, LDV, WORK, LDWORK ) 12630 DO 30 J = 1, K 12631 DO 20 I = 1, N 12632 C( J, I ) = C( J, I ) - WORK( I, J ) 12633 20 CONTINUE 12634 30 CONTINUE 12635 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 12636 DO 40 J = 1, K 12637 CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 12638 40 CONTINUE 12639 CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, 12640 $ K, ONE, V, LDV, WORK, LDWORK ) 12641 IF( N.GT.K ) THEN 12642 CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, 12643 $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, 12644 $ ONE, WORK, LDWORK ) 12645 END IF 12646 CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, 12647 $ ONE, T, LDT, WORK, LDWORK ) 12648 IF( N.GT.K ) THEN 12649 CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, 12650 $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, 12651 $ C( 1, K+1 ), LDC ) 12652 END IF 12653 CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, 12654 $ ONE, V, LDV, WORK, LDWORK ) 12655 DO 60 J = 1, K 12656 DO 50 I = 1, M 12657 C( I, J ) = C( I, J ) - WORK( I, J ) 12658 50 CONTINUE 12659 60 CONTINUE 12660 END IF 12661 ELSE 12662 IF( LSAME( SIDE, 'L' ) ) THEN 12663 DO 70 J = 1, K 12664 CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 12665 70 CONTINUE 12666 CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, 12667 $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) 12668 IF( M.GT.K ) THEN 12669 CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, 12670 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 12671 END IF 12672 CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, 12673 $ ONE, T, LDT, WORK, LDWORK ) 12674 IF( M.GT.K ) THEN 12675 CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, 12676 $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) 12677 END IF 12678 CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, 12679 $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) 12680 DO 90 J = 1, K 12681 DO 80 I = 1, N 12682 C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 12683 80 CONTINUE 12684 90 CONTINUE 12685 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 12686 DO 100 J = 1, K 12687 CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 12688 100 CONTINUE 12689 CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, 12690 $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) 12691 IF( N.GT.K ) THEN 12692 CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, 12693 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 12694 END IF 12695 CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, 12696 $ ONE, T, LDT, WORK, LDWORK ) 12697 IF( N.GT.K ) THEN 12698 CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, 12699 $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) 12700 END IF 12701 CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, 12702 $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) 12703 DO 120 J = 1, K 12704 DO 110 I = 1, M 12705 C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 12706 110 CONTINUE 12707 120 CONTINUE 12708 END IF 12709 END IF 12710 ELSE IF( LSAME( STOREV, 'R' ) ) THEN 12711 IF( LSAME( DIRECT, 'F' ) ) THEN 12712 IF( LSAME( SIDE, 'L' ) ) THEN 12713 DO 130 J = 1, K 12714 CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 12715 130 CONTINUE 12716 CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, 12717 $ ONE, V, LDV, WORK, LDWORK ) 12718 IF( M.GT.K ) THEN 12719 CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, 12720 $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, 12721 $ WORK, LDWORK ) 12722 END IF 12723 CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, 12724 $ ONE, T, LDT, WORK, LDWORK ) 12725 IF( M.GT.K ) THEN 12726 CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, 12727 $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, 12728 $ C( K+1, 1 ), LDC ) 12729 END IF 12730 CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, 12731 $ K, ONE, V, LDV, WORK, LDWORK ) 12732 DO 150 J = 1, K 12733 DO 140 I = 1, N 12734 C( J, I ) = C( J, I ) - WORK( I, J ) 12735 140 CONTINUE 12736 150 CONTINUE 12737 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 12738 DO 160 J = 1, K 12739 CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 12740 160 CONTINUE 12741 CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, 12742 $ ONE, V, LDV, WORK, LDWORK ) 12743 IF( N.GT.K ) THEN 12744 CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, 12745 $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, 12746 $ ONE, WORK, LDWORK ) 12747 END IF 12748 CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, 12749 $ ONE, T, LDT, WORK, LDWORK ) 12750 IF( N.GT.K ) THEN 12751 CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, 12752 $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, 12753 $ C( 1, K+1 ), LDC ) 12754 END IF 12755 CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, 12756 $ K, ONE, V, LDV, WORK, LDWORK ) 12757 DO 180 J = 1, K 12758 DO 170 I = 1, M 12759 C( I, J ) = C( I, J ) - WORK( I, J ) 12760 170 CONTINUE 12761 180 CONTINUE 12762 END IF 12763 ELSE 12764 IF( LSAME( SIDE, 'L' ) ) THEN 12765 DO 190 J = 1, K 12766 CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 12767 190 CONTINUE 12768 CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, 12769 $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) 12770 IF( M.GT.K ) THEN 12771 CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, 12772 $ C, LDC, V, LDV, ONE, WORK, LDWORK ) 12773 END IF 12774 CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, 12775 $ ONE, T, LDT, WORK, LDWORK ) 12776 IF( M.GT.K ) THEN 12777 CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, 12778 $ V, LDV, WORK, LDWORK, ONE, C, LDC ) 12779 END IF 12780 CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, 12781 $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) 12782 DO 210 J = 1, K 12783 DO 200 I = 1, N 12784 C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 12785 200 CONTINUE 12786 210 CONTINUE 12787 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 12788 DO 220 J = 1, K 12789 CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 12790 220 CONTINUE 12791 CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, 12792 $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) 12793 IF( N.GT.K ) THEN 12794 CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, 12795 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 12796 END IF 12797 CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, 12798 $ ONE, T, LDT, WORK, LDWORK ) 12799 IF( N.GT.K ) THEN 12800 CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, 12801 $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) 12802 END IF 12803 CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, 12804 $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) 12805 DO 240 J = 1, K 12806 DO 230 I = 1, M 12807 C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 12808 230 CONTINUE 12809 240 CONTINUE 12810 END IF 12811 END IF 12812 END IF 12813 RETURN 12814 END 12815! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarfg.f 12816 SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) 12817 INTEGER INCX, N 12818 DOUBLE PRECISION ALPHA, TAU 12819 DOUBLE PRECISION X( * ) 12820 DOUBLE PRECISION ONE, ZERO 12821 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 12822 INTEGER J, KNT 12823 DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM 12824 DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 12825 EXTERNAL DLAMCH, DLAPY2, DNRM2 12826 INTRINSIC ABS, SIGN 12827 EXTERNAL DSCAL 12828 IF( N.LE.1 ) THEN 12829 TAU = ZERO 12830 RETURN 12831 END IF 12832 XNORM = DNRM2( N-1, X, INCX ) 12833 IF( XNORM.EQ.ZERO ) THEN 12834 TAU = ZERO 12835 ELSE 12836 BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) 12837 SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) 12838 KNT = 0 12839 IF( ABS( BETA ).LT.SAFMIN ) THEN 12840 RSAFMN = ONE / SAFMIN 12841 10 CONTINUE 12842 KNT = KNT + 1 12843 CALL DSCAL( N-1, RSAFMN, X, INCX ) 12844 BETA = BETA*RSAFMN 12845 ALPHA = ALPHA*RSAFMN 12846 IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) ) 12847 $ GO TO 10 12848 XNORM = DNRM2( N-1, X, INCX ) 12849 BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) 12850 END IF 12851 TAU = ( BETA-ALPHA ) / BETA 12852 CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) 12853 DO 20 J = 1, KNT 12854 BETA = BETA*SAFMIN 12855 20 CONTINUE 12856 ALPHA = BETA 12857 END IF 12858 RETURN 12859 END 12860! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarft.f 12861 SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) 12862 CHARACTER DIRECT, STOREV 12863 INTEGER K, LDT, LDV, N 12864 DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) 12865 DOUBLE PRECISION ONE, ZERO 12866 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 12867 INTEGER I, J, PREVLASTV, LASTV 12868 EXTERNAL DGEMV, DTRMV 12869 LOGICAL LSAME 12870 EXTERNAL LSAME 12871 IF( N.EQ.0 ) 12872 $ RETURN 12873 IF( LSAME( DIRECT, 'F' ) ) THEN 12874 PREVLASTV = N 12875 DO I = 1, K 12876 PREVLASTV = MAX( I, PREVLASTV ) 12877 IF( TAU( I ).EQ.ZERO ) THEN 12878 DO J = 1, I 12879 T( J, I ) = ZERO 12880 END DO 12881 ELSE 12882 IF( LSAME( STOREV, 'C' ) ) THEN 12883 DO LASTV = N, I+1, -1 12884 IF( V( LASTV, I ).NE.ZERO ) EXIT 12885 END DO 12886 DO J = 1, I-1 12887 T( J, I ) = -TAU( I ) * V( I , J ) 12888 END DO 12889 J = MIN( LASTV, PREVLASTV ) 12890 CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), 12891 $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, 12892 $ T( 1, I ), 1 ) 12893 ELSE 12894 DO LASTV = N, I+1, -1 12895 IF( V( I, LASTV ).NE.ZERO ) EXIT 12896 END DO 12897 DO J = 1, I-1 12898 T( J, I ) = -TAU( I ) * V( J , I ) 12899 END DO 12900 J = MIN( LASTV, PREVLASTV ) 12901 CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ), 12902 $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE, 12903 $ T( 1, I ), 1 ) 12904 END IF 12905 CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, 12906 $ LDT, T( 1, I ), 1 ) 12907 T( I, I ) = TAU( I ) 12908 IF( I.GT.1 ) THEN 12909 PREVLASTV = MAX( PREVLASTV, LASTV ) 12910 ELSE 12911 PREVLASTV = LASTV 12912 END IF 12913 END IF 12914 END DO 12915 ELSE 12916 PREVLASTV = 1 12917 DO I = K, 1, -1 12918 IF( TAU( I ).EQ.ZERO ) THEN 12919 DO J = I, K 12920 T( J, I ) = ZERO 12921 END DO 12922 ELSE 12923 IF( I.LT.K ) THEN 12924 IF( LSAME( STOREV, 'C' ) ) THEN 12925 DO LASTV = 1, I-1 12926 IF( V( LASTV, I ).NE.ZERO ) EXIT 12927 END DO 12928 DO J = I+1, K 12929 T( J, I ) = -TAU( I ) * V( N-K+I , J ) 12930 END DO 12931 J = MAX( LASTV, PREVLASTV ) 12932 CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ), 12933 $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, 12934 $ T( I+1, I ), 1 ) 12935 ELSE 12936 DO LASTV = 1, I-1 12937 IF( V( I, LASTV ).NE.ZERO ) EXIT 12938 END DO 12939 DO J = I+1, K 12940 T( J, I ) = -TAU( I ) * V( J, N-K+I ) 12941 END DO 12942 J = MAX( LASTV, PREVLASTV ) 12943 CALL DGEMV( 'No transpose', K-I, N-K+I-J, 12944 $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, 12945 $ ONE, T( I+1, I ), 1 ) 12946 END IF 12947 CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, 12948 $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) 12949 IF( I.GT.1 ) THEN 12950 PREVLASTV = MIN( PREVLASTV, LASTV ) 12951 ELSE 12952 PREVLASTV = LASTV 12953 END IF 12954 END IF 12955 T( I, I ) = TAU( I ) 12956 END IF 12957 END DO 12958 END IF 12959 RETURN 12960 END 12961! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarfx.f 12962 SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) 12963 CHARACTER SIDE 12964 INTEGER LDC, M, N 12965 DOUBLE PRECISION TAU 12966 DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) 12967 DOUBLE PRECISION ZERO, ONE 12968 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 12969 INTEGER J 12970 DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, 12971 $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 12972 LOGICAL LSAME 12973 EXTERNAL LSAME 12974 EXTERNAL DLARF 12975 IF( TAU.EQ.ZERO ) 12976 $ RETURN 12977 IF( LSAME( SIDE, 'L' ) ) THEN 12978 GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, 12979 $ 170, 190 )M 12980 CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) 12981 GO TO 410 12982 10 CONTINUE 12983 T1 = ONE - TAU*V( 1 )*V( 1 ) 12984 DO 20 J = 1, N 12985 C( 1, J ) = T1*C( 1, J ) 12986 20 CONTINUE 12987 GO TO 410 12988 30 CONTINUE 12989 V1 = V( 1 ) 12990 T1 = TAU*V1 12991 V2 = V( 2 ) 12992 T2 = TAU*V2 12993 DO 40 J = 1, N 12994 SUM = V1*C( 1, J ) + V2*C( 2, J ) 12995 C( 1, J ) = C( 1, J ) - SUM*T1 12996 C( 2, J ) = C( 2, J ) - SUM*T2 12997 40 CONTINUE 12998 GO TO 410 12999 50 CONTINUE 13000 V1 = V( 1 ) 13001 T1 = TAU*V1 13002 V2 = V( 2 ) 13003 T2 = TAU*V2 13004 V3 = V( 3 ) 13005 T3 = TAU*V3 13006 DO 60 J = 1, N 13007 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) 13008 C( 1, J ) = C( 1, J ) - SUM*T1 13009 C( 2, J ) = C( 2, J ) - SUM*T2 13010 C( 3, J ) = C( 3, J ) - SUM*T3 13011 60 CONTINUE 13012 GO TO 410 13013 70 CONTINUE 13014 V1 = V( 1 ) 13015 T1 = TAU*V1 13016 V2 = V( 2 ) 13017 T2 = TAU*V2 13018 V3 = V( 3 ) 13019 T3 = TAU*V3 13020 V4 = V( 4 ) 13021 T4 = TAU*V4 13022 DO 80 J = 1, N 13023 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 13024 $ V4*C( 4, J ) 13025 C( 1, J ) = C( 1, J ) - SUM*T1 13026 C( 2, J ) = C( 2, J ) - SUM*T2 13027 C( 3, J ) = C( 3, J ) - SUM*T3 13028 C( 4, J ) = C( 4, J ) - SUM*T4 13029 80 CONTINUE 13030 GO TO 410 13031 90 CONTINUE 13032 V1 = V( 1 ) 13033 T1 = TAU*V1 13034 V2 = V( 2 ) 13035 T2 = TAU*V2 13036 V3 = V( 3 ) 13037 T3 = TAU*V3 13038 V4 = V( 4 ) 13039 T4 = TAU*V4 13040 V5 = V( 5 ) 13041 T5 = TAU*V5 13042 DO 100 J = 1, N 13043 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 13044 $ V4*C( 4, J ) + V5*C( 5, J ) 13045 C( 1, J ) = C( 1, J ) - SUM*T1 13046 C( 2, J ) = C( 2, J ) - SUM*T2 13047 C( 3, J ) = C( 3, J ) - SUM*T3 13048 C( 4, J ) = C( 4, J ) - SUM*T4 13049 C( 5, J ) = C( 5, J ) - SUM*T5 13050 100 CONTINUE 13051 GO TO 410 13052 110 CONTINUE 13053 V1 = V( 1 ) 13054 T1 = TAU*V1 13055 V2 = V( 2 ) 13056 T2 = TAU*V2 13057 V3 = V( 3 ) 13058 T3 = TAU*V3 13059 V4 = V( 4 ) 13060 T4 = TAU*V4 13061 V5 = V( 5 ) 13062 T5 = TAU*V5 13063 V6 = V( 6 ) 13064 T6 = TAU*V6 13065 DO 120 J = 1, N 13066 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 13067 $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) 13068 C( 1, J ) = C( 1, J ) - SUM*T1 13069 C( 2, J ) = C( 2, J ) - SUM*T2 13070 C( 3, J ) = C( 3, J ) - SUM*T3 13071 C( 4, J ) = C( 4, J ) - SUM*T4 13072 C( 5, J ) = C( 5, J ) - SUM*T5 13073 C( 6, J ) = C( 6, J ) - SUM*T6 13074 120 CONTINUE 13075 GO TO 410 13076 130 CONTINUE 13077 V1 = V( 1 ) 13078 T1 = TAU*V1 13079 V2 = V( 2 ) 13080 T2 = TAU*V2 13081 V3 = V( 3 ) 13082 T3 = TAU*V3 13083 V4 = V( 4 ) 13084 T4 = TAU*V4 13085 V5 = V( 5 ) 13086 T5 = TAU*V5 13087 V6 = V( 6 ) 13088 T6 = TAU*V6 13089 V7 = V( 7 ) 13090 T7 = TAU*V7 13091 DO 140 J = 1, N 13092 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 13093 $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + 13094 $ V7*C( 7, J ) 13095 C( 1, J ) = C( 1, J ) - SUM*T1 13096 C( 2, J ) = C( 2, J ) - SUM*T2 13097 C( 3, J ) = C( 3, J ) - SUM*T3 13098 C( 4, J ) = C( 4, J ) - SUM*T4 13099 C( 5, J ) = C( 5, J ) - SUM*T5 13100 C( 6, J ) = C( 6, J ) - SUM*T6 13101 C( 7, J ) = C( 7, J ) - SUM*T7 13102 140 CONTINUE 13103 GO TO 410 13104 150 CONTINUE 13105 V1 = V( 1 ) 13106 T1 = TAU*V1 13107 V2 = V( 2 ) 13108 T2 = TAU*V2 13109 V3 = V( 3 ) 13110 T3 = TAU*V3 13111 V4 = V( 4 ) 13112 T4 = TAU*V4 13113 V5 = V( 5 ) 13114 T5 = TAU*V5 13115 V6 = V( 6 ) 13116 T6 = TAU*V6 13117 V7 = V( 7 ) 13118 T7 = TAU*V7 13119 V8 = V( 8 ) 13120 T8 = TAU*V8 13121 DO 160 J = 1, N 13122 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 13123 $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + 13124 $ V7*C( 7, J ) + V8*C( 8, J ) 13125 C( 1, J ) = C( 1, J ) - SUM*T1 13126 C( 2, J ) = C( 2, J ) - SUM*T2 13127 C( 3, J ) = C( 3, J ) - SUM*T3 13128 C( 4, J ) = C( 4, J ) - SUM*T4 13129 C( 5, J ) = C( 5, J ) - SUM*T5 13130 C( 6, J ) = C( 6, J ) - SUM*T6 13131 C( 7, J ) = C( 7, J ) - SUM*T7 13132 C( 8, J ) = C( 8, J ) - SUM*T8 13133 160 CONTINUE 13134 GO TO 410 13135 170 CONTINUE 13136 V1 = V( 1 ) 13137 T1 = TAU*V1 13138 V2 = V( 2 ) 13139 T2 = TAU*V2 13140 V3 = V( 3 ) 13141 T3 = TAU*V3 13142 V4 = V( 4 ) 13143 T4 = TAU*V4 13144 V5 = V( 5 ) 13145 T5 = TAU*V5 13146 V6 = V( 6 ) 13147 T6 = TAU*V6 13148 V7 = V( 7 ) 13149 T7 = TAU*V7 13150 V8 = V( 8 ) 13151 T8 = TAU*V8 13152 V9 = V( 9 ) 13153 T9 = TAU*V9 13154 DO 180 J = 1, N 13155 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 13156 $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + 13157 $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) 13158 C( 1, J ) = C( 1, J ) - SUM*T1 13159 C( 2, J ) = C( 2, J ) - SUM*T2 13160 C( 3, J ) = C( 3, J ) - SUM*T3 13161 C( 4, J ) = C( 4, J ) - SUM*T4 13162 C( 5, J ) = C( 5, J ) - SUM*T5 13163 C( 6, J ) = C( 6, J ) - SUM*T6 13164 C( 7, J ) = C( 7, J ) - SUM*T7 13165 C( 8, J ) = C( 8, J ) - SUM*T8 13166 C( 9, J ) = C( 9, J ) - SUM*T9 13167 180 CONTINUE 13168 GO TO 410 13169 190 CONTINUE 13170 V1 = V( 1 ) 13171 T1 = TAU*V1 13172 V2 = V( 2 ) 13173 T2 = TAU*V2 13174 V3 = V( 3 ) 13175 T3 = TAU*V3 13176 V4 = V( 4 ) 13177 T4 = TAU*V4 13178 V5 = V( 5 ) 13179 T5 = TAU*V5 13180 V6 = V( 6 ) 13181 T6 = TAU*V6 13182 V7 = V( 7 ) 13183 T7 = TAU*V7 13184 V8 = V( 8 ) 13185 T8 = TAU*V8 13186 V9 = V( 9 ) 13187 T9 = TAU*V9 13188 V10 = V( 10 ) 13189 T10 = TAU*V10 13190 DO 200 J = 1, N 13191 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 13192 $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + 13193 $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + 13194 $ V10*C( 10, J ) 13195 C( 1, J ) = C( 1, J ) - SUM*T1 13196 C( 2, J ) = C( 2, J ) - SUM*T2 13197 C( 3, J ) = C( 3, J ) - SUM*T3 13198 C( 4, J ) = C( 4, J ) - SUM*T4 13199 C( 5, J ) = C( 5, J ) - SUM*T5 13200 C( 6, J ) = C( 6, J ) - SUM*T6 13201 C( 7, J ) = C( 7, J ) - SUM*T7 13202 C( 8, J ) = C( 8, J ) - SUM*T8 13203 C( 9, J ) = C( 9, J ) - SUM*T9 13204 C( 10, J ) = C( 10, J ) - SUM*T10 13205 200 CONTINUE 13206 GO TO 410 13207 ELSE 13208 GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, 13209 $ 370, 390 )N 13210 CALL DLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) 13211 GO TO 410 13212 210 CONTINUE 13213 T1 = ONE - TAU*V( 1 )*V( 1 ) 13214 DO 220 J = 1, M 13215 C( J, 1 ) = T1*C( J, 1 ) 13216 220 CONTINUE 13217 GO TO 410 13218 230 CONTINUE 13219 V1 = V( 1 ) 13220 T1 = TAU*V1 13221 V2 = V( 2 ) 13222 T2 = TAU*V2 13223 DO 240 J = 1, M 13224 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) 13225 C( J, 1 ) = C( J, 1 ) - SUM*T1 13226 C( J, 2 ) = C( J, 2 ) - SUM*T2 13227 240 CONTINUE 13228 GO TO 410 13229 250 CONTINUE 13230 V1 = V( 1 ) 13231 T1 = TAU*V1 13232 V2 = V( 2 ) 13233 T2 = TAU*V2 13234 V3 = V( 3 ) 13235 T3 = TAU*V3 13236 DO 260 J = 1, M 13237 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) 13238 C( J, 1 ) = C( J, 1 ) - SUM*T1 13239 C( J, 2 ) = C( J, 2 ) - SUM*T2 13240 C( J, 3 ) = C( J, 3 ) - SUM*T3 13241 260 CONTINUE 13242 GO TO 410 13243 270 CONTINUE 13244 V1 = V( 1 ) 13245 T1 = TAU*V1 13246 V2 = V( 2 ) 13247 T2 = TAU*V2 13248 V3 = V( 3 ) 13249 T3 = TAU*V3 13250 V4 = V( 4 ) 13251 T4 = TAU*V4 13252 DO 280 J = 1, M 13253 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 13254 $ V4*C( J, 4 ) 13255 C( J, 1 ) = C( J, 1 ) - SUM*T1 13256 C( J, 2 ) = C( J, 2 ) - SUM*T2 13257 C( J, 3 ) = C( J, 3 ) - SUM*T3 13258 C( J, 4 ) = C( J, 4 ) - SUM*T4 13259 280 CONTINUE 13260 GO TO 410 13261 290 CONTINUE 13262 V1 = V( 1 ) 13263 T1 = TAU*V1 13264 V2 = V( 2 ) 13265 T2 = TAU*V2 13266 V3 = V( 3 ) 13267 T3 = TAU*V3 13268 V4 = V( 4 ) 13269 T4 = TAU*V4 13270 V5 = V( 5 ) 13271 T5 = TAU*V5 13272 DO 300 J = 1, M 13273 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 13274 $ V4*C( J, 4 ) + V5*C( J, 5 ) 13275 C( J, 1 ) = C( J, 1 ) - SUM*T1 13276 C( J, 2 ) = C( J, 2 ) - SUM*T2 13277 C( J, 3 ) = C( J, 3 ) - SUM*T3 13278 C( J, 4 ) = C( J, 4 ) - SUM*T4 13279 C( J, 5 ) = C( J, 5 ) - SUM*T5 13280 300 CONTINUE 13281 GO TO 410 13282 310 CONTINUE 13283 V1 = V( 1 ) 13284 T1 = TAU*V1 13285 V2 = V( 2 ) 13286 T2 = TAU*V2 13287 V3 = V( 3 ) 13288 T3 = TAU*V3 13289 V4 = V( 4 ) 13290 T4 = TAU*V4 13291 V5 = V( 5 ) 13292 T5 = TAU*V5 13293 V6 = V( 6 ) 13294 T6 = TAU*V6 13295 DO 320 J = 1, M 13296 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 13297 $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) 13298 C( J, 1 ) = C( J, 1 ) - SUM*T1 13299 C( J, 2 ) = C( J, 2 ) - SUM*T2 13300 C( J, 3 ) = C( J, 3 ) - SUM*T3 13301 C( J, 4 ) = C( J, 4 ) - SUM*T4 13302 C( J, 5 ) = C( J, 5 ) - SUM*T5 13303 C( J, 6 ) = C( J, 6 ) - SUM*T6 13304 320 CONTINUE 13305 GO TO 410 13306 330 CONTINUE 13307 V1 = V( 1 ) 13308 T1 = TAU*V1 13309 V2 = V( 2 ) 13310 T2 = TAU*V2 13311 V3 = V( 3 ) 13312 T3 = TAU*V3 13313 V4 = V( 4 ) 13314 T4 = TAU*V4 13315 V5 = V( 5 ) 13316 T5 = TAU*V5 13317 V6 = V( 6 ) 13318 T6 = TAU*V6 13319 V7 = V( 7 ) 13320 T7 = TAU*V7 13321 DO 340 J = 1, M 13322 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 13323 $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + 13324 $ V7*C( J, 7 ) 13325 C( J, 1 ) = C( J, 1 ) - SUM*T1 13326 C( J, 2 ) = C( J, 2 ) - SUM*T2 13327 C( J, 3 ) = C( J, 3 ) - SUM*T3 13328 C( J, 4 ) = C( J, 4 ) - SUM*T4 13329 C( J, 5 ) = C( J, 5 ) - SUM*T5 13330 C( J, 6 ) = C( J, 6 ) - SUM*T6 13331 C( J, 7 ) = C( J, 7 ) - SUM*T7 13332 340 CONTINUE 13333 GO TO 410 13334 350 CONTINUE 13335 V1 = V( 1 ) 13336 T1 = TAU*V1 13337 V2 = V( 2 ) 13338 T2 = TAU*V2 13339 V3 = V( 3 ) 13340 T3 = TAU*V3 13341 V4 = V( 4 ) 13342 T4 = TAU*V4 13343 V5 = V( 5 ) 13344 T5 = TAU*V5 13345 V6 = V( 6 ) 13346 T6 = TAU*V6 13347 V7 = V( 7 ) 13348 T7 = TAU*V7 13349 V8 = V( 8 ) 13350 T8 = TAU*V8 13351 DO 360 J = 1, M 13352 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 13353 $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + 13354 $ V7*C( J, 7 ) + V8*C( J, 8 ) 13355 C( J, 1 ) = C( J, 1 ) - SUM*T1 13356 C( J, 2 ) = C( J, 2 ) - SUM*T2 13357 C( J, 3 ) = C( J, 3 ) - SUM*T3 13358 C( J, 4 ) = C( J, 4 ) - SUM*T4 13359 C( J, 5 ) = C( J, 5 ) - SUM*T5 13360 C( J, 6 ) = C( J, 6 ) - SUM*T6 13361 C( J, 7 ) = C( J, 7 ) - SUM*T7 13362 C( J, 8 ) = C( J, 8 ) - SUM*T8 13363 360 CONTINUE 13364 GO TO 410 13365 370 CONTINUE 13366 V1 = V( 1 ) 13367 T1 = TAU*V1 13368 V2 = V( 2 ) 13369 T2 = TAU*V2 13370 V3 = V( 3 ) 13371 T3 = TAU*V3 13372 V4 = V( 4 ) 13373 T4 = TAU*V4 13374 V5 = V( 5 ) 13375 T5 = TAU*V5 13376 V6 = V( 6 ) 13377 T6 = TAU*V6 13378 V7 = V( 7 ) 13379 T7 = TAU*V7 13380 V8 = V( 8 ) 13381 T8 = TAU*V8 13382 V9 = V( 9 ) 13383 T9 = TAU*V9 13384 DO 380 J = 1, M 13385 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 13386 $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + 13387 $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) 13388 C( J, 1 ) = C( J, 1 ) - SUM*T1 13389 C( J, 2 ) = C( J, 2 ) - SUM*T2 13390 C( J, 3 ) = C( J, 3 ) - SUM*T3 13391 C( J, 4 ) = C( J, 4 ) - SUM*T4 13392 C( J, 5 ) = C( J, 5 ) - SUM*T5 13393 C( J, 6 ) = C( J, 6 ) - SUM*T6 13394 C( J, 7 ) = C( J, 7 ) - SUM*T7 13395 C( J, 8 ) = C( J, 8 ) - SUM*T8 13396 C( J, 9 ) = C( J, 9 ) - SUM*T9 13397 380 CONTINUE 13398 GO TO 410 13399 390 CONTINUE 13400 V1 = V( 1 ) 13401 T1 = TAU*V1 13402 V2 = V( 2 ) 13403 T2 = TAU*V2 13404 V3 = V( 3 ) 13405 T3 = TAU*V3 13406 V4 = V( 4 ) 13407 T4 = TAU*V4 13408 V5 = V( 5 ) 13409 T5 = TAU*V5 13410 V6 = V( 6 ) 13411 T6 = TAU*V6 13412 V7 = V( 7 ) 13413 T7 = TAU*V7 13414 V8 = V( 8 ) 13415 T8 = TAU*V8 13416 V9 = V( 9 ) 13417 T9 = TAU*V9 13418 V10 = V( 10 ) 13419 T10 = TAU*V10 13420 DO 400 J = 1, M 13421 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 13422 $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + 13423 $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + 13424 $ V10*C( J, 10 ) 13425 C( J, 1 ) = C( J, 1 ) - SUM*T1 13426 C( J, 2 ) = C( J, 2 ) - SUM*T2 13427 C( J, 3 ) = C( J, 3 ) - SUM*T3 13428 C( J, 4 ) = C( J, 4 ) - SUM*T4 13429 C( J, 5 ) = C( J, 5 ) - SUM*T5 13430 C( J, 6 ) = C( J, 6 ) - SUM*T6 13431 C( J, 7 ) = C( J, 7 ) - SUM*T7 13432 C( J, 8 ) = C( J, 8 ) - SUM*T8 13433 C( J, 9 ) = C( J, 9 ) - SUM*T9 13434 C( J, 10 ) = C( J, 10 ) - SUM*T10 13435 400 CONTINUE 13436 GO TO 410 13437 END IF 13438 410 CONTINUE 13439 RETURN 13440 END 13441! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarfy.f 13442 SUBROUTINE DLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) 13443 CHARACTER UPLO 13444 INTEGER INCV, LDC, N 13445 DOUBLE PRECISION TAU 13446 DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) 13447 DOUBLE PRECISION ONE, ZERO, HALF 13448 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, HALF = 0.5D+0 ) 13449 DOUBLE PRECISION ALPHA 13450 EXTERNAL DAXPY, DSYMV, DSYR2 13451 DOUBLE PRECISION DDOT 13452 EXTERNAL DDOT 13453 IF( TAU.EQ.ZERO ) 13454 $ RETURN 13455 CALL DSYMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) 13456 ALPHA = -HALF*TAU*DDOT( N, WORK, 1, V, INCV ) 13457 CALL DAXPY( N, ALPHA, V, INCV, WORK, 1 ) 13458 CALL DSYR2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC ) 13459 RETURN 13460 END 13461! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarnv.f 13462 SUBROUTINE DLARNV( IDIST, ISEED, N, X ) 13463 INTEGER IDIST, N 13464 INTEGER ISEED( 4 ) 13465 DOUBLE PRECISION X( * ) 13466 DOUBLE PRECISION ONE, TWO 13467 PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) 13468 INTEGER LV 13469 PARAMETER ( LV = 128 ) 13470 DOUBLE PRECISION TWOPI 13471 PARAMETER ( TWOPI = 6.28318530717958647692528676655900576839D+0 ) 13472 INTEGER I, IL, IL2, IV 13473 DOUBLE PRECISION U( LV ) 13474 INTRINSIC COS, LOG, MIN, SQRT 13475 EXTERNAL DLARUV 13476 DO 40 IV = 1, N, LV / 2 13477 IL = MIN( LV / 2, N-IV+1 ) 13478 IF( IDIST.EQ.3 ) THEN 13479 IL2 = 2*IL 13480 ELSE 13481 IL2 = IL 13482 END IF 13483 CALL DLARUV( ISEED, IL2, U ) 13484 IF( IDIST.EQ.1 ) THEN 13485 DO 10 I = 1, IL 13486 X( IV+I-1 ) = U( I ) 13487 10 CONTINUE 13488 ELSE IF( IDIST.EQ.2 ) THEN 13489 DO 20 I = 1, IL 13490 X( IV+I-1 ) = TWO*U( I ) - ONE 13491 20 CONTINUE 13492 ELSE IF( IDIST.EQ.3 ) THEN 13493 DO 30 I = 1, IL 13494 X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* 13495 $ COS( TWOPI*U( 2*I ) ) 13496 30 CONTINUE 13497 END IF 13498 40 CONTINUE 13499 RETURN 13500 END 13501! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarra.f 13502 SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM, 13503 $ NSPLIT, ISPLIT, INFO ) 13504 INTEGER INFO, N, NSPLIT 13505 DOUBLE PRECISION SPLTOL, TNRM 13506 INTEGER ISPLIT( * ) 13507 DOUBLE PRECISION D( * ), E( * ), E2( * ) 13508 DOUBLE PRECISION ZERO 13509 PARAMETER ( ZERO = 0.0D0 ) 13510 INTEGER I 13511 DOUBLE PRECISION EABS, TMP1 13512 INTRINSIC ABS 13513 INFO = 0 13514 IF( N.LE.0 ) THEN 13515 RETURN 13516 END IF 13517 NSPLIT = 1 13518 IF(SPLTOL.LT.ZERO) THEN 13519 TMP1 = ABS(SPLTOL)* TNRM 13520 DO 9 I = 1, N-1 13521 EABS = ABS( E(I) ) 13522 IF( EABS .LE. TMP1) THEN 13523 E(I) = ZERO 13524 E2(I) = ZERO 13525 ISPLIT( NSPLIT ) = I 13526 NSPLIT = NSPLIT + 1 13527 END IF 13528 9 CONTINUE 13529 ELSE 13530 DO 10 I = 1, N-1 13531 EABS = ABS( E(I) ) 13532 IF( EABS .LE. SPLTOL * SQRT(ABS(D(I)))*SQRT(ABS(D(I+1))) ) 13533 $ THEN 13534 E(I) = ZERO 13535 E2(I) = ZERO 13536 ISPLIT( NSPLIT ) = I 13537 NSPLIT = NSPLIT + 1 13538 END IF 13539 10 CONTINUE 13540 ENDIF 13541 ISPLIT( NSPLIT ) = N 13542 RETURN 13543 END 13544! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarrb.f 13545 SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, 13546 $ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, 13547 $ PIVMIN, SPDIAM, TWIST, INFO ) 13548 INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST 13549 DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPDIAM 13550 INTEGER IWORK( * ) 13551 DOUBLE PRECISION D( * ), LLD( * ), W( * ), 13552 $ WERR( * ), WGAP( * ), WORK( * ) 13553 DOUBLE PRECISION ZERO, TWO, HALF 13554 PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, 13555 $ HALF = 0.5D0 ) 13556 INTEGER MAXITR 13557 INTEGER I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT, 13558 $ OLNINT, PREV, R 13559 DOUBLE PRECISION BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH, 13560 $ RGAP, RIGHT, TMP, WIDTH 13561 INTEGER DLANEG 13562 EXTERNAL DLANEG 13563 INTRINSIC ABS, MAX, MIN 13564 INFO = 0 13565 IF( N.LE.0 ) THEN 13566 RETURN 13567 END IF 13568 MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) / 13569 $ LOG( TWO ) ) + 2 13570 MNWDTH = TWO * PIVMIN 13571 R = TWIST 13572 IF((R.LT.1).OR.(R.GT.N)) R = N 13573 I1 = IFIRST 13574 NINT = 0 13575 PREV = 0 13576 RGAP = WGAP( I1-OFFSET ) 13577 DO 75 I = I1, ILAST 13578 K = 2*I 13579 II = I - OFFSET 13580 LEFT = W( II ) - WERR( II ) 13581 RIGHT = W( II ) + WERR( II ) 13582 LGAP = RGAP 13583 RGAP = WGAP( II ) 13584 GAP = MIN( LGAP, RGAP ) 13585 BACK = WERR( II ) 13586 20 CONTINUE 13587 NEGCNT = DLANEG( N, D, LLD, LEFT, PIVMIN, R ) 13588 IF( NEGCNT.GT.I-1 ) THEN 13589 LEFT = LEFT - BACK 13590 BACK = TWO*BACK 13591 GO TO 20 13592 END IF 13593 BACK = WERR( II ) 13594 50 CONTINUE 13595 NEGCNT = DLANEG( N, D, LLD, RIGHT, PIVMIN, R ) 13596 IF( NEGCNT.LT.I ) THEN 13597 RIGHT = RIGHT + BACK 13598 BACK = TWO*BACK 13599 GO TO 50 13600 END IF 13601 WIDTH = HALF*ABS( LEFT - RIGHT ) 13602 TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) 13603 CVRGD = MAX(RTOL1*GAP,RTOL2*TMP) 13604 IF( WIDTH.LE.CVRGD .OR. WIDTH.LE.MNWDTH ) THEN 13605 IWORK( K-1 ) = -1 13606 IF((I.EQ.I1).AND.(I.LT.ILAST)) I1 = I + 1 13607 IF((PREV.GE.I1).AND.(I.LE.ILAST)) IWORK( 2*PREV-1 ) = I + 1 13608 ELSE 13609 PREV = I 13610 NINT = NINT + 1 13611 IWORK( K-1 ) = I + 1 13612 IWORK( K ) = NEGCNT 13613 END IF 13614 WORK( K-1 ) = LEFT 13615 WORK( K ) = RIGHT 13616 75 CONTINUE 13617 ITER = 0 13618 80 CONTINUE 13619 PREV = I1 - 1 13620 I = I1 13621 OLNINT = NINT 13622 DO 100 IP = 1, OLNINT 13623 K = 2*I 13624 II = I - OFFSET 13625 RGAP = WGAP( II ) 13626 LGAP = RGAP 13627 IF(II.GT.1) LGAP = WGAP( II-1 ) 13628 GAP = MIN( LGAP, RGAP ) 13629 NEXT = IWORK( K-1 ) 13630 LEFT = WORK( K-1 ) 13631 RIGHT = WORK( K ) 13632 MID = HALF*( LEFT + RIGHT ) 13633 WIDTH = RIGHT - MID 13634 TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) 13635 CVRGD = MAX(RTOL1*GAP,RTOL2*TMP) 13636 IF( ( WIDTH.LE.CVRGD ) .OR. ( WIDTH.LE.MNWDTH ).OR. 13637 $ ( ITER.EQ.MAXITR ) )THEN 13638 NINT = NINT - 1 13639 IWORK( K-1 ) = 0 13640 IF( I1.EQ.I ) THEN 13641 I1 = NEXT 13642 ELSE 13643 IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT 13644 END IF 13645 I = NEXT 13646 GO TO 100 13647 END IF 13648 PREV = I 13649 NEGCNT = DLANEG( N, D, LLD, MID, PIVMIN, R ) 13650 IF( NEGCNT.LE.I-1 ) THEN 13651 WORK( K-1 ) = MID 13652 ELSE 13653 WORK( K ) = MID 13654 END IF 13655 I = NEXT 13656 100 CONTINUE 13657 ITER = ITER + 1 13658 IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80 13659 DO 110 I = IFIRST, ILAST 13660 K = 2*I 13661 II = I - OFFSET 13662 IF( IWORK( K-1 ).EQ.0 ) THEN 13663 W( II ) = HALF*( WORK( K-1 )+WORK( K ) ) 13664 WERR( II ) = WORK( K ) - W( II ) 13665 END IF 13666 110 CONTINUE 13667 DO 111 I = IFIRST+1, ILAST 13668 K = 2*I 13669 II = I - OFFSET 13670 WGAP( II-1 ) = MAX( ZERO, 13671 $ W(II) - WERR (II) - W( II-1 ) - WERR( II-1 )) 13672 111 CONTINUE 13673 RETURN 13674 END 13675! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarrc.f 13676 SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, 13677 $ EIGCNT, LCNT, RCNT, INFO ) 13678 CHARACTER JOBT 13679 INTEGER EIGCNT, INFO, LCNT, N, RCNT 13680 DOUBLE PRECISION PIVMIN, VL, VU 13681 DOUBLE PRECISION D( * ), E( * ) 13682 DOUBLE PRECISION ZERO 13683 PARAMETER ( ZERO = 0.0D0 ) 13684 INTEGER I 13685 LOGICAL MATT 13686 DOUBLE PRECISION LPIVOT, RPIVOT, SL, SU, TMP, TMP2 13687 LOGICAL LSAME 13688 EXTERNAL LSAME 13689 INFO = 0 13690 IF( N.LE.0 ) THEN 13691 RETURN 13692 END IF 13693 LCNT = 0 13694 RCNT = 0 13695 EIGCNT = 0 13696 MATT = LSAME( JOBT, 'T' ) 13697 IF (MATT) THEN 13698 LPIVOT = D( 1 ) - VL 13699 RPIVOT = D( 1 ) - VU 13700 IF( LPIVOT.LE.ZERO ) THEN 13701 LCNT = LCNT + 1 13702 ENDIF 13703 IF( RPIVOT.LE.ZERO ) THEN 13704 RCNT = RCNT + 1 13705 ENDIF 13706 DO 10 I = 1, N-1 13707 TMP = E(I)**2 13708 LPIVOT = ( D( I+1 )-VL ) - TMP/LPIVOT 13709 RPIVOT = ( D( I+1 )-VU ) - TMP/RPIVOT 13710 IF( LPIVOT.LE.ZERO ) THEN 13711 LCNT = LCNT + 1 13712 ENDIF 13713 IF( RPIVOT.LE.ZERO ) THEN 13714 RCNT = RCNT + 1 13715 ENDIF 13716 10 CONTINUE 13717 ELSE 13718 SL = -VL 13719 SU = -VU 13720 DO 20 I = 1, N - 1 13721 LPIVOT = D( I ) + SL 13722 RPIVOT = D( I ) + SU 13723 IF( LPIVOT.LE.ZERO ) THEN 13724 LCNT = LCNT + 1 13725 ENDIF 13726 IF( RPIVOT.LE.ZERO ) THEN 13727 RCNT = RCNT + 1 13728 ENDIF 13729 TMP = E(I) * D(I) * E(I) 13730 TMP2 = TMP / LPIVOT 13731 IF( TMP2.EQ.ZERO ) THEN 13732 SL = TMP - VL 13733 ELSE 13734 SL = SL*TMP2 - VL 13735 END IF 13736 TMP2 = TMP / RPIVOT 13737 IF( TMP2.EQ.ZERO ) THEN 13738 SU = TMP - VU 13739 ELSE 13740 SU = SU*TMP2 - VU 13741 END IF 13742 20 CONTINUE 13743 LPIVOT = D( N ) + SL 13744 RPIVOT = D( N ) + SU 13745 IF( LPIVOT.LE.ZERO ) THEN 13746 LCNT = LCNT + 1 13747 ENDIF 13748 IF( RPIVOT.LE.ZERO ) THEN 13749 RCNT = RCNT + 1 13750 ENDIF 13751 ENDIF 13752 EIGCNT = RCNT - LCNT 13753 RETURN 13754 END 13755! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarrd.f 13756 SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, 13757 $ RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, 13758 $ M, W, WERR, WL, WU, IBLOCK, INDEXW, 13759 $ WORK, IWORK, INFO ) 13760 CHARACTER ORDER, RANGE 13761 INTEGER IL, INFO, IU, M, N, NSPLIT 13762 DOUBLE PRECISION PIVMIN, RELTOL, VL, VU, WL, WU 13763 INTEGER IBLOCK( * ), INDEXW( * ), 13764 $ ISPLIT( * ), IWORK( * ) 13765 DOUBLE PRECISION D( * ), E( * ), E2( * ), 13766 $ GERS( * ), W( * ), WERR( * ), WORK( * ) 13767 DOUBLE PRECISION ZERO, ONE, TWO, HALF, FUDGE 13768 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, 13769 $ TWO = 2.0D0, HALF = ONE/TWO, 13770 $ FUDGE = TWO ) 13771 INTEGER ALLRNG, VALRNG, INDRNG 13772 PARAMETER ( ALLRNG = 1, VALRNG = 2, INDRNG = 3 ) 13773 LOGICAL NCNVRG, TOOFEW 13774 INTEGER I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, 13775 $ IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1, 13776 $ ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB, 13777 $ NWL, NWU 13778 DOUBLE PRECISION ATOLI, EPS, GL, GU, RTOLI, TMP1, TMP2, 13779 $ TNORM, UFLOW, WKILL, WLU, WUL 13780 INTEGER IDUMMA( 1 ) 13781 LOGICAL LSAME 13782 INTEGER ILAENV 13783 DOUBLE PRECISION DLAMCH 13784 EXTERNAL LSAME, ILAENV, DLAMCH 13785 EXTERNAL DLAEBZ 13786 INTRINSIC ABS, INT, LOG, MAX, MIN 13787 INFO = 0 13788 IF( N.LE.0 ) THEN 13789 RETURN 13790 END IF 13791 IF( LSAME( RANGE, 'A' ) ) THEN 13792 IRANGE = ALLRNG 13793 ELSE IF( LSAME( RANGE, 'V' ) ) THEN 13794 IRANGE = VALRNG 13795 ELSE IF( LSAME( RANGE, 'I' ) ) THEN 13796 IRANGE = INDRNG 13797 ELSE 13798 IRANGE = 0 13799 END IF 13800 IF( IRANGE.LE.0 ) THEN 13801 INFO = -1 13802 ELSE IF( .NOT.(LSAME(ORDER,'B').OR.LSAME(ORDER,'E')) ) THEN 13803 INFO = -2 13804 ELSE IF( N.LT.0 ) THEN 13805 INFO = -3 13806 ELSE IF( IRANGE.EQ.VALRNG ) THEN 13807 IF( VL.GE.VU ) 13808 $ INFO = -5 13809 ELSE IF( IRANGE.EQ.INDRNG .AND. 13810 $ ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) THEN 13811 INFO = -6 13812 ELSE IF( IRANGE.EQ.INDRNG .AND. 13813 $ ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN 13814 INFO = -7 13815 END IF 13816 IF( INFO.NE.0 ) THEN 13817 RETURN 13818 END IF 13819 INFO = 0 13820 NCNVRG = .FALSE. 13821 TOOFEW = .FALSE. 13822 M = 0 13823 IF( N.EQ.0 ) RETURN 13824 IF( IRANGE.EQ.INDRNG .AND. IL.EQ.1 .AND. IU.EQ.N ) IRANGE = 1 13825 EPS = DLAMCH( 'P' ) 13826 UFLOW = DLAMCH( 'U' ) 13827 IF( N.EQ.1 ) THEN 13828 IF( (IRANGE.EQ.ALLRNG).OR. 13829 $ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR. 13830 $ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN 13831 M = 1 13832 W(1) = D(1) 13833 WERR(1) = ZERO 13834 IBLOCK( 1 ) = 1 13835 INDEXW( 1 ) = 1 13836 ENDIF 13837 RETURN 13838 END IF 13839 NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) 13840 IF( NB.LE.1 ) NB = 0 13841 GL = D(1) 13842 GU = D(1) 13843 DO 5 I = 1,N 13844 GL = MIN( GL, GERS( 2*I - 1)) 13845 GU = MAX( GU, GERS(2*I) ) 13846 5 CONTINUE 13847 TNORM = MAX( ABS( GL ), ABS( GU ) ) 13848 GL = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN 13849 GU = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN 13850 RTOLI = RELTOL 13851 ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN 13852 IF( IRANGE.EQ.INDRNG ) THEN 13853 ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / 13854 $ LOG( TWO ) ) + 2 13855 WORK( N+1 ) = GL 13856 WORK( N+2 ) = GL 13857 WORK( N+3 ) = GU 13858 WORK( N+4 ) = GU 13859 WORK( N+5 ) = GL 13860 WORK( N+6 ) = GU 13861 IWORK( 1 ) = -1 13862 IWORK( 2 ) = -1 13863 IWORK( 3 ) = N + 1 13864 IWORK( 4 ) = N + 1 13865 IWORK( 5 ) = IL - 1 13866 IWORK( 6 ) = IU 13867 CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, 13868 $ D, E, E2, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, 13869 $ IWORK, W, IBLOCK, IINFO ) 13870 IF( IINFO .NE. 0 ) THEN 13871 INFO = IINFO 13872 RETURN 13873 END IF 13874 IF( IWORK( 6 ).EQ.IU ) THEN 13875 WL = WORK( N+1 ) 13876 WLU = WORK( N+3 ) 13877 NWL = IWORK( 1 ) 13878 WU = WORK( N+4 ) 13879 WUL = WORK( N+2 ) 13880 NWU = IWORK( 4 ) 13881 ELSE 13882 WL = WORK( N+2 ) 13883 WLU = WORK( N+4 ) 13884 NWL = IWORK( 2 ) 13885 WU = WORK( N+3 ) 13886 WUL = WORK( N+1 ) 13887 NWU = IWORK( 3 ) 13888 END IF 13889 IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN 13890 INFO = 4 13891 RETURN 13892 END IF 13893 ELSEIF( IRANGE.EQ.VALRNG ) THEN 13894 WL = VL 13895 WU = VU 13896 ELSEIF( IRANGE.EQ.ALLRNG ) THEN 13897 WL = GL 13898 WU = GU 13899 ENDIF 13900 M = 0 13901 IEND = 0 13902 INFO = 0 13903 NWL = 0 13904 NWU = 0 13905 DO 70 JBLK = 1, NSPLIT 13906 IOFF = IEND 13907 IBEGIN = IOFF + 1 13908 IEND = ISPLIT( JBLK ) 13909 IN = IEND - IOFF 13910 IF( IN.EQ.1 ) THEN 13911 IF( WL.GE.D( IBEGIN )-PIVMIN ) 13912 $ NWL = NWL + 1 13913 IF( WU.GE.D( IBEGIN )-PIVMIN ) 13914 $ NWU = NWU + 1 13915 IF( IRANGE.EQ.ALLRNG .OR. 13916 $ ( WL.LT.D( IBEGIN )-PIVMIN 13917 $ .AND. WU.GE. D( IBEGIN )-PIVMIN ) ) THEN 13918 M = M + 1 13919 W( M ) = D( IBEGIN ) 13920 WERR(M) = ZERO 13921 IBLOCK( M ) = JBLK 13922 INDEXW( M ) = 1 13923 END IF 13924 ELSE 13925 GU = D( IBEGIN ) 13926 GL = D( IBEGIN ) 13927 TMP1 = ZERO 13928 DO 40 J = IBEGIN, IEND 13929 GL = MIN( GL, GERS( 2*J - 1)) 13930 GU = MAX( GU, GERS(2*J) ) 13931 40 CONTINUE 13932 GL = GL - FUDGE*TNORM*EPS*IN - FUDGE*PIVMIN 13933 GU = GU + FUDGE*TNORM*EPS*IN + FUDGE*PIVMIN 13934 IF( IRANGE.GT.1 ) THEN 13935 IF( GU.LT.WL ) THEN 13936 NWL = NWL + IN 13937 NWU = NWU + IN 13938 GO TO 70 13939 END IF 13940 GL = MAX( GL, WL ) 13941 GU = MIN( GU, WU ) 13942 IF( GL.GE.GU ) 13943 $ GO TO 70 13944 END IF 13945 WORK( N+1 ) = GL 13946 WORK( N+IN+1 ) = GU 13947 CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, 13948 $ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ), 13949 $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, 13950 $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) 13951 IF( IINFO .NE. 0 ) THEN 13952 INFO = IINFO 13953 RETURN 13954 END IF 13955 NWL = NWL + IWORK( 1 ) 13956 NWU = NWU + IWORK( IN+1 ) 13957 IWOFF = M - IWORK( 1 ) 13958 ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / 13959 $ LOG( TWO ) ) + 2 13960 CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, 13961 $ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ), 13962 $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, 13963 $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) 13964 IF( IINFO .NE. 0 ) THEN 13965 INFO = IINFO 13966 RETURN 13967 END IF 13968 DO 60 J = 1, IOUT 13969 TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) 13970 TMP2 = HALF*ABS( WORK( J+N )-WORK( J+IN+N ) ) 13971 IF( J.GT.IOUT-IINFO ) THEN 13972 NCNVRG = .TRUE. 13973 IB = -JBLK 13974 ELSE 13975 IB = JBLK 13976 END IF 13977 DO 50 JE = IWORK( J ) + 1 + IWOFF, 13978 $ IWORK( J+IN ) + IWOFF 13979 W( JE ) = TMP1 13980 WERR( JE ) = TMP2 13981 INDEXW( JE ) = JE - IWOFF 13982 IBLOCK( JE ) = IB 13983 50 CONTINUE 13984 60 CONTINUE 13985 M = M + IM 13986 END IF 13987 70 CONTINUE 13988 IF( IRANGE.EQ.INDRNG ) THEN 13989 IDISCL = IL - 1 - NWL 13990 IDISCU = NWU - IU 13991 IF( IDISCL.GT.0 ) THEN 13992 IM = 0 13993 DO 80 JE = 1, M 13994 IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN 13995 IDISCL = IDISCL - 1 13996 ELSE 13997 IM = IM + 1 13998 W( IM ) = W( JE ) 13999 WERR( IM ) = WERR( JE ) 14000 INDEXW( IM ) = INDEXW( JE ) 14001 IBLOCK( IM ) = IBLOCK( JE ) 14002 END IF 14003 80 CONTINUE 14004 M = IM 14005 END IF 14006 IF( IDISCU.GT.0 ) THEN 14007 IM=M+1 14008 DO 81 JE = M, 1, -1 14009 IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN 14010 IDISCU = IDISCU - 1 14011 ELSE 14012 IM = IM - 1 14013 W( IM ) = W( JE ) 14014 WERR( IM ) = WERR( JE ) 14015 INDEXW( IM ) = INDEXW( JE ) 14016 IBLOCK( IM ) = IBLOCK( JE ) 14017 END IF 14018 81 CONTINUE 14019 JEE = 0 14020 DO 82 JE = IM, M 14021 JEE = JEE + 1 14022 W( JEE ) = W( JE ) 14023 WERR( JEE ) = WERR( JE ) 14024 INDEXW( JEE ) = INDEXW( JE ) 14025 IBLOCK( JEE ) = IBLOCK( JE ) 14026 82 CONTINUE 14027 M = M-IM+1 14028 END IF 14029 IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN 14030 IF( IDISCL.GT.0 ) THEN 14031 WKILL = WU 14032 DO 100 JDISC = 1, IDISCL 14033 IW = 0 14034 DO 90 JE = 1, M 14035 IF( IBLOCK( JE ).NE.0 .AND. 14036 $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN 14037 IW = JE 14038 WKILL = W( JE ) 14039 END IF 14040 90 CONTINUE 14041 IBLOCK( IW ) = 0 14042 100 CONTINUE 14043 END IF 14044 IF( IDISCU.GT.0 ) THEN 14045 WKILL = WL 14046 DO 120 JDISC = 1, IDISCU 14047 IW = 0 14048 DO 110 JE = 1, M 14049 IF( IBLOCK( JE ).NE.0 .AND. 14050 $ ( W( JE ).GE.WKILL .OR. IW.EQ.0 ) ) THEN 14051 IW = JE 14052 WKILL = W( JE ) 14053 END IF 14054 110 CONTINUE 14055 IBLOCK( IW ) = 0 14056 120 CONTINUE 14057 END IF 14058 IM = 0 14059 DO 130 JE = 1, M 14060 IF( IBLOCK( JE ).NE.0 ) THEN 14061 IM = IM + 1 14062 W( IM ) = W( JE ) 14063 WERR( IM ) = WERR( JE ) 14064 INDEXW( IM ) = INDEXW( JE ) 14065 IBLOCK( IM ) = IBLOCK( JE ) 14066 END IF 14067 130 CONTINUE 14068 M = IM 14069 END IF 14070 IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN 14071 TOOFEW = .TRUE. 14072 END IF 14073 END IF 14074 IF(( IRANGE.EQ.ALLRNG .AND. M.NE.N ).OR. 14075 $ ( IRANGE.EQ.INDRNG .AND. M.NE.IU-IL+1 ) ) THEN 14076 TOOFEW = .TRUE. 14077 END IF 14078 IF( LSAME(ORDER,'E') .AND. NSPLIT.GT.1 ) THEN 14079 DO 150 JE = 1, M - 1 14080 IE = 0 14081 TMP1 = W( JE ) 14082 DO 140 J = JE + 1, M 14083 IF( W( J ).LT.TMP1 ) THEN 14084 IE = J 14085 TMP1 = W( J ) 14086 END IF 14087 140 CONTINUE 14088 IF( IE.NE.0 ) THEN 14089 TMP2 = WERR( IE ) 14090 ITMP1 = IBLOCK( IE ) 14091 ITMP2 = INDEXW( IE ) 14092 W( IE ) = W( JE ) 14093 WERR( IE ) = WERR( JE ) 14094 IBLOCK( IE ) = IBLOCK( JE ) 14095 INDEXW( IE ) = INDEXW( JE ) 14096 W( JE ) = TMP1 14097 WERR( JE ) = TMP2 14098 IBLOCK( JE ) = ITMP1 14099 INDEXW( JE ) = ITMP2 14100 END IF 14101 150 CONTINUE 14102 END IF 14103 INFO = 0 14104 IF( NCNVRG ) 14105 $ INFO = INFO + 1 14106 IF( TOOFEW ) 14107 $ INFO = INFO + 2 14108 RETURN 14109 END 14110! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarre.f 14111 SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, 14112 $ RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, 14113 $ W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, 14114 $ WORK, IWORK, INFO ) 14115 CHARACTER RANGE 14116 INTEGER IL, INFO, IU, M, N, NSPLIT 14117 DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU 14118 INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ), 14119 $ INDEXW( * ) 14120 DOUBLE PRECISION D( * ), E( * ), E2( * ), GERS( * ), 14121 $ W( * ),WERR( * ), WGAP( * ), WORK( * ) 14122 DOUBLE PRECISION FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD, 14123 $ MAXGROWTH, ONE, PERT, TWO, ZERO 14124 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, 14125 $ TWO = 2.0D0, FOUR=4.0D0, 14126 $ HNDRD = 100.0D0, 14127 $ PERT = 8.0D0, 14128 $ HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF, 14129 $ MAXGROWTH = 64.0D0, FUDGE = 2.0D0 ) 14130 INTEGER MAXTRY, ALLRNG, INDRNG, VALRNG 14131 PARAMETER ( MAXTRY = 6, ALLRNG = 1, INDRNG = 2, 14132 $ VALRNG = 3 ) 14133 LOGICAL FORCEB, NOREP, USEDQD 14134 INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO, 14135 $ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM, 14136 $ WBEGIN, WEND 14137 DOUBLE PRECISION AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS, 14138 $ EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL, 14139 $ RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM, 14140 $ TAU, TMP, TMP1 14141 INTEGER ISEED( 4 ) 14142 LOGICAL LSAME 14143 DOUBLE PRECISION DLAMCH 14144 EXTERNAL DLAMCH, LSAME 14145 EXTERNAL DCOPY, DLARNV, DLARRA, DLARRB, DLARRC, DLARRD, 14146 $ DLASQ2, DLARRK 14147 INTRINSIC ABS, MAX, MIN 14148 INFO = 0 14149 IF( N.LE.0 ) THEN 14150 RETURN 14151 END IF 14152 IF( LSAME( RANGE, 'A' ) ) THEN 14153 IRANGE = ALLRNG 14154 ELSE IF( LSAME( RANGE, 'V' ) ) THEN 14155 IRANGE = VALRNG 14156 ELSE IF( LSAME( RANGE, 'I' ) ) THEN 14157 IRANGE = INDRNG 14158 END IF 14159 M = 0 14160 SAFMIN = DLAMCH( 'S' ) 14161 EPS = DLAMCH( 'P' ) 14162 RTL = SQRT(EPS) 14163 BSRTOL = SQRT(EPS) 14164 IF( N.EQ.1 ) THEN 14165 IF( (IRANGE.EQ.ALLRNG).OR. 14166 $ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR. 14167 $ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN 14168 M = 1 14169 W(1) = D(1) 14170 WERR(1) = ZERO 14171 WGAP(1) = ZERO 14172 IBLOCK( 1 ) = 1 14173 INDEXW( 1 ) = 1 14174 GERS(1) = D( 1 ) 14175 GERS(2) = D( 1 ) 14176 ENDIF 14177 E(1) = ZERO 14178 RETURN 14179 END IF 14180 GL = D(1) 14181 GU = D(1) 14182 EOLD = ZERO 14183 EMAX = ZERO 14184 E(N) = ZERO 14185 DO 5 I = 1,N 14186 WERR(I) = ZERO 14187 WGAP(I) = ZERO 14188 EABS = ABS( E(I) ) 14189 IF( EABS .GE. EMAX ) THEN 14190 EMAX = EABS 14191 END IF 14192 TMP1 = EABS + EOLD 14193 GERS( 2*I-1) = D(I) - TMP1 14194 GL = MIN( GL, GERS( 2*I - 1)) 14195 GERS( 2*I ) = D(I) + TMP1 14196 GU = MAX( GU, GERS(2*I) ) 14197 EOLD = EABS 14198 5 CONTINUE 14199 PIVMIN = SAFMIN * MAX( ONE, EMAX**2 ) 14200 SPDIAM = GU - GL 14201 CALL DLARRA( N, D, E, E2, SPLTOL, SPDIAM, 14202 $ NSPLIT, ISPLIT, IINFO ) 14203 FORCEB = .FALSE. 14204 USEDQD = (( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB)) 14205 IF( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ) THEN 14206 VL = GL 14207 VU = GU 14208 ELSE 14209 CALL DLARRD( RANGE, 'B', N, VL, VU, IL, IU, GERS, 14210 $ BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, 14211 $ MM, W, WERR, VL, VU, IBLOCK, INDEXW, 14212 $ WORK, IWORK, IINFO ) 14213 IF( IINFO.NE.0 ) THEN 14214 INFO = -1 14215 RETURN 14216 ENDIF 14217 DO 14 I = MM+1,N 14218 W( I ) = ZERO 14219 WERR( I ) = ZERO 14220 IBLOCK( I ) = 0 14221 INDEXW( I ) = 0 14222 14 CONTINUE 14223 END IF 14224 IBEGIN = 1 14225 WBEGIN = 1 14226 DO 170 JBLK = 1, NSPLIT 14227 IEND = ISPLIT( JBLK ) 14228 IN = IEND - IBEGIN + 1 14229 IF( IN.EQ.1 ) THEN 14230 IF( (IRANGE.EQ.ALLRNG).OR.( (IRANGE.EQ.VALRNG).AND. 14231 $ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) ) 14232 $ .OR. ( (IRANGE.EQ.INDRNG).AND.(IBLOCK(WBEGIN).EQ.JBLK)) 14233 $ ) THEN 14234 M = M + 1 14235 W( M ) = D( IBEGIN ) 14236 WERR(M) = ZERO 14237 WGAP(M) = ZERO 14238 IBLOCK( M ) = JBLK 14239 INDEXW( M ) = 1 14240 WBEGIN = WBEGIN + 1 14241 ENDIF 14242 E( IEND ) = ZERO 14243 IBEGIN = IEND + 1 14244 GO TO 170 14245 END IF 14246 E( IEND ) = ZERO 14247 GL = D(IBEGIN) 14248 GU = D(IBEGIN) 14249 DO 15 I = IBEGIN , IEND 14250 GL = MIN( GERS( 2*I-1 ), GL ) 14251 GU = MAX( GERS( 2*I ), GU ) 14252 15 CONTINUE 14253 SPDIAM = GU - GL 14254 IF(.NOT. ((IRANGE.EQ.ALLRNG).AND.(.NOT.FORCEB)) ) THEN 14255 MB = 0 14256 DO 20 I = WBEGIN,MM 14257 IF( IBLOCK(I).EQ.JBLK ) THEN 14258 MB = MB+1 14259 ELSE 14260 GOTO 21 14261 ENDIF 14262 20 CONTINUE 14263 21 CONTINUE 14264 IF( MB.EQ.0) THEN 14265 E( IEND ) = ZERO 14266 IBEGIN = IEND + 1 14267 GO TO 170 14268 ELSE 14269 USEDQD = ( (MB .GT. FAC*IN) .AND. (.NOT.FORCEB) ) 14270 WEND = WBEGIN + MB - 1 14271 SIGMA = ZERO 14272 DO 30 I = WBEGIN, WEND - 1 14273 WGAP( I ) = MAX( ZERO, 14274 $ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) ) 14275 30 CONTINUE 14276 WGAP( WEND ) = MAX( ZERO, 14277 $ VU - SIGMA - (W( WEND )+WERR( WEND ))) 14278 INDL = INDEXW(WBEGIN) 14279 INDU = INDEXW( WEND ) 14280 ENDIF 14281 ENDIF 14282 IF(( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN 14283 CALL DLARRK( IN, 1, GL, GU, D(IBEGIN), 14284 $ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO ) 14285 IF( IINFO.NE.0 ) THEN 14286 INFO = -1 14287 RETURN 14288 ENDIF 14289 ISLEFT = MAX(GL, TMP - TMP1 14290 $ - HNDRD * EPS* ABS(TMP - TMP1)) 14291 CALL DLARRK( IN, IN, GL, GU, D(IBEGIN), 14292 $ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO ) 14293 IF( IINFO.NE.0 ) THEN 14294 INFO = -1 14295 RETURN 14296 ENDIF 14297 ISRGHT = MIN(GU, TMP + TMP1 14298 $ + HNDRD * EPS * ABS(TMP + TMP1)) 14299 SPDIAM = ISRGHT - ISLEFT 14300 ELSE 14301 ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN) 14302 $ - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) )) 14303 ISRGHT = MIN(GU,W(WEND) + WERR(WEND) 14304 $ + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND))) 14305 ENDIF 14306 IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN 14307 USEDQD = .TRUE. 14308 INDL = 1 14309 INDU = IN 14310 MB = IN 14311 WEND = WBEGIN + MB - 1 14312 S1 = ISLEFT + FOURTH * SPDIAM 14313 S2 = ISRGHT - FOURTH * SPDIAM 14314 ELSE 14315 IF( USEDQD ) THEN 14316 S1 = ISLEFT + FOURTH * SPDIAM 14317 S2 = ISRGHT - FOURTH * SPDIAM 14318 ELSE 14319 TMP = MIN(ISRGHT,VU) - MAX(ISLEFT,VL) 14320 S1 = MAX(ISLEFT,VL) + FOURTH * TMP 14321 S2 = MIN(ISRGHT,VU) - FOURTH * TMP 14322 ENDIF 14323 ENDIF 14324 IF(MB.GT.1) THEN 14325 CALL DLARRC( 'T', IN, S1, S2, D(IBEGIN), 14326 $ E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO) 14327 ENDIF 14328 IF(MB.EQ.1) THEN 14329 SIGMA = GL 14330 SGNDEF = ONE 14331 ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN 14332 IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN 14333 SIGMA = MAX(ISLEFT,GL) 14334 ELSEIF( USEDQD ) THEN 14335 SIGMA = ISLEFT 14336 ELSE 14337 SIGMA = MAX(ISLEFT,VL) 14338 ENDIF 14339 SGNDEF = ONE 14340 ELSE 14341 IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN 14342 SIGMA = MIN(ISRGHT,GU) 14343 ELSEIF( USEDQD ) THEN 14344 SIGMA = ISRGHT 14345 ELSE 14346 SIGMA = MIN(ISRGHT,VU) 14347 ENDIF 14348 SGNDEF = -ONE 14349 ENDIF 14350 IF( USEDQD ) THEN 14351 TAU = SPDIAM*EPS*N + TWO*PIVMIN 14352 TAU = MAX( TAU,TWO*EPS*ABS(SIGMA) ) 14353 ELSE 14354 IF(MB.GT.1) THEN 14355 CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN) 14356 AVGAP = ABS(CLWDTH / DBLE(WEND-WBEGIN)) 14357 IF( SGNDEF.EQ.ONE ) THEN 14358 TAU = HALF*MAX(WGAP(WBEGIN),AVGAP) 14359 TAU = MAX(TAU,WERR(WBEGIN)) 14360 ELSE 14361 TAU = HALF*MAX(WGAP(WEND-1),AVGAP) 14362 TAU = MAX(TAU,WERR(WEND)) 14363 ENDIF 14364 ELSE 14365 TAU = WERR(WBEGIN) 14366 ENDIF 14367 ENDIF 14368 DO 80 IDUM = 1, MAXTRY 14369 DPIVOT = D( IBEGIN ) - SIGMA 14370 WORK( 1 ) = DPIVOT 14371 DMAX = ABS( WORK(1) ) 14372 J = IBEGIN 14373 DO 70 I = 1, IN - 1 14374 WORK( 2*IN+I ) = ONE / WORK( I ) 14375 TMP = E( J )*WORK( 2*IN+I ) 14376 WORK( IN+I ) = TMP 14377 DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J ) 14378 WORK( I+1 ) = DPIVOT 14379 DMAX = MAX( DMAX, ABS(DPIVOT) ) 14380 J = J + 1 14381 70 CONTINUE 14382 IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN 14383 NOREP = .TRUE. 14384 ELSE 14385 NOREP = .FALSE. 14386 ENDIF 14387 IF( USEDQD .AND. .NOT.NOREP ) THEN 14388 DO 71 I = 1, IN 14389 TMP = SGNDEF*WORK( I ) 14390 IF( TMP.LT.ZERO ) NOREP = .TRUE. 14391 71 CONTINUE 14392 ENDIF 14393 IF(NOREP) THEN 14394 IF( IDUM.EQ.MAXTRY-1 ) THEN 14395 IF( SGNDEF.EQ.ONE ) THEN 14396 SIGMA = 14397 $ GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN 14398 ELSE 14399 SIGMA = 14400 $ GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN 14401 END IF 14402 ELSE 14403 SIGMA = SIGMA - SGNDEF * TAU 14404 TAU = TWO * TAU 14405 END IF 14406 ELSE 14407 GO TO 83 14408 END IF 14409 80 CONTINUE 14410 INFO = 2 14411 RETURN 14412 83 CONTINUE 14413 E( IEND ) = SIGMA 14414 CALL DCOPY( IN, WORK, 1, D( IBEGIN ), 1 ) 14415 CALL DCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 ) 14416 IF(MB.GT.1 ) THEN 14417 DO 122 I = 1, 4 14418 ISEED( I ) = 1 14419 122 CONTINUE 14420 CALL DLARNV(2, ISEED, 2*IN-1, WORK(1)) 14421 DO 125 I = 1,IN-1 14422 D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(I)) 14423 E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(IN+I)) 14424 125 CONTINUE 14425 D(IEND) = D(IEND)*(ONE+EPS*FOUR*WORK(IN)) 14426 ENDIF 14427 IF ( .NOT.USEDQD ) THEN 14428 DO 134 J=WBEGIN,WEND 14429 W(J) = W(J) - SIGMA 14430 WERR(J) = WERR(J) + ABS(W(J)) * EPS 14431 134 CONTINUE 14432 DO 135 I = IBEGIN, IEND-1 14433 WORK( I ) = D( I ) * E( I )**2 14434 135 CONTINUE 14435 CALL DLARRB(IN, D(IBEGIN), WORK(IBEGIN), 14436 $ INDL, INDU, RTOL1, RTOL2, INDL-1, 14437 $ W(WBEGIN), WGAP(WBEGIN), WERR(WBEGIN), 14438 $ WORK( 2*N+1 ), IWORK, PIVMIN, SPDIAM, 14439 $ IN, IINFO ) 14440 IF( IINFO .NE. 0 ) THEN 14441 INFO = -4 14442 RETURN 14443 END IF 14444 WGAP( WEND ) = MAX( ZERO, 14445 $ ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) ) 14446 DO 138 I = INDL, INDU 14447 M = M + 1 14448 IBLOCK(M) = JBLK 14449 INDEXW(M) = I 14450 138 CONTINUE 14451 ELSE 14452 RTOL = LOG(DBLE(IN)) * FOUR * EPS 14453 J = IBEGIN 14454 DO 140 I = 1, IN - 1 14455 WORK( 2*I-1 ) = ABS( D( J ) ) 14456 WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 ) 14457 J = J + 1 14458 140 CONTINUE 14459 WORK( 2*IN-1 ) = ABS( D( IEND ) ) 14460 WORK( 2*IN ) = ZERO 14461 CALL DLASQ2( IN, WORK, IINFO ) 14462 IF( IINFO .NE. 0 ) THEN 14463 INFO = -5 14464 RETURN 14465 ELSE 14466 DO 149 I = 1, IN 14467 IF( WORK( I ).LT.ZERO ) THEN 14468 INFO = -6 14469 RETURN 14470 ENDIF 14471 149 CONTINUE 14472 END IF 14473 IF( SGNDEF.GT.ZERO ) THEN 14474 DO 150 I = INDL, INDU 14475 M = M + 1 14476 W( M ) = WORK( IN-I+1 ) 14477 IBLOCK( M ) = JBLK 14478 INDEXW( M ) = I 14479 150 CONTINUE 14480 ELSE 14481 DO 160 I = INDL, INDU 14482 M = M + 1 14483 W( M ) = -WORK( I ) 14484 IBLOCK( M ) = JBLK 14485 INDEXW( M ) = I 14486 160 CONTINUE 14487 END IF 14488 DO 165 I = M - MB + 1, M 14489 WERR( I ) = RTOL * ABS( W(I) ) 14490 165 CONTINUE 14491 DO 166 I = M - MB + 1, M - 1 14492 WGAP( I ) = MAX( ZERO, 14493 $ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) ) 14494 166 CONTINUE 14495 WGAP( M ) = MAX( ZERO, 14496 $ ( VU-SIGMA ) - ( W( M ) + WERR( M ) ) ) 14497 END IF 14498 IBEGIN = IEND + 1 14499 WBEGIN = WEND + 1 14500 170 CONTINUE 14501 RETURN 14502 END 14503! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarrf.f 14504 SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND, 14505 $ W, WGAP, WERR, 14506 $ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, 14507 $ DPLUS, LPLUS, WORK, INFO ) 14508 INTEGER CLSTRT, CLEND, INFO, N 14509 DOUBLE PRECISION CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM 14510 DOUBLE PRECISION D( * ), DPLUS( * ), L( * ), LD( * ), 14511 $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * ) 14512 DOUBLE PRECISION FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO 14513 PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, FOUR = 4.0D0, 14514 $ QUART = 0.25D0, 14515 $ MAXGROWTH1 = 8.D0, 14516 $ MAXGROWTH2 = 8.D0 ) 14517 LOGICAL DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1 14518 INTEGER I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT 14519 PARAMETER ( KTRYMAX = 1, SLEFT = 1, SRIGHT = 2 ) 14520 DOUBLE PRECISION AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL, 14521 $ FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA, 14522 $ MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX, 14523 $ RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2 14524 LOGICAL DISNAN 14525 DOUBLE PRECISION DLAMCH 14526 EXTERNAL DISNAN, DLAMCH 14527 EXTERNAL DCOPY 14528 INTRINSIC ABS 14529 INFO = 0 14530 IF( N.LE.0 ) THEN 14531 RETURN 14532 END IF 14533 FACT = DBLE(2**KTRYMAX) 14534 EPS = DLAMCH( 'Precision' ) 14535 SHIFT = 0 14536 FORCER = .FALSE. 14537 NOFAIL = .FALSE. 14538 CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT) 14539 AVGAP = CLWDTH / DBLE(CLEND-CLSTRT) 14540 MINGAP = MIN(CLGAPL, CLGAPR) 14541 LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT ) 14542 RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND ) 14543 LSIGMA = LSIGMA - ABS(LSIGMA)* FOUR * EPS 14544 RSIGMA = RSIGMA + ABS(RSIGMA)* FOUR * EPS 14545 LDMAX = QUART * MINGAP + TWO * PIVMIN 14546 RDMAX = QUART * MINGAP + TWO * PIVMIN 14547 LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT 14548 RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT 14549 S = DLAMCH( 'S' ) 14550 SMLGROWTH = ONE / S 14551 FAIL = DBLE(N-1)*MINGAP/(SPDIAM*EPS) 14552 FAIL2 = DBLE(N-1)*MINGAP/(SPDIAM*SQRT(EPS)) 14553 BESTSHIFT = LSIGMA 14554 KTRY = 0 14555 GROWTHBOUND = MAXGROWTH1*SPDIAM 14556 5 CONTINUE 14557 SAWNAN1 = .FALSE. 14558 SAWNAN2 = .FALSE. 14559 LDELTA = MIN(LDMAX,LDELTA) 14560 RDELTA = MIN(RDMAX,RDELTA) 14561 S = -LSIGMA 14562 DPLUS( 1 ) = D( 1 ) + S 14563 IF(ABS(DPLUS(1)).LT.PIVMIN) THEN 14564 DPLUS(1) = -PIVMIN 14565 SAWNAN1 = .TRUE. 14566 ENDIF 14567 MAX1 = ABS( DPLUS( 1 ) ) 14568 DO 6 I = 1, N - 1 14569 LPLUS( I ) = LD( I ) / DPLUS( I ) 14570 S = S*LPLUS( I )*L( I ) - LSIGMA 14571 DPLUS( I+1 ) = D( I+1 ) + S 14572 IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN 14573 DPLUS(I+1) = -PIVMIN 14574 SAWNAN1 = .TRUE. 14575 ENDIF 14576 MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) ) 14577 6 CONTINUE 14578 SAWNAN1 = SAWNAN1 .OR. DISNAN( MAX1 ) 14579 IF( FORCER .OR. 14580 $ (MAX1.LE.GROWTHBOUND .AND. .NOT.SAWNAN1 ) ) THEN 14581 SIGMA = LSIGMA 14582 SHIFT = SLEFT 14583 GOTO 100 14584 ENDIF 14585 S = -RSIGMA 14586 WORK( 1 ) = D( 1 ) + S 14587 IF(ABS(WORK(1)).LT.PIVMIN) THEN 14588 WORK(1) = -PIVMIN 14589 SAWNAN2 = .TRUE. 14590 ENDIF 14591 MAX2 = ABS( WORK( 1 ) ) 14592 DO 7 I = 1, N - 1 14593 WORK( N+I ) = LD( I ) / WORK( I ) 14594 S = S*WORK( N+I )*L( I ) - RSIGMA 14595 WORK( I+1 ) = D( I+1 ) + S 14596 IF(ABS(WORK(I+1)).LT.PIVMIN) THEN 14597 WORK(I+1) = -PIVMIN 14598 SAWNAN2 = .TRUE. 14599 ENDIF 14600 MAX2 = MAX( MAX2,ABS(WORK(I+1)) ) 14601 7 CONTINUE 14602 SAWNAN2 = SAWNAN2 .OR. DISNAN( MAX2 ) 14603 IF( FORCER .OR. 14604 $ (MAX2.LE.GROWTHBOUND .AND. .NOT.SAWNAN2 ) ) THEN 14605 SIGMA = RSIGMA 14606 SHIFT = SRIGHT 14607 GOTO 100 14608 ENDIF 14609 IF(SAWNAN1.AND.SAWNAN2) THEN 14610 GOTO 50 14611 ELSE 14612 IF( .NOT.SAWNAN1 ) THEN 14613 INDX = 1 14614 IF(MAX1.LE.SMLGROWTH) THEN 14615 SMLGROWTH = MAX1 14616 BESTSHIFT = LSIGMA 14617 ENDIF 14618 ENDIF 14619 IF( .NOT.SAWNAN2 ) THEN 14620 IF(SAWNAN1 .OR. MAX2.LE.MAX1) INDX = 2 14621 IF(MAX2.LE.SMLGROWTH) THEN 14622 SMLGROWTH = MAX2 14623 BESTSHIFT = RSIGMA 14624 ENDIF 14625 ENDIF 14626 ENDIF 14627 IF((CLWDTH.LT.MINGAP/DBLE(128)) .AND. 14628 $ (MIN(MAX1,MAX2).LT.FAIL2) 14629 $ .AND.(.NOT.SAWNAN1).AND.(.NOT.SAWNAN2)) THEN 14630 DORRR1 = .TRUE. 14631 ELSE 14632 DORRR1 = .FALSE. 14633 ENDIF 14634 TRYRRR1 = .TRUE. 14635 IF( TRYRRR1 .AND. DORRR1 ) THEN 14636 IF(INDX.EQ.1) THEN 14637 TMP = ABS( DPLUS( N ) ) 14638 ZNM2 = ONE 14639 PROD = ONE 14640 OLDP = ONE 14641 DO 15 I = N-1, 1, -1 14642 IF( PROD .LE. EPS ) THEN 14643 PROD = 14644 $ ((DPLUS(I+1)*WORK(N+I+1))/(DPLUS(I)*WORK(N+I)))*OLDP 14645 ELSE 14646 PROD = PROD*ABS(WORK(N+I)) 14647 END IF 14648 OLDP = PROD 14649 ZNM2 = ZNM2 + PROD**2 14650 TMP = MAX( TMP, ABS( DPLUS( I ) * PROD )) 14651 15 CONTINUE 14652 RRR1 = TMP/( SPDIAM * SQRT( ZNM2 ) ) 14653 IF (RRR1.LE.MAXGROWTH2) THEN 14654 SIGMA = LSIGMA 14655 SHIFT = SLEFT 14656 GOTO 100 14657 ENDIF 14658 ELSE IF(INDX.EQ.2) THEN 14659 TMP = ABS( WORK( N ) ) 14660 ZNM2 = ONE 14661 PROD = ONE 14662 OLDP = ONE 14663 DO 16 I = N-1, 1, -1 14664 IF( PROD .LE. EPS ) THEN 14665 PROD = ((WORK(I+1)*LPLUS(I+1))/(WORK(I)*LPLUS(I)))*OLDP 14666 ELSE 14667 PROD = PROD*ABS(LPLUS(I)) 14668 END IF 14669 OLDP = PROD 14670 ZNM2 = ZNM2 + PROD**2 14671 TMP = MAX( TMP, ABS( WORK( I ) * PROD )) 14672 16 CONTINUE 14673 RRR2 = TMP/( SPDIAM * SQRT( ZNM2 ) ) 14674 IF (RRR2.LE.MAXGROWTH2) THEN 14675 SIGMA = RSIGMA 14676 SHIFT = SRIGHT 14677 GOTO 100 14678 ENDIF 14679 END IF 14680 ENDIF 14681 50 CONTINUE 14682 IF (KTRY.LT.KTRYMAX) THEN 14683 LSIGMA = MAX( LSIGMA - LDELTA, 14684 $ LSIGMA - LDMAX) 14685 RSIGMA = MIN( RSIGMA + RDELTA, 14686 $ RSIGMA + RDMAX ) 14687 LDELTA = TWO * LDELTA 14688 RDELTA = TWO * RDELTA 14689 KTRY = KTRY + 1 14690 GOTO 5 14691 ELSE 14692 IF((SMLGROWTH.LT.FAIL).OR.NOFAIL) THEN 14693 LSIGMA = BESTSHIFT 14694 RSIGMA = BESTSHIFT 14695 FORCER = .TRUE. 14696 GOTO 5 14697 ELSE 14698 INFO = 1 14699 RETURN 14700 ENDIF 14701 END IF 14702 100 CONTINUE 14703 IF (SHIFT.EQ.SLEFT) THEN 14704 ELSEIF (SHIFT.EQ.SRIGHT) THEN 14705 CALL DCOPY( N, WORK, 1, DPLUS, 1 ) 14706 CALL DCOPY( N-1, WORK(N+1), 1, LPLUS, 1 ) 14707 ENDIF 14708 RETURN 14709 END 14710! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarrj.f 14711 SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST, 14712 $ RTOL, OFFSET, W, WERR, WORK, IWORK, 14713 $ PIVMIN, SPDIAM, INFO ) 14714 INTEGER IFIRST, ILAST, INFO, N, OFFSET 14715 DOUBLE PRECISION PIVMIN, RTOL, SPDIAM 14716 INTEGER IWORK( * ) 14717 DOUBLE PRECISION D( * ), E2( * ), W( * ), 14718 $ WERR( * ), WORK( * ) 14719 DOUBLE PRECISION ZERO, ONE, TWO, HALF 14720 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 14721 $ HALF = 0.5D0 ) 14722 INTEGER MAXITR 14723 INTEGER CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT, 14724 $ OLNINT, P, PREV, SAVI1 14725 DOUBLE PRECISION DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH 14726 INTRINSIC ABS, MAX 14727 INFO = 0 14728 IF( N.LE.0 ) THEN 14729 RETURN 14730 END IF 14731 MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) / 14732 $ LOG( TWO ) ) + 2 14733 I1 = IFIRST 14734 I2 = ILAST 14735 NINT = 0 14736 PREV = 0 14737 DO 75 I = I1, I2 14738 K = 2*I 14739 II = I - OFFSET 14740 LEFT = W( II ) - WERR( II ) 14741 MID = W(II) 14742 RIGHT = W( II ) + WERR( II ) 14743 WIDTH = RIGHT - MID 14744 TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) 14745 IF( WIDTH.LT.RTOL*TMP ) THEN 14746 IWORK( K-1 ) = -1 14747 IF((I.EQ.I1).AND.(I.LT.I2)) I1 = I + 1 14748 IF((PREV.GE.I1).AND.(I.LE.I2)) IWORK( 2*PREV-1 ) = I + 1 14749 ELSE 14750 PREV = I 14751 FAC = ONE 14752 20 CONTINUE 14753 CNT = 0 14754 S = LEFT 14755 DPLUS = D( 1 ) - S 14756 IF( DPLUS.LT.ZERO ) CNT = CNT + 1 14757 DO 30 J = 2, N 14758 DPLUS = D( J ) - S - E2( J-1 )/DPLUS 14759 IF( DPLUS.LT.ZERO ) CNT = CNT + 1 14760 30 CONTINUE 14761 IF( CNT.GT.I-1 ) THEN 14762 LEFT = LEFT - WERR( II )*FAC 14763 FAC = TWO*FAC 14764 GO TO 20 14765 END IF 14766 FAC = ONE 14767 50 CONTINUE 14768 CNT = 0 14769 S = RIGHT 14770 DPLUS = D( 1 ) - S 14771 IF( DPLUS.LT.ZERO ) CNT = CNT + 1 14772 DO 60 J = 2, N 14773 DPLUS = D( J ) - S - E2( J-1 )/DPLUS 14774 IF( DPLUS.LT.ZERO ) CNT = CNT + 1 14775 60 CONTINUE 14776 IF( CNT.LT.I ) THEN 14777 RIGHT = RIGHT + WERR( II )*FAC 14778 FAC = TWO*FAC 14779 GO TO 50 14780 END IF 14781 NINT = NINT + 1 14782 IWORK( K-1 ) = I + 1 14783 IWORK( K ) = CNT 14784 END IF 14785 WORK( K-1 ) = LEFT 14786 WORK( K ) = RIGHT 14787 75 CONTINUE 14788 SAVI1 = I1 14789 ITER = 0 14790 80 CONTINUE 14791 PREV = I1 - 1 14792 I = I1 14793 OLNINT = NINT 14794 DO 100 P = 1, OLNINT 14795 K = 2*I 14796 II = I - OFFSET 14797 NEXT = IWORK( K-1 ) 14798 LEFT = WORK( K-1 ) 14799 RIGHT = WORK( K ) 14800 MID = HALF*( LEFT + RIGHT ) 14801 WIDTH = RIGHT - MID 14802 TMP = MAX( ABS( LEFT ), ABS( RIGHT ) ) 14803 IF( ( WIDTH.LT.RTOL*TMP ) .OR. 14804 $ (ITER.EQ.MAXITR) )THEN 14805 NINT = NINT - 1 14806 IWORK( K-1 ) = 0 14807 IF( I1.EQ.I ) THEN 14808 I1 = NEXT 14809 ELSE 14810 IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT 14811 END IF 14812 I = NEXT 14813 GO TO 100 14814 END IF 14815 PREV = I 14816 CNT = 0 14817 S = MID 14818 DPLUS = D( 1 ) - S 14819 IF( DPLUS.LT.ZERO ) CNT = CNT + 1 14820 DO 90 J = 2, N 14821 DPLUS = D( J ) - S - E2( J-1 )/DPLUS 14822 IF( DPLUS.LT.ZERO ) CNT = CNT + 1 14823 90 CONTINUE 14824 IF( CNT.LE.I-1 ) THEN 14825 WORK( K-1 ) = MID 14826 ELSE 14827 WORK( K ) = MID 14828 END IF 14829 I = NEXT 14830 100 CONTINUE 14831 ITER = ITER + 1 14832 IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80 14833 DO 110 I = SAVI1, ILAST 14834 K = 2*I 14835 II = I - OFFSET 14836 IF( IWORK( K-1 ).EQ.0 ) THEN 14837 W( II ) = HALF*( WORK( K-1 )+WORK( K ) ) 14838 WERR( II ) = WORK( K ) - W( II ) 14839 END IF 14840 110 CONTINUE 14841 RETURN 14842 END 14843! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarrk.f 14844 SUBROUTINE DLARRK( N, IW, GL, GU, 14845 $ D, E2, PIVMIN, RELTOL, W, WERR, INFO) 14846 INTEGER INFO, IW, N 14847 DOUBLE PRECISION PIVMIN, RELTOL, GL, GU, W, WERR 14848 DOUBLE PRECISION D( * ), E2( * ) 14849 DOUBLE PRECISION FUDGE, HALF, TWO, ZERO 14850 PARAMETER ( HALF = 0.5D0, TWO = 2.0D0, 14851 $ FUDGE = TWO, ZERO = 0.0D0 ) 14852 INTEGER I, IT, ITMAX, NEGCNT 14853 DOUBLE PRECISION ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1, 14854 $ TMP2, TNORM 14855 DOUBLE PRECISION DLAMCH 14856 EXTERNAL DLAMCH 14857 INTRINSIC ABS, INT, LOG, MAX 14858 IF( N.LE.0 ) THEN 14859 INFO = 0 14860 RETURN 14861 END IF 14862 EPS = DLAMCH( 'P' ) 14863 TNORM = MAX( ABS( GL ), ABS( GU ) ) 14864 RTOLI = RELTOL 14865 ATOLI = FUDGE*TWO*PIVMIN 14866 ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / 14867 $ LOG( TWO ) ) + 2 14868 INFO = -1 14869 LEFT = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN 14870 RIGHT = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN 14871 IT = 0 14872 10 CONTINUE 14873 TMP1 = ABS( RIGHT - LEFT ) 14874 TMP2 = MAX( ABS(RIGHT), ABS(LEFT) ) 14875 IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) ) THEN 14876 INFO = 0 14877 GOTO 30 14878 ENDIF 14879 IF(IT.GT.ITMAX) 14880 $ GOTO 30 14881 IT = IT + 1 14882 MID = HALF * (LEFT + RIGHT) 14883 NEGCNT = 0 14884 TMP1 = D( 1 ) - MID 14885 IF( ABS( TMP1 ).LT.PIVMIN ) 14886 $ TMP1 = -PIVMIN 14887 IF( TMP1.LE.ZERO ) 14888 $ NEGCNT = NEGCNT + 1 14889 DO 20 I = 2, N 14890 TMP1 = D( I ) - E2( I-1 ) / TMP1 - MID 14891 IF( ABS( TMP1 ).LT.PIVMIN ) 14892 $ TMP1 = -PIVMIN 14893 IF( TMP1.LE.ZERO ) 14894 $ NEGCNT = NEGCNT + 1 14895 20 CONTINUE 14896 IF(NEGCNT.GE.IW) THEN 14897 RIGHT = MID 14898 ELSE 14899 LEFT = MID 14900 ENDIF 14901 GOTO 10 14902 30 CONTINUE 14903 W = HALF * (LEFT + RIGHT) 14904 WERR = HALF * ABS( RIGHT - LEFT ) 14905 RETURN 14906 END 14907! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarrr.f 14908 SUBROUTINE DLARRR( N, D, E, INFO ) 14909 INTEGER N, INFO 14910 DOUBLE PRECISION D( * ), E( * ) 14911 DOUBLE PRECISION ZERO, RELCOND 14912 PARAMETER ( ZERO = 0.0D0, 14913 $ RELCOND = 0.999D0 ) 14914 INTEGER I 14915 LOGICAL YESREL 14916 DOUBLE PRECISION EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2, 14917 $ OFFDIG, OFFDIG2 14918 DOUBLE PRECISION DLAMCH 14919 EXTERNAL DLAMCH 14920 INTRINSIC ABS 14921 IF( N.LE.0 ) THEN 14922 INFO = 0 14923 RETURN 14924 END IF 14925 INFO = 1 14926 SAFMIN = DLAMCH( 'Safe minimum' ) 14927 EPS = DLAMCH( 'Precision' ) 14928 SMLNUM = SAFMIN / EPS 14929 RMIN = SQRT( SMLNUM ) 14930 YESREL = .TRUE. 14931 OFFDIG = ZERO 14932 TMP = SQRT(ABS(D(1))) 14933 IF (TMP.LT.RMIN) YESREL = .FALSE. 14934 IF(.NOT.YESREL) GOTO 11 14935 DO 10 I = 2, N 14936 TMP2 = SQRT(ABS(D(I))) 14937 IF (TMP2.LT.RMIN) YESREL = .FALSE. 14938 IF(.NOT.YESREL) GOTO 11 14939 OFFDIG2 = ABS(E(I-1))/(TMP*TMP2) 14940 IF(OFFDIG+OFFDIG2.GE.RELCOND) YESREL = .FALSE. 14941 IF(.NOT.YESREL) GOTO 11 14942 TMP = TMP2 14943 OFFDIG = OFFDIG2 14944 10 CONTINUE 14945 11 CONTINUE 14946 IF( YESREL ) THEN 14947 INFO = 0 14948 RETURN 14949 ELSE 14950 ENDIF 14951 RETURN 14952 END 14953! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlarrv.f 14954 SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN, 14955 $ ISPLIT, M, DOL, DOU, MINRGP, 14956 $ RTOL1, RTOL2, W, WERR, WGAP, 14957 $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, 14958 $ WORK, IWORK, INFO ) 14959 INTEGER DOL, DOU, INFO, LDZ, M, N 14960 DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU 14961 INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ), 14962 $ ISUPPZ( * ), IWORK( * ) 14963 DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ), 14964 $ WGAP( * ), WORK( * ) 14965 DOUBLE PRECISION Z( LDZ, * ) 14966 INTEGER MAXITR 14967 PARAMETER ( MAXITR = 10 ) 14968 DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, HALF 14969 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, 14970 $ TWO = 2.0D0, THREE = 3.0D0, 14971 $ FOUR = 4.0D0, HALF = 0.5D0) 14972 LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ 14973 INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1, 14974 $ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG, 14975 $ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER, 14976 $ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS, 14977 $ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST, 14978 $ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST, 14979 $ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX, 14980 $ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU, 14981 $ ZUSEDW 14982 DOUBLE PRECISION BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU, 14983 $ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID, 14984 $ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF, 14985 $ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ 14986 DOUBLE PRECISION DLAMCH 14987 EXTERNAL DLAMCH 14988 EXTERNAL DCOPY, DLAR1V, DLARRB, DLARRF, DLASET, 14989 $ DSCAL 14990 INTRINSIC ABS, DBLE, MAX, MIN 14991 INFO = 0 14992 IF( N.LE.0 ) THEN 14993 RETURN 14994 END IF 14995 INDLD = N+1 14996 INDLLD= 2*N+1 14997 INDWRK= 3*N+1 14998 MINWSIZE = 12 * N 14999 DO 5 I= 1,MINWSIZE 15000 WORK( I ) = ZERO 15001 5 CONTINUE 15002 IINDR = 0 15003 IINDC1 = N 15004 IINDC2 = 2*N 15005 IINDWK = 3*N + 1 15006 MINIWSIZE = 7 * N 15007 DO 10 I= 1,MINIWSIZE 15008 IWORK( I ) = 0 15009 10 CONTINUE 15010 ZUSEDL = 1 15011 IF(DOL.GT.1) THEN 15012 ZUSEDL = DOL-1 15013 ENDIF 15014 ZUSEDU = M 15015 IF(DOU.LT.M) THEN 15016 ZUSEDU = DOU+1 15017 ENDIF 15018 ZUSEDW = ZUSEDU - ZUSEDL + 1 15019 CALL DLASET( 'Full', N, ZUSEDW, ZERO, ZERO, 15020 $ Z(1,ZUSEDL), LDZ ) 15021 EPS = DLAMCH( 'Precision' ) 15022 RQTOL = TWO * EPS 15023 TRYRQC = .TRUE. 15024 IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN 15025 ELSE 15026 RTOL1 = FOUR * EPS 15027 RTOL2 = FOUR * EPS 15028 ENDIF 15029 DONE = 0 15030 IBEGIN = 1 15031 WBEGIN = 1 15032 DO 170 JBLK = 1, IBLOCK( M ) 15033 IEND = ISPLIT( JBLK ) 15034 SIGMA = L( IEND ) 15035 WEND = WBEGIN - 1 15036 15 CONTINUE 15037 IF( WEND.LT.M ) THEN 15038 IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN 15039 WEND = WEND + 1 15040 GO TO 15 15041 END IF 15042 END IF 15043 IF( WEND.LT.WBEGIN ) THEN 15044 IBEGIN = IEND + 1 15045 GO TO 170 15046 ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN 15047 IBEGIN = IEND + 1 15048 WBEGIN = WEND + 1 15049 GO TO 170 15050 END IF 15051 GL = GERS( 2*IBEGIN-1 ) 15052 GU = GERS( 2*IBEGIN ) 15053 DO 20 I = IBEGIN+1 , IEND 15054 GL = MIN( GERS( 2*I-1 ), GL ) 15055 GU = MAX( GERS( 2*I ), GU ) 15056 20 CONTINUE 15057 SPDIAM = GU - GL 15058 OLDIEN = IBEGIN - 1 15059 IN = IEND - IBEGIN + 1 15060 IM = WEND - WBEGIN + 1 15061 IF( IBEGIN.EQ.IEND ) THEN 15062 DONE = DONE+1 15063 Z( IBEGIN, WBEGIN ) = ONE 15064 ISUPPZ( 2*WBEGIN-1 ) = IBEGIN 15065 ISUPPZ( 2*WBEGIN ) = IBEGIN 15066 W( WBEGIN ) = W( WBEGIN ) + SIGMA 15067 WORK( WBEGIN ) = W( WBEGIN ) 15068 IBEGIN = IEND + 1 15069 WBEGIN = WBEGIN + 1 15070 GO TO 170 15071 END IF 15072 CALL DCOPY( IM, W( WBEGIN ), 1, 15073 $ WORK( WBEGIN ), 1 ) 15074 DO 30 I=1,IM 15075 W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA 15076 30 CONTINUE 15077 NDEPTH = 0 15078 PARITY = 1 15079 NCLUS = 1 15080 IWORK( IINDC1+1 ) = 1 15081 IWORK( IINDC1+2 ) = IM 15082 IDONE = 0 15083 40 CONTINUE 15084 IF( IDONE.LT.IM ) THEN 15085 IF( NDEPTH.GT.M ) THEN 15086 INFO = -2 15087 RETURN 15088 ENDIF 15089 OLDNCL = NCLUS 15090 NCLUS = 0 15091 PARITY = 1 - PARITY 15092 IF( PARITY.EQ.0 ) THEN 15093 OLDCLS = IINDC1 15094 NEWCLS = IINDC2 15095 ELSE 15096 OLDCLS = IINDC2 15097 NEWCLS = IINDC1 15098 END IF 15099 DO 150 I = 1, OLDNCL 15100 J = OLDCLS + 2*I 15101 OLDFST = IWORK( J-1 ) 15102 OLDLST = IWORK( J ) 15103 IF( NDEPTH.GT.0 ) THEN 15104 IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN 15105 J = WBEGIN + OLDFST - 1 15106 ELSE 15107 IF(WBEGIN+OLDFST-1.LT.DOL) THEN 15108 J = DOL - 1 15109 ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN 15110 J = DOU 15111 ELSE 15112 J = WBEGIN + OLDFST - 1 15113 ENDIF 15114 ENDIF 15115 CALL DCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 ) 15116 CALL DCOPY( IN-1, Z( IBEGIN, J+1 ), 1, L( IBEGIN ), 15117 $ 1 ) 15118 SIGMA = Z( IEND, J+1 ) 15119 CALL DLASET( 'Full', IN, 2, ZERO, ZERO, 15120 $ Z( IBEGIN, J), LDZ ) 15121 END IF 15122 DO 50 J = IBEGIN, IEND-1 15123 TMP = D( J )*L( J ) 15124 WORK( INDLD-1+J ) = TMP 15125 WORK( INDLLD-1+J ) = TMP*L( J ) 15126 50 CONTINUE 15127 IF( NDEPTH.GT.0 ) THEN 15128 P = INDEXW( WBEGIN-1+OLDFST ) 15129 Q = INDEXW( WBEGIN-1+OLDLST ) 15130 OFFSET = INDEXW( WBEGIN ) - 1 15131 CALL DLARRB( IN, D( IBEGIN ), 15132 $ WORK(INDLLD+IBEGIN-1), 15133 $ P, Q, RTOL1, RTOL2, OFFSET, 15134 $ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN), 15135 $ WORK( INDWRK ), IWORK( IINDWK ), 15136 $ PIVMIN, SPDIAM, IN, IINFO ) 15137 IF( IINFO.NE.0 ) THEN 15138 INFO = -1 15139 RETURN 15140 ENDIF 15141 IF( OLDFST.GT.1) THEN 15142 WGAP( WBEGIN+OLDFST-2 ) = 15143 $ MAX(WGAP(WBEGIN+OLDFST-2), 15144 $ W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1) 15145 $ - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) ) 15146 ENDIF 15147 IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN 15148 WGAP( WBEGIN+OLDLST-1 ) = 15149 $ MAX(WGAP(WBEGIN+OLDLST-1), 15150 $ W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST) 15151 $ - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) ) 15152 ENDIF 15153 DO 53 J=OLDFST,OLDLST 15154 W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA 15155 53 CONTINUE 15156 END IF 15157 NEWFST = OLDFST 15158 DO 140 J = OLDFST, OLDLST 15159 IF( J.EQ.OLDLST ) THEN 15160 NEWLST = J 15161 ELSE IF ( WGAP( WBEGIN + J -1).GE. 15162 $ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN 15163 NEWLST = J 15164 ELSE 15165 GOTO 140 15166 END IF 15167 NEWSIZ = NEWLST - NEWFST + 1 15168 IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN 15169 NEWFTT = WBEGIN + NEWFST - 1 15170 ELSE 15171 IF(WBEGIN+NEWFST-1.LT.DOL) THEN 15172 NEWFTT = DOL - 1 15173 ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN 15174 NEWFTT = DOU 15175 ELSE 15176 NEWFTT = WBEGIN + NEWFST - 1 15177 ENDIF 15178 ENDIF 15179 IF( NEWSIZ.GT.1) THEN 15180 IF( NEWFST.EQ.1 ) THEN 15181 LGAP = MAX( ZERO, 15182 $ W(WBEGIN)-WERR(WBEGIN) - VL ) 15183 ELSE 15184 LGAP = WGAP( WBEGIN+NEWFST-2 ) 15185 ENDIF 15186 RGAP = WGAP( WBEGIN+NEWLST-1 ) 15187 DO 55 K =1,2 15188 IF(K.EQ.1) THEN 15189 P = INDEXW( WBEGIN-1+NEWFST ) 15190 ELSE 15191 P = INDEXW( WBEGIN-1+NEWLST ) 15192 ENDIF 15193 OFFSET = INDEXW( WBEGIN ) - 1 15194 CALL DLARRB( IN, D(IBEGIN), 15195 $ WORK( INDLLD+IBEGIN-1 ),P,P, 15196 $ RQTOL, RQTOL, OFFSET, 15197 $ WORK(WBEGIN),WGAP(WBEGIN), 15198 $ WERR(WBEGIN),WORK( INDWRK ), 15199 $ IWORK( IINDWK ), PIVMIN, SPDIAM, 15200 $ IN, IINFO ) 15201 55 CONTINUE 15202 IF((WBEGIN+NEWLST-1.LT.DOL).OR. 15203 $ (WBEGIN+NEWFST-1.GT.DOU)) THEN 15204 IDONE = IDONE + NEWLST - NEWFST + 1 15205 GOTO 139 15206 ENDIF 15207 CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ), 15208 $ WORK(INDLD+IBEGIN-1), 15209 $ NEWFST, NEWLST, WORK(WBEGIN), 15210 $ WGAP(WBEGIN), WERR(WBEGIN), 15211 $ SPDIAM, LGAP, RGAP, PIVMIN, TAU, 15212 $ Z(IBEGIN, NEWFTT),Z(IBEGIN, NEWFTT+1), 15213 $ WORK( INDWRK ), IINFO ) 15214 IF( IINFO.EQ.0 ) THEN 15215 SSIGMA = SIGMA + TAU 15216 Z( IEND, NEWFTT+1 ) = SSIGMA 15217 DO 116 K = NEWFST, NEWLST 15218 FUDGE = 15219 $ THREE*EPS*ABS(WORK(WBEGIN+K-1)) 15220 WORK( WBEGIN + K - 1 ) = 15221 $ WORK( WBEGIN + K - 1) - TAU 15222 FUDGE = FUDGE + 15223 $ FOUR*EPS*ABS(WORK(WBEGIN+K-1)) 15224 WERR( WBEGIN + K - 1 ) = 15225 $ WERR( WBEGIN + K - 1 ) + FUDGE 15226 116 CONTINUE 15227 NCLUS = NCLUS + 1 15228 K = NEWCLS + 2*NCLUS 15229 IWORK( K-1 ) = NEWFST 15230 IWORK( K ) = NEWLST 15231 ELSE 15232 INFO = -2 15233 RETURN 15234 ENDIF 15235 ELSE 15236 ITER = 0 15237 TOL = FOUR * LOG(DBLE(IN)) * EPS 15238 K = NEWFST 15239 WINDEX = WBEGIN + K - 1 15240 WINDMN = MAX(WINDEX - 1,1) 15241 WINDPL = MIN(WINDEX + 1,M) 15242 LAMBDA = WORK( WINDEX ) 15243 DONE = DONE + 1 15244 IF((WINDEX.LT.DOL).OR. 15245 $ (WINDEX.GT.DOU)) THEN 15246 ESKIP = .TRUE. 15247 GOTO 125 15248 ELSE 15249 ESKIP = .FALSE. 15250 ENDIF 15251 LEFT = WORK( WINDEX ) - WERR( WINDEX ) 15252 RIGHT = WORK( WINDEX ) + WERR( WINDEX ) 15253 INDEIG = INDEXW( WINDEX ) 15254 IF( K .EQ. 1) THEN 15255 LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT)) 15256 ELSE 15257 LGAP = WGAP(WINDMN) 15258 ENDIF 15259 IF( K .EQ. IM) THEN 15260 RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT)) 15261 ELSE 15262 RGAP = WGAP(WINDEX) 15263 ENDIF 15264 GAP = MIN( LGAP, RGAP ) 15265 IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN 15266 GAPTOL = ZERO 15267 ELSE 15268 GAPTOL = GAP * EPS 15269 ENDIF 15270 ISUPMN = IN 15271 ISUPMX = 1 15272 SAVGAP = WGAP(WINDEX) 15273 WGAP(WINDEX) = GAP 15274 USEDBS = .FALSE. 15275 USEDRQ = .FALSE. 15276 NEEDBS = .NOT.TRYRQC 15277 120 CONTINUE 15278 IF(NEEDBS) THEN 15279 USEDBS = .TRUE. 15280 ITMP1 = IWORK( IINDR+WINDEX ) 15281 OFFSET = INDEXW( WBEGIN ) - 1 15282 CALL DLARRB( IN, D(IBEGIN), 15283 $ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG, 15284 $ ZERO, TWO*EPS, OFFSET, 15285 $ WORK(WBEGIN),WGAP(WBEGIN), 15286 $ WERR(WBEGIN),WORK( INDWRK ), 15287 $ IWORK( IINDWK ), PIVMIN, SPDIAM, 15288 $ ITMP1, IINFO ) 15289 IF( IINFO.NE.0 ) THEN 15290 INFO = -3 15291 RETURN 15292 ENDIF 15293 LAMBDA = WORK( WINDEX ) 15294 IWORK( IINDR+WINDEX ) = 0 15295 ENDIF 15296 CALL DLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ), 15297 $ L( IBEGIN ), WORK(INDLD+IBEGIN-1), 15298 $ WORK(INDLLD+IBEGIN-1), 15299 $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ), 15300 $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA, 15301 $ IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ), 15302 $ NRMINV, RESID, RQCORR, WORK( INDWRK ) ) 15303 IF(ITER .EQ. 0) THEN 15304 BSTRES = RESID 15305 BSTW = LAMBDA 15306 ELSEIF(RESID.LT.BSTRES) THEN 15307 BSTRES = RESID 15308 BSTW = LAMBDA 15309 ENDIF 15310 ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 )) 15311 ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX )) 15312 ITER = ITER + 1 15313 IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT. 15314 $ RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS) 15315 $ THEN 15316 IF(INDEIG.LE.NEGCNT) THEN 15317 SGNDEF = -ONE 15318 ELSE 15319 SGNDEF = ONE 15320 ENDIF 15321 IF( ( RQCORR*SGNDEF.GE.ZERO ) 15322 $ .AND.( LAMBDA + RQCORR.LE. RIGHT) 15323 $ .AND.( LAMBDA + RQCORR.GE. LEFT) 15324 $ ) THEN 15325 USEDRQ = .TRUE. 15326 IF(SGNDEF.EQ.ONE) THEN 15327 LEFT = LAMBDA 15328 ELSE 15329 RIGHT = LAMBDA 15330 ENDIF 15331 WORK( WINDEX ) = 15332 $ HALF * (RIGHT + LEFT) 15333 LAMBDA = LAMBDA + RQCORR 15334 WERR( WINDEX ) = 15335 $ HALF * (RIGHT-LEFT) 15336 ELSE 15337 NEEDBS = .TRUE. 15338 ENDIF 15339 IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN 15340 USEDBS = .TRUE. 15341 GOTO 120 15342 ELSEIF( ITER.LT.MAXITR ) THEN 15343 GOTO 120 15344 ELSEIF( ITER.EQ.MAXITR ) THEN 15345 NEEDBS = .TRUE. 15346 GOTO 120 15347 ELSE 15348 INFO = 5 15349 RETURN 15350 END IF 15351 ELSE 15352 STP2II = .FALSE. 15353 IF(USEDRQ .AND. USEDBS .AND. 15354 $ BSTRES.LE.RESID) THEN 15355 LAMBDA = BSTW 15356 STP2II = .TRUE. 15357 ENDIF 15358 IF (STP2II) THEN 15359 CALL DLAR1V( IN, 1, IN, LAMBDA, 15360 $ D( IBEGIN ), L( IBEGIN ), 15361 $ WORK(INDLD+IBEGIN-1), 15362 $ WORK(INDLLD+IBEGIN-1), 15363 $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ), 15364 $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA, 15365 $ IWORK( IINDR+WINDEX ), 15366 $ ISUPPZ( 2*WINDEX-1 ), 15367 $ NRMINV, RESID, RQCORR, WORK( INDWRK ) ) 15368 ENDIF 15369 WORK( WINDEX ) = LAMBDA 15370 END IF 15371 ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN 15372 ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN 15373 ZFROM = ISUPPZ( 2*WINDEX-1 ) 15374 ZTO = ISUPPZ( 2*WINDEX ) 15375 ISUPMN = ISUPMN + OLDIEN 15376 ISUPMX = ISUPMX + OLDIEN 15377 IF(ISUPMN.LT.ZFROM) THEN 15378 DO 122 II = ISUPMN,ZFROM-1 15379 Z( II, WINDEX ) = ZERO 15380 122 CONTINUE 15381 ENDIF 15382 IF(ISUPMX.GT.ZTO) THEN 15383 DO 123 II = ZTO+1,ISUPMX 15384 Z( II, WINDEX ) = ZERO 15385 123 CONTINUE 15386 ENDIF 15387 CALL DSCAL( ZTO-ZFROM+1, NRMINV, 15388 $ Z( ZFROM, WINDEX ), 1 ) 15389 125 CONTINUE 15390 W( WINDEX ) = LAMBDA+SIGMA 15391 IF(.NOT.ESKIP) THEN 15392 IF( K.GT.1) THEN 15393 WGAP( WINDMN ) = MAX( WGAP(WINDMN), 15394 $ W(WINDEX)-WERR(WINDEX) 15395 $ - W(WINDMN)-WERR(WINDMN) ) 15396 ENDIF 15397 IF( WINDEX.LT.WEND ) THEN 15398 WGAP( WINDEX ) = MAX( SAVGAP, 15399 $ W( WINDPL )-WERR( WINDPL ) 15400 $ - W( WINDEX )-WERR( WINDEX) ) 15401 ENDIF 15402 ENDIF 15403 IDONE = IDONE + 1 15404 ENDIF 15405 139 CONTINUE 15406 NEWFST = J + 1 15407 140 CONTINUE 15408 150 CONTINUE 15409 NDEPTH = NDEPTH + 1 15410 GO TO 40 15411 END IF 15412 IBEGIN = IEND + 1 15413 WBEGIN = WEND + 1 15414 170 CONTINUE 15415 RETURN 15416 END 15417! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlartg.f 15418 SUBROUTINE DLARTG( F, G, CS, SN, R ) 15419 DOUBLE PRECISION CS, F, G, R, SN 15420 DOUBLE PRECISION ZERO 15421 PARAMETER ( ZERO = 0.0D0 ) 15422 DOUBLE PRECISION ONE 15423 PARAMETER ( ONE = 1.0D0 ) 15424 DOUBLE PRECISION TWO 15425 PARAMETER ( TWO = 2.0D0 ) 15426 INTEGER COUNT, I 15427 DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE 15428 DOUBLE PRECISION DLAMCH 15429 EXTERNAL DLAMCH 15430 INTRINSIC ABS, INT, LOG, MAX, SQRT 15431 SAFMIN = DLAMCH( 'S' ) 15432 EPS = DLAMCH( 'E' ) 15433 SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / 15434 $ LOG( DLAMCH( 'B' ) ) / TWO ) 15435 SAFMX2 = ONE / SAFMN2 15436 IF( G.EQ.ZERO ) THEN 15437 CS = ONE 15438 SN = ZERO 15439 R = F 15440 ELSE IF( F.EQ.ZERO ) THEN 15441 CS = ZERO 15442 SN = ONE 15443 R = G 15444 ELSE 15445 F1 = F 15446 G1 = G 15447 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 15448 IF( SCALE.GE.SAFMX2 ) THEN 15449 COUNT = 0 15450 10 CONTINUE 15451 COUNT = COUNT + 1 15452 F1 = F1*SAFMN2 15453 G1 = G1*SAFMN2 15454 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 15455 IF( SCALE.GE.SAFMX2 ) 15456 $ GO TO 10 15457 R = SQRT( F1**2+G1**2 ) 15458 CS = F1 / R 15459 SN = G1 / R 15460 DO 20 I = 1, COUNT 15461 R = R*SAFMX2 15462 20 CONTINUE 15463 ELSE IF( SCALE.LE.SAFMN2 ) THEN 15464 COUNT = 0 15465 30 CONTINUE 15466 COUNT = COUNT + 1 15467 F1 = F1*SAFMX2 15468 G1 = G1*SAFMX2 15469 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 15470 IF( SCALE.LE.SAFMN2 ) 15471 $ GO TO 30 15472 R = SQRT( F1**2+G1**2 ) 15473 CS = F1 / R 15474 SN = G1 / R 15475 DO 40 I = 1, COUNT 15476 R = R*SAFMN2 15477 40 CONTINUE 15478 ELSE 15479 R = SQRT( F1**2+G1**2 ) 15480 CS = F1 / R 15481 SN = G1 / R 15482 END IF 15483 IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN 15484 CS = -CS 15485 SN = -SN 15486 R = -R 15487 END IF 15488 END IF 15489 RETURN 15490 END 15491! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaruv.f 15492 SUBROUTINE DLARUV( ISEED, N, X ) 15493 INTEGER N 15494 INTEGER ISEED( 4 ) 15495 DOUBLE PRECISION X( N ) 15496 DOUBLE PRECISION ONE 15497 PARAMETER ( ONE = 1.0D0 ) 15498 INTEGER LV, IPW2 15499 DOUBLE PRECISION R 15500 PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) 15501 INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J 15502 INTEGER MM( LV, 4 ) 15503 INTRINSIC DBLE, MIN, MOD 15504 DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, 15505 $ 2549 / 15506 DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, 15507 $ 1145 / 15508 DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, 15509 $ 2253 / 15510 DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, 15511 $ 305 / 15512 DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, 15513 $ 3301 / 15514 DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, 15515 $ 1065 / 15516 DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, 15517 $ 3133 / 15518 DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, 15519 $ 2913 / 15520 DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, 15521 $ 3285 / 15522 DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, 15523 $ 1241 / 15524 DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, 15525 $ 1197 / 15526 DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, 15527 $ 3729 / 15528 DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, 15529 $ 2501 / 15530 DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, 15531 $ 1673 / 15532 DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, 15533 $ 541 / 15534 DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, 15535 $ 2753 / 15536 DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, 15537 $ 949 / 15538 DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, 15539 $ 2361 / 15540 DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, 15541 $ 1165 / 15542 DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, 15543 $ 4081 / 15544 DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, 15545 $ 2725 / 15546 DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, 15547 $ 3305 / 15548 DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, 15549 $ 3069 / 15550 DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, 15551 $ 3617 / 15552 DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, 15553 $ 3733 / 15554 DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, 15555 $ 409 / 15556 DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, 15557 $ 2157 / 15558 DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, 15559 $ 1361 / 15560 DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, 15561 $ 3973 / 15562 DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, 15563 $ 1865 / 15564 DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, 15565 $ 2525 / 15566 DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, 15567 $ 1409 / 15568 DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, 15569 $ 3445 / 15570 DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, 15571 $ 3577 / 15572 DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, 15573 $ 77 / 15574 DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, 15575 $ 3761 / 15576 DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, 15577 $ 2149 / 15578 DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, 15579 $ 1449 / 15580 DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, 15581 $ 3005 / 15582 DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, 15583 $ 225 / 15584 DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, 15585 $ 85 / 15586 DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, 15587 $ 3673 / 15588 DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, 15589 $ 3117 / 15590 DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, 15591 $ 3089 / 15592 DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, 15593 $ 1349 / 15594 DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, 15595 $ 2057 / 15596 DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, 15597 $ 413 / 15598 DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, 15599 $ 65 / 15600 DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, 15601 $ 1845 / 15602 DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, 15603 $ 697 / 15604 DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, 15605 $ 3085 / 15606 DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, 15607 $ 3441 / 15608 DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, 15609 $ 1573 / 15610 DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, 15611 $ 3689 / 15612 DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, 15613 $ 2941 / 15614 DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, 15615 $ 929 / 15616 DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, 15617 $ 533 / 15618 DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, 15619 $ 2841 / 15620 DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, 15621 $ 4077 / 15622 DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, 15623 $ 721 / 15624 DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, 15625 $ 2821 / 15626 DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, 15627 $ 2249 / 15628 DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, 15629 $ 2397 / 15630 DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, 15631 $ 2817 / 15632 DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, 15633 $ 245 / 15634 DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, 15635 $ 1913 / 15636 DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, 15637 $ 1997 / 15638 DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, 15639 $ 3121 / 15640 DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, 15641 $ 997 / 15642 DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, 15643 $ 1833 / 15644 DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, 15645 $ 2877 / 15646 DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, 15647 $ 1633 / 15648 DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, 15649 $ 981 / 15650 DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, 15651 $ 2009 / 15652 DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, 15653 $ 941 / 15654 DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, 15655 $ 2449 / 15656 DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, 15657 $ 197 / 15658 DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, 15659 $ 2441 / 15660 DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, 15661 $ 285 / 15662 DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, 15663 $ 1473 / 15664 DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, 15665 $ 2741 / 15666 DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, 15667 $ 3129 / 15668 DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, 15669 $ 909 / 15670 DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, 15671 $ 2801 / 15672 DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, 15673 $ 421 / 15674 DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, 15675 $ 4073 / 15676 DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, 15677 $ 2813 / 15678 DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, 15679 $ 2337 / 15680 DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, 15681 $ 1429 / 15682 DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, 15683 $ 1177 / 15684 DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, 15685 $ 1901 / 15686 DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, 15687 $ 81 / 15688 DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, 15689 $ 1669 / 15690 DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, 15691 $ 2633 / 15692 DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, 15693 $ 2269 / 15694 DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, 15695 $ 129 / 15696 DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, 15697 $ 1141 / 15698 DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, 15699 $ 249 / 15700 DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, 15701 $ 3917 / 15702 DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, 15703 $ 2481 / 15704 DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, 15705 $ 3941 / 15706 DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, 15707 $ 2217 / 15708 DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, 15709 $ 2749 / 15710 DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, 15711 $ 3041 / 15712 DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, 15713 $ 1877 / 15714 DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, 15715 $ 345 / 15716 DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, 15717 $ 2861 / 15718 DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, 15719 $ 1809 / 15720 DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, 15721 $ 3141 / 15722 DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, 15723 $ 2825 / 15724 DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, 15725 $ 157 / 15726 DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, 15727 $ 2881 / 15728 DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, 15729 $ 3637 / 15730 DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, 15731 $ 1465 / 15732 DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, 15733 $ 2829 / 15734 DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, 15735 $ 2161 / 15736 DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, 15737 $ 3365 / 15738 DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, 15739 $ 361 / 15740 DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, 15741 $ 2685 / 15742 DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, 15743 $ 3745 / 15744 DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, 15745 $ 2325 / 15746 DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, 15747 $ 3609 / 15748 DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, 15749 $ 3821 / 15750 DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, 15751 $ 3537 / 15752 DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, 15753 $ 517 / 15754 DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, 15755 $ 3017 / 15756 DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, 15757 $ 2141 / 15758 DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, 15759 $ 1537 / 15760 I1 = ISEED( 1 ) 15761 I2 = ISEED( 2 ) 15762 I3 = ISEED( 3 ) 15763 I4 = ISEED( 4 ) 15764 DO 10 I = 1, MIN( N, LV ) 15765 20 CONTINUE 15766 IT4 = I4*MM( I, 4 ) 15767 IT3 = IT4 / IPW2 15768 IT4 = IT4 - IPW2*IT3 15769 IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) 15770 IT2 = IT3 / IPW2 15771 IT3 = IT3 - IPW2*IT2 15772 IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) 15773 IT1 = IT2 / IPW2 15774 IT2 = IT2 - IPW2*IT1 15775 IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + 15776 $ I4*MM( I, 1 ) 15777 IT1 = MOD( IT1, IPW2 ) 15778 X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* 15779 $ DBLE( IT4 ) ) ) ) 15780 IF (X( I ).EQ.1.0D0) THEN 15781 I1 = I1 + 2 15782 I2 = I2 + 2 15783 I3 = I3 + 2 15784 I4 = I4 + 2 15785 GOTO 20 15786 END IF 15787 10 CONTINUE 15788 ISEED( 1 ) = IT1 15789 ISEED( 2 ) = IT2 15790 ISEED( 3 ) = IT3 15791 ISEED( 4 ) = IT4 15792 RETURN 15793 END 15794! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlas2.f 15795 SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) 15796 DOUBLE PRECISION F, G, H, SSMAX, SSMIN 15797 DOUBLE PRECISION ZERO 15798 PARAMETER ( ZERO = 0.0D0 ) 15799 DOUBLE PRECISION ONE 15800 PARAMETER ( ONE = 1.0D0 ) 15801 DOUBLE PRECISION TWO 15802 PARAMETER ( TWO = 2.0D0 ) 15803 DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA 15804 INTRINSIC ABS, MAX, MIN, SQRT 15805 FA = ABS( F ) 15806 GA = ABS( G ) 15807 HA = ABS( H ) 15808 FHMN = MIN( FA, HA ) 15809 FHMX = MAX( FA, HA ) 15810 IF( FHMN.EQ.ZERO ) THEN 15811 SSMIN = ZERO 15812 IF( FHMX.EQ.ZERO ) THEN 15813 SSMAX = GA 15814 ELSE 15815 SSMAX = MAX( FHMX, GA )*SQRT( ONE+ 15816 $ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 ) 15817 END IF 15818 ELSE 15819 IF( GA.LT.FHMX ) THEN 15820 AS = ONE + FHMN / FHMX 15821 AT = ( FHMX-FHMN ) / FHMX 15822 AU = ( GA / FHMX )**2 15823 C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) ) 15824 SSMIN = FHMN*C 15825 SSMAX = FHMX / C 15826 ELSE 15827 AU = FHMX / GA 15828 IF( AU.EQ.ZERO ) THEN 15829 SSMIN = ( FHMN*FHMX ) / GA 15830 SSMAX = GA 15831 ELSE 15832 AS = ONE + FHMN / FHMX 15833 AT = ( FHMX-FHMN ) / FHMX 15834 C = ONE / ( SQRT( ONE+( AS*AU )**2 )+ 15835 $ SQRT( ONE+( AT*AU )**2 ) ) 15836 SSMIN = ( FHMN*C )*AU 15837 SSMIN = SSMIN + SSMIN 15838 SSMAX = GA / ( C+C ) 15839 END IF 15840 END IF 15841 END IF 15842 RETURN 15843 END 15844! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlascl.f 15845 SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) 15846 CHARACTER TYPE 15847 INTEGER INFO, KL, KU, LDA, M, N 15848 DOUBLE PRECISION CFROM, CTO 15849 DOUBLE PRECISION A( LDA, * ) 15850 DOUBLE PRECISION ZERO, ONE 15851 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 15852 LOGICAL DONE 15853 INTEGER I, ITYPE, J, K1, K2, K3, K4 15854 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM 15855 LOGICAL LSAME, DISNAN 15856 DOUBLE PRECISION DLAMCH 15857 EXTERNAL LSAME, DLAMCH, DISNAN 15858 INTRINSIC ABS, MAX, MIN 15859 EXTERNAL XERBLA 15860 INFO = 0 15861 IF( LSAME( TYPE, 'G' ) ) THEN 15862 ITYPE = 0 15863 ELSE IF( LSAME( TYPE, 'L' ) ) THEN 15864 ITYPE = 1 15865 ELSE IF( LSAME( TYPE, 'U' ) ) THEN 15866 ITYPE = 2 15867 ELSE IF( LSAME( TYPE, 'H' ) ) THEN 15868 ITYPE = 3 15869 ELSE IF( LSAME( TYPE, 'B' ) ) THEN 15870 ITYPE = 4 15871 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN 15872 ITYPE = 5 15873 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN 15874 ITYPE = 6 15875 ELSE 15876 ITYPE = -1 15877 END IF 15878 IF( ITYPE.EQ.-1 ) THEN 15879 INFO = -1 15880 ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN 15881 INFO = -4 15882 ELSE IF( DISNAN(CTO) ) THEN 15883 INFO = -5 15884 ELSE IF( M.LT.0 ) THEN 15885 INFO = -6 15886 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. 15887 $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN 15888 INFO = -7 15889 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN 15890 INFO = -9 15891 ELSE IF( ITYPE.GE.4 ) THEN 15892 IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN 15893 INFO = -2 15894 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. 15895 $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) 15896 $ THEN 15897 INFO = -3 15898 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. 15899 $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. 15900 $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN 15901 INFO = -9 15902 END IF 15903 END IF 15904 IF( INFO.NE.0 ) THEN 15905 CALL XERBLA( 'DLASCL', -INFO ) 15906 RETURN 15907 END IF 15908 IF( N.EQ.0 .OR. M.EQ.0 ) 15909 $ RETURN 15910 SMLNUM = DLAMCH( 'S' ) 15911 BIGNUM = ONE / SMLNUM 15912 CFROMC = CFROM 15913 CTOC = CTO 15914 10 CONTINUE 15915 CFROM1 = CFROMC*SMLNUM 15916 IF( CFROM1.EQ.CFROMC ) THEN 15917 MUL = CTOC / CFROMC 15918 DONE = .TRUE. 15919 CTO1 = CTOC 15920 ELSE 15921 CTO1 = CTOC / BIGNUM 15922 IF( CTO1.EQ.CTOC ) THEN 15923 MUL = CTOC 15924 DONE = .TRUE. 15925 CFROMC = ONE 15926 ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN 15927 MUL = SMLNUM 15928 DONE = .FALSE. 15929 CFROMC = CFROM1 15930 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN 15931 MUL = BIGNUM 15932 DONE = .FALSE. 15933 CTOC = CTO1 15934 ELSE 15935 MUL = CTOC / CFROMC 15936 DONE = .TRUE. 15937 END IF 15938 END IF 15939 IF( ITYPE.EQ.0 ) THEN 15940 DO 30 J = 1, N 15941 DO 20 I = 1, M 15942 A( I, J ) = A( I, J )*MUL 15943 20 CONTINUE 15944 30 CONTINUE 15945 ELSE IF( ITYPE.EQ.1 ) THEN 15946 DO 50 J = 1, N 15947 DO 40 I = J, M 15948 A( I, J ) = A( I, J )*MUL 15949 40 CONTINUE 15950 50 CONTINUE 15951 ELSE IF( ITYPE.EQ.2 ) THEN 15952 DO 70 J = 1, N 15953 DO 60 I = 1, MIN( J, M ) 15954 A( I, J ) = A( I, J )*MUL 15955 60 CONTINUE 15956 70 CONTINUE 15957 ELSE IF( ITYPE.EQ.3 ) THEN 15958 DO 90 J = 1, N 15959 DO 80 I = 1, MIN( J+1, M ) 15960 A( I, J ) = A( I, J )*MUL 15961 80 CONTINUE 15962 90 CONTINUE 15963 ELSE IF( ITYPE.EQ.4 ) THEN 15964 K3 = KL + 1 15965 K4 = N + 1 15966 DO 110 J = 1, N 15967 DO 100 I = 1, MIN( K3, K4-J ) 15968 A( I, J ) = A( I, J )*MUL 15969 100 CONTINUE 15970 110 CONTINUE 15971 ELSE IF( ITYPE.EQ.5 ) THEN 15972 K1 = KU + 2 15973 K3 = KU + 1 15974 DO 130 J = 1, N 15975 DO 120 I = MAX( K1-J, 1 ), K3 15976 A( I, J ) = A( I, J )*MUL 15977 120 CONTINUE 15978 130 CONTINUE 15979 ELSE IF( ITYPE.EQ.6 ) THEN 15980 K1 = KL + KU + 2 15981 K2 = KL + 1 15982 K3 = 2*KL + KU + 1 15983 K4 = KL + KU + 1 + M 15984 DO 150 J = 1, N 15985 DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) 15986 A( I, J ) = A( I, J )*MUL 15987 140 CONTINUE 15988 150 CONTINUE 15989 END IF 15990 IF( .NOT.DONE ) 15991 $ GO TO 10 15992 RETURN 15993 END 15994! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaset.f 15995 SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) 15996 CHARACTER UPLO 15997 INTEGER LDA, M, N 15998 DOUBLE PRECISION ALPHA, BETA 15999 DOUBLE PRECISION A( LDA, * ) 16000 INTEGER I, J 16001 LOGICAL LSAME 16002 EXTERNAL LSAME 16003 INTRINSIC MIN 16004 IF( LSAME( UPLO, 'U' ) ) THEN 16005 DO 20 J = 2, N 16006 DO 10 I = 1, MIN( J-1, M ) 16007 A( I, J ) = ALPHA 16008 10 CONTINUE 16009 20 CONTINUE 16010 ELSE IF( LSAME( UPLO, 'L' ) ) THEN 16011 DO 40 J = 1, MIN( M, N ) 16012 DO 30 I = J + 1, M 16013 A( I, J ) = ALPHA 16014 30 CONTINUE 16015 40 CONTINUE 16016 ELSE 16017 DO 60 J = 1, N 16018 DO 50 I = 1, M 16019 A( I, J ) = ALPHA 16020 50 CONTINUE 16021 60 CONTINUE 16022 END IF 16023 DO 70 I = 1, MIN( M, N ) 16024 A( I, I ) = BETA 16025 70 CONTINUE 16026 RETURN 16027 END 16028! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlasq1.f 16029 SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) 16030 INTEGER INFO, N 16031 DOUBLE PRECISION D( * ), E( * ), WORK( * ) 16032 DOUBLE PRECISION ZERO 16033 PARAMETER ( ZERO = 0.0D0 ) 16034 INTEGER I, IINFO 16035 DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX 16036 EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA 16037 DOUBLE PRECISION DLAMCH 16038 EXTERNAL DLAMCH 16039 INTRINSIC ABS, MAX, SQRT 16040 INFO = 0 16041 IF( N.LT.0 ) THEN 16042 INFO = -1 16043 CALL XERBLA( 'DLASQ1', -INFO ) 16044 RETURN 16045 ELSE IF( N.EQ.0 ) THEN 16046 RETURN 16047 ELSE IF( N.EQ.1 ) THEN 16048 D( 1 ) = ABS( D( 1 ) ) 16049 RETURN 16050 ELSE IF( N.EQ.2 ) THEN 16051 CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX ) 16052 D( 1 ) = SIGMX 16053 D( 2 ) = SIGMN 16054 RETURN 16055 END IF 16056 SIGMX = ZERO 16057 DO 10 I = 1, N - 1 16058 D( I ) = ABS( D( I ) ) 16059 SIGMX = MAX( SIGMX, ABS( E( I ) ) ) 16060 10 CONTINUE 16061 D( N ) = ABS( D( N ) ) 16062 IF( SIGMX.EQ.ZERO ) THEN 16063 CALL DLASRT( 'D', N, D, IINFO ) 16064 RETURN 16065 END IF 16066 DO 20 I = 1, N 16067 SIGMX = MAX( SIGMX, D( I ) ) 16068 20 CONTINUE 16069 EPS = DLAMCH( 'Precision' ) 16070 SAFMIN = DLAMCH( 'Safe minimum' ) 16071 SCALE = SQRT( EPS / SAFMIN ) 16072 CALL DCOPY( N, D, 1, WORK( 1 ), 2 ) 16073 CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 ) 16074 CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1, 16075 $ IINFO ) 16076 DO 30 I = 1, 2*N - 1 16077 WORK( I ) = WORK( I )**2 16078 30 CONTINUE 16079 WORK( 2*N ) = ZERO 16080 CALL DLASQ2( N, WORK, INFO ) 16081 IF( INFO.EQ.0 ) THEN 16082 DO 40 I = 1, N 16083 D( I ) = SQRT( WORK( I ) ) 16084 40 CONTINUE 16085 CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) 16086 ELSE IF( INFO.EQ.2 ) THEN 16087 DO I = 1, N 16088 D( I ) = SQRT( WORK( 2*I-1 ) ) 16089 E( I ) = SQRT( WORK( 2*I ) ) 16090 END DO 16091 CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) 16092 CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, E, N, IINFO ) 16093 END IF 16094 RETURN 16095 END 16096! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlasq2.f 16097 SUBROUTINE DLASQ2( N, Z, INFO ) 16098 INTEGER INFO, N 16099 DOUBLE PRECISION Z( * ) 16100 DOUBLE PRECISION CBIAS 16101 PARAMETER ( CBIAS = 1.50D0 ) 16102 DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD 16103 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, 16104 $ TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 ) 16105 LOGICAL IEEE 16106 INTEGER I0, I1, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, 16107 $ K, KMIN, N0, N1, NBIG, NDIV, NFAIL, PP, SPLT, 16108 $ TTYPE 16109 DOUBLE PRECISION D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN, 16110 $ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX, 16111 $ QMIN, S, SAFMIN, SIGMA, T, TAU, TEMP, TOL, 16112 $ TOL2, TRACE, ZMAX, TEMPE, TEMPQ 16113 EXTERNAL DLASQ3, DLASRT, XERBLA 16114 INTEGER ILAENV 16115 DOUBLE PRECISION DLAMCH 16116 EXTERNAL DLAMCH, ILAENV 16117 INTRINSIC ABS, DBLE, MAX, MIN, SQRT 16118 INFO = 0 16119 EPS = DLAMCH( 'Precision' ) 16120 SAFMIN = DLAMCH( 'Safe minimum' ) 16121 TOL = EPS*HUNDRD 16122 TOL2 = TOL**2 16123 IF( N.LT.0 ) THEN 16124 INFO = -1 16125 CALL XERBLA( 'DLASQ2', 1 ) 16126 RETURN 16127 ELSE IF( N.EQ.0 ) THEN 16128 RETURN 16129 ELSE IF( N.EQ.1 ) THEN 16130 IF( Z( 1 ).LT.ZERO ) THEN 16131 INFO = -201 16132 CALL XERBLA( 'DLASQ2', 2 ) 16133 END IF 16134 RETURN 16135 ELSE IF( N.EQ.2 ) THEN 16136 IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN 16137 INFO = -2 16138 CALL XERBLA( 'DLASQ2', 2 ) 16139 RETURN 16140 ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN 16141 D = Z( 3 ) 16142 Z( 3 ) = Z( 1 ) 16143 Z( 1 ) = D 16144 END IF 16145 Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 ) 16146 IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN 16147 T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) 16148 S = Z( 3 )*( Z( 2 ) / T ) 16149 IF( S.LE.T ) THEN 16150 S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) ) 16151 ELSE 16152 S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) 16153 END IF 16154 T = Z( 1 ) + ( S+Z( 2 ) ) 16155 Z( 3 ) = Z( 3 )*( Z( 1 ) / T ) 16156 Z( 1 ) = T 16157 END IF 16158 Z( 2 ) = Z( 3 ) 16159 Z( 6 ) = Z( 2 ) + Z( 1 ) 16160 RETURN 16161 END IF 16162 Z( 2*N ) = ZERO 16163 EMIN = Z( 2 ) 16164 QMAX = ZERO 16165 ZMAX = ZERO 16166 D = ZERO 16167 E = ZERO 16168 DO 10 K = 1, 2*( N-1 ), 2 16169 IF( Z( K ).LT.ZERO ) THEN 16170 INFO = -( 200+K ) 16171 CALL XERBLA( 'DLASQ2', 2 ) 16172 RETURN 16173 ELSE IF( Z( K+1 ).LT.ZERO ) THEN 16174 INFO = -( 200+K+1 ) 16175 CALL XERBLA( 'DLASQ2', 2 ) 16176 RETURN 16177 END IF 16178 D = D + Z( K ) 16179 E = E + Z( K+1 ) 16180 QMAX = MAX( QMAX, Z( K ) ) 16181 EMIN = MIN( EMIN, Z( K+1 ) ) 16182 ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) ) 16183 10 CONTINUE 16184 IF( Z( 2*N-1 ).LT.ZERO ) THEN 16185 INFO = -( 200+2*N-1 ) 16186 CALL XERBLA( 'DLASQ2', 2 ) 16187 RETURN 16188 END IF 16189 D = D + Z( 2*N-1 ) 16190 QMAX = MAX( QMAX, Z( 2*N-1 ) ) 16191 ZMAX = MAX( QMAX, ZMAX ) 16192 IF( E.EQ.ZERO ) THEN 16193 DO 20 K = 2, N 16194 Z( K ) = Z( 2*K-1 ) 16195 20 CONTINUE 16196 CALL DLASRT( 'D', N, Z, IINFO ) 16197 Z( 2*N-1 ) = D 16198 RETURN 16199 END IF 16200 TRACE = D + E 16201 IF( TRACE.EQ.ZERO ) THEN 16202 Z( 2*N-1 ) = ZERO 16203 RETURN 16204 END IF 16205 IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. 16206 $ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 16207 DO 30 K = 2*N, 2, -2 16208 Z( 2*K ) = ZERO 16209 Z( 2*K-1 ) = Z( K ) 16210 Z( 2*K-2 ) = ZERO 16211 Z( 2*K-3 ) = Z( K-1 ) 16212 30 CONTINUE 16213 I0 = 1 16214 N0 = N 16215 IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN 16216 IPN4 = 4*( I0+N0 ) 16217 DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4 16218 TEMP = Z( I4-3 ) 16219 Z( I4-3 ) = Z( IPN4-I4-3 ) 16220 Z( IPN4-I4-3 ) = TEMP 16221 TEMP = Z( I4-1 ) 16222 Z( I4-1 ) = Z( IPN4-I4-5 ) 16223 Z( IPN4-I4-5 ) = TEMP 16224 40 CONTINUE 16225 END IF 16226 PP = 0 16227 DO 80 K = 1, 2 16228 D = Z( 4*N0+PP-3 ) 16229 DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4 16230 IF( Z( I4-1 ).LE.TOL2*D ) THEN 16231 Z( I4-1 ) = -ZERO 16232 D = Z( I4-3 ) 16233 ELSE 16234 D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) ) 16235 END IF 16236 50 CONTINUE 16237 EMIN = Z( 4*I0+PP+1 ) 16238 D = Z( 4*I0+PP-3 ) 16239 DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4 16240 Z( I4-2*PP-2 ) = D + Z( I4-1 ) 16241 IF( Z( I4-1 ).LE.TOL2*D ) THEN 16242 Z( I4-1 ) = -ZERO 16243 Z( I4-2*PP-2 ) = D 16244 Z( I4-2*PP ) = ZERO 16245 D = Z( I4+1 ) 16246 ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND. 16247 $ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN 16248 TEMP = Z( I4+1 ) / Z( I4-2*PP-2 ) 16249 Z( I4-2*PP ) = Z( I4-1 )*TEMP 16250 D = D*TEMP 16251 ELSE 16252 Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) ) 16253 D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) ) 16254 END IF 16255 EMIN = MIN( EMIN, Z( I4-2*PP ) ) 16256 60 CONTINUE 16257 Z( 4*N0-PP-2 ) = D 16258 QMAX = Z( 4*I0-PP-2 ) 16259 DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4 16260 QMAX = MAX( QMAX, Z( I4 ) ) 16261 70 CONTINUE 16262 PP = 1 - PP 16263 80 CONTINUE 16264 TTYPE = 0 16265 DMIN1 = ZERO 16266 DMIN2 = ZERO 16267 DN = ZERO 16268 DN1 = ZERO 16269 DN2 = ZERO 16270 G = ZERO 16271 TAU = ZERO 16272 ITER = 2 16273 NFAIL = 0 16274 NDIV = 2*( N0-I0 ) 16275 DO 160 IWHILA = 1, N + 1 16276 IF( N0.LT.1 ) 16277 $ GO TO 170 16278 DESIG = ZERO 16279 IF( N0.EQ.N ) THEN 16280 SIGMA = ZERO 16281 ELSE 16282 SIGMA = -Z( 4*N0-1 ) 16283 END IF 16284 IF( SIGMA.LT.ZERO ) THEN 16285 INFO = 1 16286 RETURN 16287 END IF 16288 EMAX = ZERO 16289 IF( N0.GT.I0 ) THEN 16290 EMIN = ABS( Z( 4*N0-5 ) ) 16291 ELSE 16292 EMIN = ZERO 16293 END IF 16294 QMIN = Z( 4*N0-3 ) 16295 QMAX = QMIN 16296 DO 90 I4 = 4*N0, 8, -4 16297 IF( Z( I4-5 ).LE.ZERO ) 16298 $ GO TO 100 16299 IF( QMIN.GE.FOUR*EMAX ) THEN 16300 QMIN = MIN( QMIN, Z( I4-3 ) ) 16301 EMAX = MAX( EMAX, Z( I4-5 ) ) 16302 END IF 16303 QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) ) 16304 EMIN = MIN( EMIN, Z( I4-5 ) ) 16305 90 CONTINUE 16306 I4 = 4 16307 100 CONTINUE 16308 I0 = I4 / 4 16309 PP = 0 16310 IF( N0-I0.GT.1 ) THEN 16311 DEE = Z( 4*I0-3 ) 16312 DEEMIN = DEE 16313 KMIN = I0 16314 DO 110 I4 = 4*I0+1, 4*N0-3, 4 16315 DEE = Z( I4 )*( DEE /( DEE+Z( I4-2 ) ) ) 16316 IF( DEE.LE.DEEMIN ) THEN 16317 DEEMIN = DEE 16318 KMIN = ( I4+3 )/4 16319 END IF 16320 110 CONTINUE 16321 IF( (KMIN-I0)*2.LT.N0-KMIN .AND. 16322 $ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN 16323 IPN4 = 4*( I0+N0 ) 16324 PP = 2 16325 DO 120 I4 = 4*I0, 2*( I0+N0-1 ), 4 16326 TEMP = Z( I4-3 ) 16327 Z( I4-3 ) = Z( IPN4-I4-3 ) 16328 Z( IPN4-I4-3 ) = TEMP 16329 TEMP = Z( I4-2 ) 16330 Z( I4-2 ) = Z( IPN4-I4-2 ) 16331 Z( IPN4-I4-2 ) = TEMP 16332 TEMP = Z( I4-1 ) 16333 Z( I4-1 ) = Z( IPN4-I4-5 ) 16334 Z( IPN4-I4-5 ) = TEMP 16335 TEMP = Z( I4 ) 16336 Z( I4 ) = Z( IPN4-I4-4 ) 16337 Z( IPN4-I4-4 ) = TEMP 16338 120 CONTINUE 16339 END IF 16340 END IF 16341 DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) 16342 NBIG = 100*( N0-I0+1 ) 16343 DO 140 IWHILB = 1, NBIG 16344 IF( I0.GT.N0 ) 16345 $ GO TO 150 16346 CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, 16347 $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, 16348 $ DN2, G, TAU ) 16349 PP = 1 - PP 16350 IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN 16351 IF( Z( 4*N0 ).LE.TOL2*QMAX .OR. 16352 $ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN 16353 SPLT = I0 - 1 16354 QMAX = Z( 4*I0-3 ) 16355 EMIN = Z( 4*I0-1 ) 16356 OLDEMN = Z( 4*I0 ) 16357 DO 130 I4 = 4*I0, 4*( N0-3 ), 4 16358 IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR. 16359 $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN 16360 Z( I4-1 ) = -SIGMA 16361 SPLT = I4 / 4 16362 QMAX = ZERO 16363 EMIN = Z( I4+3 ) 16364 OLDEMN = Z( I4+4 ) 16365 ELSE 16366 QMAX = MAX( QMAX, Z( I4+1 ) ) 16367 EMIN = MIN( EMIN, Z( I4-1 ) ) 16368 OLDEMN = MIN( OLDEMN, Z( I4 ) ) 16369 END IF 16370 130 CONTINUE 16371 Z( 4*N0-1 ) = EMIN 16372 Z( 4*N0 ) = OLDEMN 16373 I0 = SPLT + 1 16374 END IF 16375 END IF 16376 140 CONTINUE 16377 INFO = 2 16378 I1 = I0 16379 N1 = N0 16380 145 CONTINUE 16381 TEMPQ = Z( 4*I0-3 ) 16382 Z( 4*I0-3 ) = Z( 4*I0-3 ) + SIGMA 16383 DO K = I0+1, N0 16384 TEMPE = Z( 4*K-5 ) 16385 Z( 4*K-5 ) = Z( 4*K-5 ) * (TEMPQ / Z( 4*K-7 )) 16386 TEMPQ = Z( 4*K-3 ) 16387 Z( 4*K-3 ) = Z( 4*K-3 ) + SIGMA + TEMPE - Z( 4*K-5 ) 16388 END DO 16389 IF( I1.GT.1 ) THEN 16390 N1 = I1-1 16391 DO WHILE( ( I1.GE.2 ) .AND. ( Z(4*I1-5).GE.ZERO ) ) 16392 I1 = I1 - 1 16393 END DO 16394 SIGMA = -Z(4*N1-1) 16395 GO TO 145 16396 END IF 16397 DO K = 1, N 16398 Z( 2*K-1 ) = Z( 4*K-3 ) 16399 IF( K.LT.N0 ) THEN 16400 Z( 2*K ) = Z( 4*K-1 ) 16401 ELSE 16402 Z( 2*K ) = 0 16403 END IF 16404 END DO 16405 RETURN 16406 150 CONTINUE 16407 160 CONTINUE 16408 INFO = 3 16409 RETURN 16410 170 CONTINUE 16411 DO 180 K = 2, N 16412 Z( K ) = Z( 4*K-3 ) 16413 180 CONTINUE 16414 CALL DLASRT( 'D', N, Z, IINFO ) 16415 E = ZERO 16416 DO 190 K = N, 1, -1 16417 E = E + Z( K ) 16418 190 CONTINUE 16419 Z( 2*N+1 ) = TRACE 16420 Z( 2*N+2 ) = E 16421 Z( 2*N+3 ) = DBLE( ITER ) 16422 Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 ) 16423 Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER ) 16424 RETURN 16425 END 16426! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlasq3.f 16427 SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, 16428 $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, 16429 $ DN2, G, TAU ) 16430 LOGICAL IEEE 16431 INTEGER I0, ITER, N0, NDIV, NFAIL, PP 16432 DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, 16433 $ QMAX, SIGMA, TAU 16434 DOUBLE PRECISION Z( * ) 16435 DOUBLE PRECISION CBIAS 16436 PARAMETER ( CBIAS = 1.50D0 ) 16437 DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD 16438 PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, 16439 $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 ) 16440 INTEGER IPN4, J4, N0IN, NN, TTYPE 16441 DOUBLE PRECISION EPS, S, T, TEMP, TOL, TOL2 16442 EXTERNAL DLASQ4, DLASQ5, DLASQ6 16443 DOUBLE PRECISION DLAMCH 16444 LOGICAL DISNAN 16445 EXTERNAL DISNAN, DLAMCH 16446 INTRINSIC ABS, MAX, MIN, SQRT 16447 N0IN = N0 16448 EPS = DLAMCH( 'Precision' ) 16449 TOL = EPS*HUNDRD 16450 TOL2 = TOL**2 16451 10 CONTINUE 16452 IF( N0.LT.I0 ) 16453 $ RETURN 16454 IF( N0.EQ.I0 ) 16455 $ GO TO 20 16456 NN = 4*N0 + PP 16457 IF( N0.EQ.( I0+1 ) ) 16458 $ GO TO 40 16459 IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. 16460 $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) 16461 $ GO TO 30 16462 20 CONTINUE 16463 Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA 16464 N0 = N0 - 1 16465 GO TO 10 16466 30 CONTINUE 16467 IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. 16468 $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) 16469 $ GO TO 50 16470 40 CONTINUE 16471 IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN 16472 S = Z( NN-3 ) 16473 Z( NN-3 ) = Z( NN-7 ) 16474 Z( NN-7 ) = S 16475 END IF 16476 T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) 16477 IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2.AND.T.NE.ZERO ) THEN 16478 S = Z( NN-3 )*( Z( NN-5 ) / T ) 16479 IF( S.LE.T ) THEN 16480 S = Z( NN-3 )*( Z( NN-5 ) / 16481 $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) 16482 ELSE 16483 S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) 16484 END IF 16485 T = Z( NN-7 ) + ( S+Z( NN-5 ) ) 16486 Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) 16487 Z( NN-7 ) = T 16488 END IF 16489 Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA 16490 Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA 16491 N0 = N0 - 2 16492 GO TO 10 16493 50 CONTINUE 16494 IF( PP.EQ.2 ) 16495 $ PP = 0 16496 IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN 16497 IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN 16498 IPN4 = 4*( I0+N0 ) 16499 DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 16500 TEMP = Z( J4-3 ) 16501 Z( J4-3 ) = Z( IPN4-J4-3 ) 16502 Z( IPN4-J4-3 ) = TEMP 16503 TEMP = Z( J4-2 ) 16504 Z( J4-2 ) = Z( IPN4-J4-2 ) 16505 Z( IPN4-J4-2 ) = TEMP 16506 TEMP = Z( J4-1 ) 16507 Z( J4-1 ) = Z( IPN4-J4-5 ) 16508 Z( IPN4-J4-5 ) = TEMP 16509 TEMP = Z( J4 ) 16510 Z( J4 ) = Z( IPN4-J4-4 ) 16511 Z( IPN4-J4-4 ) = TEMP 16512 60 CONTINUE 16513 IF( N0-I0.LE.4 ) THEN 16514 Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) 16515 Z( 4*N0-PP ) = Z( 4*I0-PP ) 16516 END IF 16517 DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) 16518 Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), 16519 $ Z( 4*I0+PP+3 ) ) 16520 Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), 16521 $ Z( 4*I0-PP+4 ) ) 16522 QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) 16523 DMIN = -ZERO 16524 END IF 16525 END IF 16526 CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, 16527 $ DN2, TAU, TTYPE, G ) 16528 70 CONTINUE 16529 CALL DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, 16530 $ DN1, DN2, IEEE, EPS ) 16531 NDIV = NDIV + ( N0-I0+2 ) 16532 ITER = ITER + 1 16533 IF( DMIN.GE.ZERO .AND. DMIN1.GE.ZERO ) THEN 16534 GO TO 90 16535 ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. 16536 $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. 16537 $ ABS( DN ).LT.TOL*SIGMA ) THEN 16538 Z( 4*( N0-1 )-PP+2 ) = ZERO 16539 DMIN = ZERO 16540 GO TO 90 16541 ELSE IF( DMIN.LT.ZERO ) THEN 16542 NFAIL = NFAIL + 1 16543 IF( TTYPE.LT.-22 ) THEN 16544 TAU = ZERO 16545 ELSE IF( DMIN1.GT.ZERO ) THEN 16546 TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) 16547 TTYPE = TTYPE - 11 16548 ELSE 16549 TAU = QURTR*TAU 16550 TTYPE = TTYPE - 12 16551 END IF 16552 GO TO 70 16553 ELSE IF( DISNAN( DMIN ) ) THEN 16554 IF( TAU.EQ.ZERO ) THEN 16555 GO TO 80 16556 ELSE 16557 TAU = ZERO 16558 GO TO 70 16559 END IF 16560 ELSE 16561 GO TO 80 16562 END IF 16563 80 CONTINUE 16564 CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) 16565 NDIV = NDIV + ( N0-I0+2 ) 16566 ITER = ITER + 1 16567 TAU = ZERO 16568 90 CONTINUE 16569 IF( TAU.LT.SIGMA ) THEN 16570 DESIG = DESIG + TAU 16571 T = SIGMA + DESIG 16572 DESIG = DESIG - ( T-SIGMA ) 16573 ELSE 16574 T = SIGMA + TAU 16575 DESIG = SIGMA - ( T-TAU ) + DESIG 16576 END IF 16577 SIGMA = T 16578 RETURN 16579 END 16580! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlasq4.f 16581 SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, 16582 $ DN1, DN2, TAU, TTYPE, G ) 16583 INTEGER I0, N0, N0IN, PP, TTYPE 16584 DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU 16585 DOUBLE PRECISION Z( * ) 16586 DOUBLE PRECISION CNST1, CNST2, CNST3 16587 PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, 16588 $ CNST3 = 1.050D0 ) 16589 DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD 16590 PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, 16591 $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, 16592 $ TWO = 2.0D0, HUNDRD = 100.0D0 ) 16593 INTEGER I4, NN, NP 16594 DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S 16595 INTRINSIC MAX, MIN, SQRT 16596 IF( DMIN.LE.ZERO ) THEN 16597 TAU = -DMIN 16598 TTYPE = -1 16599 RETURN 16600 END IF 16601 NN = 4*N0 + PP 16602 IF( N0IN.EQ.N0 ) THEN 16603 IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN 16604 B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) 16605 B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) 16606 A2 = Z( NN-7 ) + Z( NN-5 ) 16607 IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN 16608 GAP2 = DMIN2 - A2 - DMIN2*QURTR 16609 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN 16610 GAP1 = A2 - DN - ( B2 / GAP2 )*B2 16611 ELSE 16612 GAP1 = A2 - DN - ( B1+B2 ) 16613 END IF 16614 IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN 16615 S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) 16616 TTYPE = -2 16617 ELSE 16618 S = ZERO 16619 IF( DN.GT.B1 ) 16620 $ S = DN - B1 16621 IF( A2.GT.( B1+B2 ) ) 16622 $ S = MIN( S, A2-( B1+B2 ) ) 16623 S = MAX( S, THIRD*DMIN ) 16624 TTYPE = -3 16625 END IF 16626 ELSE 16627 TTYPE = -4 16628 S = QURTR*DMIN 16629 IF( DMIN.EQ.DN ) THEN 16630 GAM = DN 16631 A2 = ZERO 16632 IF( Z( NN-5 ) .GT. Z( NN-7 ) ) 16633 $ RETURN 16634 B2 = Z( NN-5 ) / Z( NN-7 ) 16635 NP = NN - 9 16636 ELSE 16637 NP = NN - 2*PP 16638 GAM = DN1 16639 IF( Z( NP-4 ) .GT. Z( NP-2 ) ) 16640 $ RETURN 16641 A2 = Z( NP-4 ) / Z( NP-2 ) 16642 IF( Z( NN-9 ) .GT. Z( NN-11 ) ) 16643 $ RETURN 16644 B2 = Z( NN-9 ) / Z( NN-11 ) 16645 NP = NN - 13 16646 END IF 16647 A2 = A2 + B2 16648 DO 10 I4 = NP, 4*I0 - 1 + PP, -4 16649 IF( B2.EQ.ZERO ) 16650 $ GO TO 20 16651 B1 = B2 16652 IF( Z( I4 ) .GT. Z( I4-2 ) ) 16653 $ RETURN 16654 B2 = B2*( Z( I4 ) / Z( I4-2 ) ) 16655 A2 = A2 + B2 16656 IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) 16657 $ GO TO 20 16658 10 CONTINUE 16659 20 CONTINUE 16660 A2 = CNST3*A2 16661 IF( A2.LT.CNST1 ) 16662 $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) 16663 END IF 16664 ELSE IF( DMIN.EQ.DN2 ) THEN 16665 TTYPE = -5 16666 S = QURTR*DMIN 16667 NP = NN - 2*PP 16668 B1 = Z( NP-2 ) 16669 B2 = Z( NP-6 ) 16670 GAM = DN2 16671 IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) 16672 $ RETURN 16673 A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) 16674 IF( N0-I0.GT.2 ) THEN 16675 B2 = Z( NN-13 ) / Z( NN-15 ) 16676 A2 = A2 + B2 16677 DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 16678 IF( B2.EQ.ZERO ) 16679 $ GO TO 40 16680 B1 = B2 16681 IF( Z( I4 ) .GT. Z( I4-2 ) ) 16682 $ RETURN 16683 B2 = B2*( Z( I4 ) / Z( I4-2 ) ) 16684 A2 = A2 + B2 16685 IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) 16686 $ GO TO 40 16687 30 CONTINUE 16688 40 CONTINUE 16689 A2 = CNST3*A2 16690 END IF 16691 IF( A2.LT.CNST1 ) 16692 $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) 16693 ELSE 16694 IF( TTYPE.EQ.-6 ) THEN 16695 G = G + THIRD*( ONE-G ) 16696 ELSE IF( TTYPE.EQ.-18 ) THEN 16697 G = QURTR*THIRD 16698 ELSE 16699 G = QURTR 16700 END IF 16701 S = G*DMIN 16702 TTYPE = -6 16703 END IF 16704 ELSE IF( N0IN.EQ.( N0+1 ) ) THEN 16705 IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN 16706 TTYPE = -7 16707 S = THIRD*DMIN1 16708 IF( Z( NN-5 ).GT.Z( NN-7 ) ) 16709 $ RETURN 16710 B1 = Z( NN-5 ) / Z( NN-7 ) 16711 B2 = B1 16712 IF( B2.EQ.ZERO ) 16713 $ GO TO 60 16714 DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 16715 A2 = B1 16716 IF( Z( I4 ).GT.Z( I4-2 ) ) 16717 $ RETURN 16718 B1 = B1*( Z( I4 ) / Z( I4-2 ) ) 16719 B2 = B2 + B1 16720 IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) 16721 $ GO TO 60 16722 50 CONTINUE 16723 60 CONTINUE 16724 B2 = SQRT( CNST3*B2 ) 16725 A2 = DMIN1 / ( ONE+B2**2 ) 16726 GAP2 = HALF*DMIN2 - A2 16727 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN 16728 S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) 16729 ELSE 16730 S = MAX( S, A2*( ONE-CNST2*B2 ) ) 16731 TTYPE = -8 16732 END IF 16733 ELSE 16734 S = QURTR*DMIN1 16735 IF( DMIN1.EQ.DN1 ) 16736 $ S = HALF*DMIN1 16737 TTYPE = -9 16738 END IF 16739 ELSE IF( N0IN.EQ.( N0+2 ) ) THEN 16740 IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN 16741 TTYPE = -10 16742 S = THIRD*DMIN2 16743 IF( Z( NN-5 ).GT.Z( NN-7 ) ) 16744 $ RETURN 16745 B1 = Z( NN-5 ) / Z( NN-7 ) 16746 B2 = B1 16747 IF( B2.EQ.ZERO ) 16748 $ GO TO 80 16749 DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 16750 IF( Z( I4 ).GT.Z( I4-2 ) ) 16751 $ RETURN 16752 B1 = B1*( Z( I4 ) / Z( I4-2 ) ) 16753 B2 = B2 + B1 16754 IF( HUNDRD*B1.LT.B2 ) 16755 $ GO TO 80 16756 70 CONTINUE 16757 80 CONTINUE 16758 B2 = SQRT( CNST3*B2 ) 16759 A2 = DMIN2 / ( ONE+B2**2 ) 16760 GAP2 = Z( NN-7 ) + Z( NN-9 ) - 16761 $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 16762 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN 16763 S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) 16764 ELSE 16765 S = MAX( S, A2*( ONE-CNST2*B2 ) ) 16766 END IF 16767 ELSE 16768 S = QURTR*DMIN2 16769 TTYPE = -11 16770 END IF 16771 ELSE IF( N0IN.GT.( N0+2 ) ) THEN 16772 S = ZERO 16773 TTYPE = -12 16774 END IF 16775 TAU = S 16776 RETURN 16777 END 16778! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlasq5.f 16779 SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, 16780 $ DN, DNM1, DNM2, IEEE, EPS ) 16781 LOGICAL IEEE 16782 INTEGER I0, N0, PP 16783 DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU, 16784 $ SIGMA, EPS 16785 DOUBLE PRECISION Z( * ) 16786 DOUBLE PRECISION ZERO, HALF 16787 PARAMETER ( ZERO = 0.0D0, HALF = 0.5 ) 16788 INTEGER J4, J4P2 16789 DOUBLE PRECISION D, EMIN, TEMP, DTHRESH 16790 INTRINSIC MIN 16791 IF( ( N0-I0-1 ).LE.0 ) 16792 $ RETURN 16793 DTHRESH = EPS*(SIGMA+TAU) 16794 IF( TAU.LT.DTHRESH*HALF ) TAU = ZERO 16795 IF( TAU.NE.ZERO ) THEN 16796 J4 = 4*I0 + PP - 3 16797 EMIN = Z( J4+4 ) 16798 D = Z( J4 ) - TAU 16799 DMIN = D 16800 DMIN1 = -Z( J4 ) 16801 IF( IEEE ) THEN 16802 IF( PP.EQ.0 ) THEN 16803 DO 10 J4 = 4*I0, 4*( N0-3 ), 4 16804 Z( J4-2 ) = D + Z( J4-1 ) 16805 TEMP = Z( J4+1 ) / Z( J4-2 ) 16806 D = D*TEMP - TAU 16807 DMIN = MIN( DMIN, D ) 16808 Z( J4 ) = Z( J4-1 )*TEMP 16809 EMIN = MIN( Z( J4 ), EMIN ) 16810 10 CONTINUE 16811 ELSE 16812 DO 20 J4 = 4*I0, 4*( N0-3 ), 4 16813 Z( J4-3 ) = D + Z( J4 ) 16814 TEMP = Z( J4+2 ) / Z( J4-3 ) 16815 D = D*TEMP - TAU 16816 DMIN = MIN( DMIN, D ) 16817 Z( J4-1 ) = Z( J4 )*TEMP 16818 EMIN = MIN( Z( J4-1 ), EMIN ) 16819 20 CONTINUE 16820 END IF 16821 DNM2 = D 16822 DMIN2 = DMIN 16823 J4 = 4*( N0-2 ) - PP 16824 J4P2 = J4 + 2*PP - 1 16825 Z( J4-2 ) = DNM2 + Z( J4P2 ) 16826 Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) 16827 DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU 16828 DMIN = MIN( DMIN, DNM1 ) 16829 DMIN1 = DMIN 16830 J4 = J4 + 4 16831 J4P2 = J4 + 2*PP - 1 16832 Z( J4-2 ) = DNM1 + Z( J4P2 ) 16833 Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) 16834 DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU 16835 DMIN = MIN( DMIN, DN ) 16836 ELSE 16837 IF( PP.EQ.0 ) THEN 16838 DO 30 J4 = 4*I0, 4*( N0-3 ), 4 16839 Z( J4-2 ) = D + Z( J4-1 ) 16840 IF( D.LT.ZERO ) THEN 16841 RETURN 16842 ELSE 16843 Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) 16844 D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU 16845 END IF 16846 DMIN = MIN( DMIN, D ) 16847 EMIN = MIN( EMIN, Z( J4 ) ) 16848 30 CONTINUE 16849 ELSE 16850 DO 40 J4 = 4*I0, 4*( N0-3 ), 4 16851 Z( J4-3 ) = D + Z( J4 ) 16852 IF( D.LT.ZERO ) THEN 16853 RETURN 16854 ELSE 16855 Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) 16856 D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU 16857 END IF 16858 DMIN = MIN( DMIN, D ) 16859 EMIN = MIN( EMIN, Z( J4-1 ) ) 16860 40 CONTINUE 16861 END IF 16862 DNM2 = D 16863 DMIN2 = DMIN 16864 J4 = 4*( N0-2 ) - PP 16865 J4P2 = J4 + 2*PP - 1 16866 Z( J4-2 ) = DNM2 + Z( J4P2 ) 16867 IF( DNM2.LT.ZERO ) THEN 16868 RETURN 16869 ELSE 16870 Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) 16871 DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU 16872 END IF 16873 DMIN = MIN( DMIN, DNM1 ) 16874 DMIN1 = DMIN 16875 J4 = J4 + 4 16876 J4P2 = J4 + 2*PP - 1 16877 Z( J4-2 ) = DNM1 + Z( J4P2 ) 16878 IF( DNM1.LT.ZERO ) THEN 16879 RETURN 16880 ELSE 16881 Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) 16882 DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU 16883 END IF 16884 DMIN = MIN( DMIN, DN ) 16885 END IF 16886 ELSE 16887 J4 = 4*I0 + PP - 3 16888 EMIN = Z( J4+4 ) 16889 D = Z( J4 ) - TAU 16890 DMIN = D 16891 DMIN1 = -Z( J4 ) 16892 IF( IEEE ) THEN 16893 IF( PP.EQ.0 ) THEN 16894 DO 50 J4 = 4*I0, 4*( N0-3 ), 4 16895 Z( J4-2 ) = D + Z( J4-1 ) 16896 TEMP = Z( J4+1 ) / Z( J4-2 ) 16897 D = D*TEMP - TAU 16898 IF( D.LT.DTHRESH ) D = ZERO 16899 DMIN = MIN( DMIN, D ) 16900 Z( J4 ) = Z( J4-1 )*TEMP 16901 EMIN = MIN( Z( J4 ), EMIN ) 16902 50 CONTINUE 16903 ELSE 16904 DO 60 J4 = 4*I0, 4*( N0-3 ), 4 16905 Z( J4-3 ) = D + Z( J4 ) 16906 TEMP = Z( J4+2 ) / Z( J4-3 ) 16907 D = D*TEMP - TAU 16908 IF( D.LT.DTHRESH ) D = ZERO 16909 DMIN = MIN( DMIN, D ) 16910 Z( J4-1 ) = Z( J4 )*TEMP 16911 EMIN = MIN( Z( J4-1 ), EMIN ) 16912 60 CONTINUE 16913 END IF 16914 DNM2 = D 16915 DMIN2 = DMIN 16916 J4 = 4*( N0-2 ) - PP 16917 J4P2 = J4 + 2*PP - 1 16918 Z( J4-2 ) = DNM2 + Z( J4P2 ) 16919 Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) 16920 DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU 16921 DMIN = MIN( DMIN, DNM1 ) 16922 DMIN1 = DMIN 16923 J4 = J4 + 4 16924 J4P2 = J4 + 2*PP - 1 16925 Z( J4-2 ) = DNM1 + Z( J4P2 ) 16926 Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) 16927 DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU 16928 DMIN = MIN( DMIN, DN ) 16929 ELSE 16930 IF( PP.EQ.0 ) THEN 16931 DO 70 J4 = 4*I0, 4*( N0-3 ), 4 16932 Z( J4-2 ) = D + Z( J4-1 ) 16933 IF( D.LT.ZERO ) THEN 16934 RETURN 16935 ELSE 16936 Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) 16937 D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU 16938 END IF 16939 IF( D.LT.DTHRESH) D = ZERO 16940 DMIN = MIN( DMIN, D ) 16941 EMIN = MIN( EMIN, Z( J4 ) ) 16942 70 CONTINUE 16943 ELSE 16944 DO 80 J4 = 4*I0, 4*( N0-3 ), 4 16945 Z( J4-3 ) = D + Z( J4 ) 16946 IF( D.LT.ZERO ) THEN 16947 RETURN 16948 ELSE 16949 Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) 16950 D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU 16951 END IF 16952 IF( D.LT.DTHRESH) D = ZERO 16953 DMIN = MIN( DMIN, D ) 16954 EMIN = MIN( EMIN, Z( J4-1 ) ) 16955 80 CONTINUE 16956 END IF 16957 DNM2 = D 16958 DMIN2 = DMIN 16959 J4 = 4*( N0-2 ) - PP 16960 J4P2 = J4 + 2*PP - 1 16961 Z( J4-2 ) = DNM2 + Z( J4P2 ) 16962 IF( DNM2.LT.ZERO ) THEN 16963 RETURN 16964 ELSE 16965 Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) 16966 DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU 16967 END IF 16968 DMIN = MIN( DMIN, DNM1 ) 16969 DMIN1 = DMIN 16970 J4 = J4 + 4 16971 J4P2 = J4 + 2*PP - 1 16972 Z( J4-2 ) = DNM1 + Z( J4P2 ) 16973 IF( DNM1.LT.ZERO ) THEN 16974 RETURN 16975 ELSE 16976 Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) 16977 DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU 16978 END IF 16979 DMIN = MIN( DMIN, DN ) 16980 END IF 16981 END IF 16982 Z( J4+2 ) = DN 16983 Z( 4*N0-PP ) = EMIN 16984 RETURN 16985 END 16986! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlasq6.f 16987 SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, 16988 $ DNM1, DNM2 ) 16989 INTEGER I0, N0, PP 16990 DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 16991 DOUBLE PRECISION Z( * ) 16992 DOUBLE PRECISION ZERO 16993 PARAMETER ( ZERO = 0.0D0 ) 16994 INTEGER J4, J4P2 16995 DOUBLE PRECISION D, EMIN, SAFMIN, TEMP 16996 DOUBLE PRECISION DLAMCH 16997 EXTERNAL DLAMCH 16998 INTRINSIC MIN 16999 IF( ( N0-I0-1 ).LE.0 ) 17000 $ RETURN 17001 SAFMIN = DLAMCH( 'Safe minimum' ) 17002 J4 = 4*I0 + PP - 3 17003 EMIN = Z( J4+4 ) 17004 D = Z( J4 ) 17005 DMIN = D 17006 IF( PP.EQ.0 ) THEN 17007 DO 10 J4 = 4*I0, 4*( N0-3 ), 4 17008 Z( J4-2 ) = D + Z( J4-1 ) 17009 IF( Z( J4-2 ).EQ.ZERO ) THEN 17010 Z( J4 ) = ZERO 17011 D = Z( J4+1 ) 17012 DMIN = D 17013 EMIN = ZERO 17014 ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND. 17015 $ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN 17016 TEMP = Z( J4+1 ) / Z( J4-2 ) 17017 Z( J4 ) = Z( J4-1 )*TEMP 17018 D = D*TEMP 17019 ELSE 17020 Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) 17021 D = Z( J4+1 )*( D / Z( J4-2 ) ) 17022 END IF 17023 DMIN = MIN( DMIN, D ) 17024 EMIN = MIN( EMIN, Z( J4 ) ) 17025 10 CONTINUE 17026 ELSE 17027 DO 20 J4 = 4*I0, 4*( N0-3 ), 4 17028 Z( J4-3 ) = D + Z( J4 ) 17029 IF( Z( J4-3 ).EQ.ZERO ) THEN 17030 Z( J4-1 ) = ZERO 17031 D = Z( J4+2 ) 17032 DMIN = D 17033 EMIN = ZERO 17034 ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND. 17035 $ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN 17036 TEMP = Z( J4+2 ) / Z( J4-3 ) 17037 Z( J4-1 ) = Z( J4 )*TEMP 17038 D = D*TEMP 17039 ELSE 17040 Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) 17041 D = Z( J4+2 )*( D / Z( J4-3 ) ) 17042 END IF 17043 DMIN = MIN( DMIN, D ) 17044 EMIN = MIN( EMIN, Z( J4-1 ) ) 17045 20 CONTINUE 17046 END IF 17047 DNM2 = D 17048 DMIN2 = DMIN 17049 J4 = 4*( N0-2 ) - PP 17050 J4P2 = J4 + 2*PP - 1 17051 Z( J4-2 ) = DNM2 + Z( J4P2 ) 17052 IF( Z( J4-2 ).EQ.ZERO ) THEN 17053 Z( J4 ) = ZERO 17054 DNM1 = Z( J4P2+2 ) 17055 DMIN = DNM1 17056 EMIN = ZERO 17057 ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. 17058 $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN 17059 TEMP = Z( J4P2+2 ) / Z( J4-2 ) 17060 Z( J4 ) = Z( J4P2 )*TEMP 17061 DNM1 = DNM2*TEMP 17062 ELSE 17063 Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) 17064 DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) 17065 END IF 17066 DMIN = MIN( DMIN, DNM1 ) 17067 DMIN1 = DMIN 17068 J4 = J4 + 4 17069 J4P2 = J4 + 2*PP - 1 17070 Z( J4-2 ) = DNM1 + Z( J4P2 ) 17071 IF( Z( J4-2 ).EQ.ZERO ) THEN 17072 Z( J4 ) = ZERO 17073 DN = Z( J4P2+2 ) 17074 DMIN = DN 17075 EMIN = ZERO 17076 ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. 17077 $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN 17078 TEMP = Z( J4P2+2 ) / Z( J4-2 ) 17079 Z( J4 ) = Z( J4P2 )*TEMP 17080 DN = DNM1*TEMP 17081 ELSE 17082 Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) 17083 DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) 17084 END IF 17085 DMIN = MIN( DMIN, DN ) 17086 Z( J4+2 ) = DN 17087 Z( 4*N0-PP ) = EMIN 17088 RETURN 17089 END 17090! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlasr.f 17091 SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) 17092 CHARACTER DIRECT, PIVOT, SIDE 17093 INTEGER LDA, M, N 17094 DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) 17095 DOUBLE PRECISION ONE, ZERO 17096 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 17097 INTEGER I, INFO, J 17098 DOUBLE PRECISION CTEMP, STEMP, TEMP 17099 LOGICAL LSAME 17100 EXTERNAL LSAME 17101 EXTERNAL XERBLA 17102 INTRINSIC MAX 17103 INFO = 0 17104 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN 17105 INFO = 1 17106 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, 17107 $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN 17108 INFO = 2 17109 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) 17110 $ THEN 17111 INFO = 3 17112 ELSE IF( M.LT.0 ) THEN 17113 INFO = 4 17114 ELSE IF( N.LT.0 ) THEN 17115 INFO = 5 17116 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 17117 INFO = 9 17118 END IF 17119 IF( INFO.NE.0 ) THEN 17120 CALL XERBLA( 'DLASR ', INFO ) 17121 RETURN 17122 END IF 17123 IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) 17124 $ RETURN 17125 IF( LSAME( SIDE, 'L' ) ) THEN 17126 IF( LSAME( PIVOT, 'V' ) ) THEN 17127 IF( LSAME( DIRECT, 'F' ) ) THEN 17128 DO 20 J = 1, M - 1 17129 CTEMP = C( J ) 17130 STEMP = S( J ) 17131 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17132 DO 10 I = 1, N 17133 TEMP = A( J+1, I ) 17134 A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) 17135 A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 17136 10 CONTINUE 17137 END IF 17138 20 CONTINUE 17139 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 17140 DO 40 J = M - 1, 1, -1 17141 CTEMP = C( J ) 17142 STEMP = S( J ) 17143 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17144 DO 30 I = 1, N 17145 TEMP = A( J+1, I ) 17146 A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) 17147 A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 17148 30 CONTINUE 17149 END IF 17150 40 CONTINUE 17151 END IF 17152 ELSE IF( LSAME( PIVOT, 'T' ) ) THEN 17153 IF( LSAME( DIRECT, 'F' ) ) THEN 17154 DO 60 J = 2, M 17155 CTEMP = C( J-1 ) 17156 STEMP = S( J-1 ) 17157 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17158 DO 50 I = 1, N 17159 TEMP = A( J, I ) 17160 A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) 17161 A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 17162 50 CONTINUE 17163 END IF 17164 60 CONTINUE 17165 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 17166 DO 80 J = M, 2, -1 17167 CTEMP = C( J-1 ) 17168 STEMP = S( J-1 ) 17169 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17170 DO 70 I = 1, N 17171 TEMP = A( J, I ) 17172 A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) 17173 A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 17174 70 CONTINUE 17175 END IF 17176 80 CONTINUE 17177 END IF 17178 ELSE IF( LSAME( PIVOT, 'B' ) ) THEN 17179 IF( LSAME( DIRECT, 'F' ) ) THEN 17180 DO 100 J = 1, M - 1 17181 CTEMP = C( J ) 17182 STEMP = S( J ) 17183 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17184 DO 90 I = 1, N 17185 TEMP = A( J, I ) 17186 A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP 17187 A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 17188 90 CONTINUE 17189 END IF 17190 100 CONTINUE 17191 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 17192 DO 120 J = M - 1, 1, -1 17193 CTEMP = C( J ) 17194 STEMP = S( J ) 17195 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17196 DO 110 I = 1, N 17197 TEMP = A( J, I ) 17198 A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP 17199 A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 17200 110 CONTINUE 17201 END IF 17202 120 CONTINUE 17203 END IF 17204 END IF 17205 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 17206 IF( LSAME( PIVOT, 'V' ) ) THEN 17207 IF( LSAME( DIRECT, 'F' ) ) THEN 17208 DO 140 J = 1, N - 1 17209 CTEMP = C( J ) 17210 STEMP = S( J ) 17211 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17212 DO 130 I = 1, M 17213 TEMP = A( I, J+1 ) 17214 A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) 17215 A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 17216 130 CONTINUE 17217 END IF 17218 140 CONTINUE 17219 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 17220 DO 160 J = N - 1, 1, -1 17221 CTEMP = C( J ) 17222 STEMP = S( J ) 17223 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17224 DO 150 I = 1, M 17225 TEMP = A( I, J+1 ) 17226 A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) 17227 A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 17228 150 CONTINUE 17229 END IF 17230 160 CONTINUE 17231 END IF 17232 ELSE IF( LSAME( PIVOT, 'T' ) ) THEN 17233 IF( LSAME( DIRECT, 'F' ) ) THEN 17234 DO 180 J = 2, N 17235 CTEMP = C( J-1 ) 17236 STEMP = S( J-1 ) 17237 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17238 DO 170 I = 1, M 17239 TEMP = A( I, J ) 17240 A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) 17241 A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 17242 170 CONTINUE 17243 END IF 17244 180 CONTINUE 17245 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 17246 DO 200 J = N, 2, -1 17247 CTEMP = C( J-1 ) 17248 STEMP = S( J-1 ) 17249 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17250 DO 190 I = 1, M 17251 TEMP = A( I, J ) 17252 A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) 17253 A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 17254 190 CONTINUE 17255 END IF 17256 200 CONTINUE 17257 END IF 17258 ELSE IF( LSAME( PIVOT, 'B' ) ) THEN 17259 IF( LSAME( DIRECT, 'F' ) ) THEN 17260 DO 220 J = 1, N - 1 17261 CTEMP = C( J ) 17262 STEMP = S( J ) 17263 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17264 DO 210 I = 1, M 17265 TEMP = A( I, J ) 17266 A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP 17267 A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 17268 210 CONTINUE 17269 END IF 17270 220 CONTINUE 17271 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 17272 DO 240 J = N - 1, 1, -1 17273 CTEMP = C( J ) 17274 STEMP = S( J ) 17275 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 17276 DO 230 I = 1, M 17277 TEMP = A( I, J ) 17278 A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP 17279 A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 17280 230 CONTINUE 17281 END IF 17282 240 CONTINUE 17283 END IF 17284 END IF 17285 END IF 17286 RETURN 17287 END 17288! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlasrt.f 17289 SUBROUTINE DLASRT( ID, N, D, INFO ) 17290 CHARACTER ID 17291 INTEGER INFO, N 17292 DOUBLE PRECISION D( * ) 17293 INTEGER SELECT 17294 PARAMETER ( SELECT = 20 ) 17295 INTEGER DIR, ENDD, I, J, START, STKPNT 17296 DOUBLE PRECISION D1, D2, D3, DMNMX, TMP 17297 INTEGER STACK( 2, 32 ) 17298 LOGICAL LSAME 17299 EXTERNAL LSAME 17300 EXTERNAL XERBLA 17301 INFO = 0 17302 DIR = -1 17303 IF( LSAME( ID, 'D' ) ) THEN 17304 DIR = 0 17305 ELSE IF( LSAME( ID, 'I' ) ) THEN 17306 DIR = 1 17307 END IF 17308 IF( DIR.EQ.-1 ) THEN 17309 INFO = -1 17310 ELSE IF( N.LT.0 ) THEN 17311 INFO = -2 17312 END IF 17313 IF( INFO.NE.0 ) THEN 17314 CALL XERBLA( 'DLASRT', -INFO ) 17315 RETURN 17316 END IF 17317 IF( N.LE.1 ) 17318 $ RETURN 17319 STKPNT = 1 17320 STACK( 1, 1 ) = 1 17321 STACK( 2, 1 ) = N 17322 10 CONTINUE 17323 START = STACK( 1, STKPNT ) 17324 ENDD = STACK( 2, STKPNT ) 17325 STKPNT = STKPNT - 1 17326 IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN 17327 IF( DIR.EQ.0 ) THEN 17328 DO 30 I = START + 1, ENDD 17329 DO 20 J = I, START + 1, -1 17330 IF( D( J ).GT.D( J-1 ) ) THEN 17331 DMNMX = D( J ) 17332 D( J ) = D( J-1 ) 17333 D( J-1 ) = DMNMX 17334 ELSE 17335 GO TO 30 17336 END IF 17337 20 CONTINUE 17338 30 CONTINUE 17339 ELSE 17340 DO 50 I = START + 1, ENDD 17341 DO 40 J = I, START + 1, -1 17342 IF( D( J ).LT.D( J-1 ) ) THEN 17343 DMNMX = D( J ) 17344 D( J ) = D( J-1 ) 17345 D( J-1 ) = DMNMX 17346 ELSE 17347 GO TO 50 17348 END IF 17349 40 CONTINUE 17350 50 CONTINUE 17351 END IF 17352 ELSE IF( ENDD-START.GT.SELECT ) THEN 17353 D1 = D( START ) 17354 D2 = D( ENDD ) 17355 I = ( START+ENDD ) / 2 17356 D3 = D( I ) 17357 IF( D1.LT.D2 ) THEN 17358 IF( D3.LT.D1 ) THEN 17359 DMNMX = D1 17360 ELSE IF( D3.LT.D2 ) THEN 17361 DMNMX = D3 17362 ELSE 17363 DMNMX = D2 17364 END IF 17365 ELSE 17366 IF( D3.LT.D2 ) THEN 17367 DMNMX = D2 17368 ELSE IF( D3.LT.D1 ) THEN 17369 DMNMX = D3 17370 ELSE 17371 DMNMX = D1 17372 END IF 17373 END IF 17374 IF( DIR.EQ.0 ) THEN 17375 I = START - 1 17376 J = ENDD + 1 17377 60 CONTINUE 17378 70 CONTINUE 17379 J = J - 1 17380 IF( D( J ).LT.DMNMX ) 17381 $ GO TO 70 17382 80 CONTINUE 17383 I = I + 1 17384 IF( D( I ).GT.DMNMX ) 17385 $ GO TO 80 17386 IF( I.LT.J ) THEN 17387 TMP = D( I ) 17388 D( I ) = D( J ) 17389 D( J ) = TMP 17390 GO TO 60 17391 END IF 17392 IF( J-START.GT.ENDD-J-1 ) THEN 17393 STKPNT = STKPNT + 1 17394 STACK( 1, STKPNT ) = START 17395 STACK( 2, STKPNT ) = J 17396 STKPNT = STKPNT + 1 17397 STACK( 1, STKPNT ) = J + 1 17398 STACK( 2, STKPNT ) = ENDD 17399 ELSE 17400 STKPNT = STKPNT + 1 17401 STACK( 1, STKPNT ) = J + 1 17402 STACK( 2, STKPNT ) = ENDD 17403 STKPNT = STKPNT + 1 17404 STACK( 1, STKPNT ) = START 17405 STACK( 2, STKPNT ) = J 17406 END IF 17407 ELSE 17408 I = START - 1 17409 J = ENDD + 1 17410 90 CONTINUE 17411 100 CONTINUE 17412 J = J - 1 17413 IF( D( J ).GT.DMNMX ) 17414 $ GO TO 100 17415 110 CONTINUE 17416 I = I + 1 17417 IF( D( I ).LT.DMNMX ) 17418 $ GO TO 110 17419 IF( I.LT.J ) THEN 17420 TMP = D( I ) 17421 D( I ) = D( J ) 17422 D( J ) = TMP 17423 GO TO 90 17424 END IF 17425 IF( J-START.GT.ENDD-J-1 ) THEN 17426 STKPNT = STKPNT + 1 17427 STACK( 1, STKPNT ) = START 17428 STACK( 2, STKPNT ) = J 17429 STKPNT = STKPNT + 1 17430 STACK( 1, STKPNT ) = J + 1 17431 STACK( 2, STKPNT ) = ENDD 17432 ELSE 17433 STKPNT = STKPNT + 1 17434 STACK( 1, STKPNT ) = J + 1 17435 STACK( 2, STKPNT ) = ENDD 17436 STKPNT = STKPNT + 1 17437 STACK( 1, STKPNT ) = START 17438 STACK( 2, STKPNT ) = J 17439 END IF 17440 END IF 17441 END IF 17442 IF( STKPNT.GT.0 ) 17443 $ GO TO 10 17444 RETURN 17445 END 17446! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlassq.f 17447 SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) 17448 INTEGER INCX, N 17449 DOUBLE PRECISION SCALE, SUMSQ 17450 DOUBLE PRECISION X( * ) 17451 DOUBLE PRECISION ZERO 17452 PARAMETER ( ZERO = 0.0D+0 ) 17453 INTEGER IX 17454 DOUBLE PRECISION ABSXI 17455 LOGICAL DISNAN 17456 EXTERNAL DISNAN 17457 INTRINSIC ABS 17458 IF( N.GT.0 ) THEN 17459 DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX 17460 ABSXI = ABS( X( IX ) ) 17461 IF( ABSXI.GT.ZERO.OR.DISNAN( ABSXI ) ) THEN 17462 IF( SCALE.LT.ABSXI ) THEN 17463 SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 17464 SCALE = ABSXI 17465 ELSE 17466 SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 17467 END IF 17468 END IF 17469 10 CONTINUE 17470 END IF 17471 RETURN 17472 END 17473! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlasv2.f 17474 SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) 17475 DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN 17476 DOUBLE PRECISION ZERO 17477 PARAMETER ( ZERO = 0.0D0 ) 17478 DOUBLE PRECISION HALF 17479 PARAMETER ( HALF = 0.5D0 ) 17480 DOUBLE PRECISION ONE 17481 PARAMETER ( ONE = 1.0D0 ) 17482 DOUBLE PRECISION TWO 17483 PARAMETER ( TWO = 2.0D0 ) 17484 DOUBLE PRECISION FOUR 17485 PARAMETER ( FOUR = 4.0D0 ) 17486 LOGICAL GASMAL, SWAP 17487 INTEGER PMAX 17488 DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, 17489 $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT 17490 INTRINSIC ABS, SIGN, SQRT 17491 DOUBLE PRECISION DLAMCH 17492 EXTERNAL DLAMCH 17493 FT = F 17494 FA = ABS( FT ) 17495 HT = H 17496 HA = ABS( H ) 17497 PMAX = 1 17498 SWAP = ( HA.GT.FA ) 17499 IF( SWAP ) THEN 17500 PMAX = 3 17501 TEMP = FT 17502 FT = HT 17503 HT = TEMP 17504 TEMP = FA 17505 FA = HA 17506 HA = TEMP 17507 END IF 17508 GT = G 17509 GA = ABS( GT ) 17510 IF( GA.EQ.ZERO ) THEN 17511 SSMIN = HA 17512 SSMAX = FA 17513 CLT = ONE 17514 CRT = ONE 17515 SLT = ZERO 17516 SRT = ZERO 17517 ELSE 17518 GASMAL = .TRUE. 17519 IF( GA.GT.FA ) THEN 17520 PMAX = 2 17521 IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN 17522 GASMAL = .FALSE. 17523 SSMAX = GA 17524 IF( HA.GT.ONE ) THEN 17525 SSMIN = FA / ( GA / HA ) 17526 ELSE 17527 SSMIN = ( FA / GA )*HA 17528 END IF 17529 CLT = ONE 17530 SLT = HT / GT 17531 SRT = ONE 17532 CRT = FT / GT 17533 END IF 17534 END IF 17535 IF( GASMAL ) THEN 17536 D = FA - HA 17537 IF( D.EQ.FA ) THEN 17538 L = ONE 17539 ELSE 17540 L = D / FA 17541 END IF 17542 M = GT / FT 17543 T = TWO - L 17544 MM = M*M 17545 TT = T*T 17546 S = SQRT( TT+MM ) 17547 IF( L.EQ.ZERO ) THEN 17548 R = ABS( M ) 17549 ELSE 17550 R = SQRT( L*L+MM ) 17551 END IF 17552 A = HALF*( S+R ) 17553 SSMIN = HA / A 17554 SSMAX = FA*A 17555 IF( MM.EQ.ZERO ) THEN 17556 IF( L.EQ.ZERO ) THEN 17557 T = SIGN( TWO, FT )*SIGN( ONE, GT ) 17558 ELSE 17559 T = GT / SIGN( D, FT ) + M / T 17560 END IF 17561 ELSE 17562 T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) 17563 END IF 17564 L = SQRT( T*T+FOUR ) 17565 CRT = TWO / L 17566 SRT = T / L 17567 CLT = ( CRT+SRT*M ) / A 17568 SLT = ( HT / FT )*SRT / A 17569 END IF 17570 END IF 17571 IF( SWAP ) THEN 17572 CSL = SRT 17573 SNL = CRT 17574 CSR = SLT 17575 SNR = CLT 17576 ELSE 17577 CSL = CLT 17578 SNL = SLT 17579 CSR = CRT 17580 SNR = SRT 17581 END IF 17582 IF( PMAX.EQ.1 ) 17583 $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) 17584 IF( PMAX.EQ.2 ) 17585 $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) 17586 IF( PMAX.EQ.3 ) 17587 $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) 17588 SSMAX = SIGN( SSMAX, TSIGN ) 17589 SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) 17590 RETURN 17591 END 17592! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlaswp.f 17593 SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) 17594 INTEGER INCX, K1, K2, LDA, N 17595 INTEGER IPIV( * ) 17596 DOUBLE PRECISION A( LDA, * ) 17597 INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 17598 DOUBLE PRECISION TEMP 17599 IF( INCX.GT.0 ) THEN 17600 IX0 = K1 17601 I1 = K1 17602 I2 = K2 17603 INC = 1 17604 ELSE IF( INCX.LT.0 ) THEN 17605 IX0 = K1 + ( K1-K2 )*INCX 17606 I1 = K2 17607 I2 = K1 17608 INC = -1 17609 ELSE 17610 RETURN 17611 END IF 17612 N32 = ( N / 32 )*32 17613 IF( N32.NE.0 ) THEN 17614 DO 30 J = 1, N32, 32 17615 IX = IX0 17616 DO 20 I = I1, I2, INC 17617 IP = IPIV( IX ) 17618 IF( IP.NE.I ) THEN 17619 DO 10 K = J, J + 31 17620 TEMP = A( I, K ) 17621 A( I, K ) = A( IP, K ) 17622 A( IP, K ) = TEMP 17623 10 CONTINUE 17624 END IF 17625 IX = IX + INCX 17626 20 CONTINUE 17627 30 CONTINUE 17628 END IF 17629 IF( N32.NE.N ) THEN 17630 N32 = N32 + 1 17631 IX = IX0 17632 DO 50 I = I1, I2, INC 17633 IP = IPIV( IX ) 17634 IF( IP.NE.I ) THEN 17635 DO 40 K = N32, N 17636 TEMP = A( I, K ) 17637 A( I, K ) = A( IP, K ) 17638 A( IP, K ) = TEMP 17639 40 CONTINUE 17640 END IF 17641 IX = IX + INCX 17642 50 CONTINUE 17643 END IF 17644 RETURN 17645 END 17646! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlasyf.f 17647 SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) 17648 CHARACTER UPLO 17649 INTEGER INFO, KB, LDA, LDW, N, NB 17650 INTEGER IPIV( * ) 17651 DOUBLE PRECISION A( LDA, * ), W( LDW, * ) 17652 DOUBLE PRECISION ZERO, ONE 17653 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 17654 DOUBLE PRECISION EIGHT, SEVTEN 17655 PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) 17656 INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, 17657 $ KSTEP, KW 17658 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1, 17659 $ ROWMAX, T 17660 LOGICAL LSAME 17661 INTEGER IDAMAX 17662 EXTERNAL LSAME, IDAMAX 17663 EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP 17664 INTRINSIC ABS, MAX, MIN, SQRT 17665 INFO = 0 17666 ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT 17667 IF( LSAME( UPLO, 'U' ) ) THEN 17668 K = N 17669 10 CONTINUE 17670 KW = NB + K - N 17671 IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) 17672 $ GO TO 30 17673 CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) 17674 IF( K.LT.N ) 17675 $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA, 17676 $ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) 17677 KSTEP = 1 17678 ABSAKK = ABS( W( K, KW ) ) 17679 IF( K.GT.1 ) THEN 17680 IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) 17681 COLMAX = ABS( W( IMAX, KW ) ) 17682 ELSE 17683 COLMAX = ZERO 17684 END IF 17685 IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN 17686 IF( INFO.EQ.0 ) 17687 $ INFO = K 17688 KP = K 17689 ELSE 17690 IF( ABSAKK.GE.ALPHA*COLMAX ) THEN 17691 KP = K 17692 ELSE 17693 CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) 17694 CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, 17695 $ W( IMAX+1, KW-1 ), 1 ) 17696 IF( K.LT.N ) 17697 $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), 17698 $ LDA, W( IMAX, KW+1 ), LDW, ONE, 17699 $ W( 1, KW-1 ), 1 ) 17700 JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 ) 17701 ROWMAX = ABS( W( JMAX, KW-1 ) ) 17702 IF( IMAX.GT.1 ) THEN 17703 JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 ) 17704 ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) ) 17705 END IF 17706 IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN 17707 KP = K 17708 ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN 17709 KP = IMAX 17710 CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) 17711 ELSE 17712 KP = IMAX 17713 KSTEP = 2 17714 END IF 17715 END IF 17716 KK = K - KSTEP + 1 17717 KKW = NB + KK - N 17718 IF( KP.NE.KK ) THEN 17719 A( KP, KP ) = A( KK, KK ) 17720 CALL DCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), 17721 $ LDA ) 17722 IF( KP.GT.1 ) 17723 $ CALL DCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) 17724 IF( K.LT.N ) 17725 $ CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), 17726 $ LDA ) 17727 CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), 17728 $ LDW ) 17729 END IF 17730 IF( KSTEP.EQ.1 ) THEN 17731 CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) 17732 R1 = ONE / A( K, K ) 17733 CALL DSCAL( K-1, R1, A( 1, K ), 1 ) 17734 ELSE 17735 IF( K.GT.2 ) THEN 17736 D21 = W( K-1, KW ) 17737 D11 = W( K, KW ) / D21 17738 D22 = W( K-1, KW-1 ) / D21 17739 T = ONE / ( D11*D22-ONE ) 17740 D21 = T / D21 17741 DO 20 J = 1, K - 2 17742 A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) 17743 A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) 17744 20 CONTINUE 17745 END IF 17746 A( K-1, K-1 ) = W( K-1, KW-1 ) 17747 A( K-1, K ) = W( K-1, KW ) 17748 A( K, K ) = W( K, KW ) 17749 END IF 17750 END IF 17751 IF( KSTEP.EQ.1 ) THEN 17752 IPIV( K ) = KP 17753 ELSE 17754 IPIV( K ) = -KP 17755 IPIV( K-1 ) = -KP 17756 END IF 17757 K = K - KSTEP 17758 GO TO 10 17759 30 CONTINUE 17760 DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB 17761 JB = MIN( NB, K-J+1 ) 17762 DO 40 JJ = J, J + JB - 1 17763 CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, 17764 $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, 17765 $ A( J, JJ ), 1 ) 17766 40 CONTINUE 17767 CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE, 17768 $ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE, 17769 $ A( 1, J ), LDA ) 17770 50 CONTINUE 17771 J = K + 1 17772 60 CONTINUE 17773 JJ = J 17774 JP = IPIV( J ) 17775 IF( JP.LT.0 ) THEN 17776 JP = -JP 17777 J = J + 1 17778 END IF 17779 J = J + 1 17780 IF( JP.NE.JJ .AND. J.LE.N ) 17781 $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) 17782 IF( J.LT.N ) 17783 $ GO TO 60 17784 KB = N - K 17785 ELSE 17786 K = 1 17787 70 CONTINUE 17788 IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) 17789 $ GO TO 90 17790 CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) 17791 CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA, 17792 $ W( K, 1 ), LDW, ONE, W( K, K ), 1 ) 17793 KSTEP = 1 17794 ABSAKK = ABS( W( K, K ) ) 17795 IF( K.LT.N ) THEN 17796 IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) 17797 COLMAX = ABS( W( IMAX, K ) ) 17798 ELSE 17799 COLMAX = ZERO 17800 END IF 17801 IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN 17802 IF( INFO.EQ.0 ) 17803 $ INFO = K 17804 KP = K 17805 ELSE 17806 IF( ABSAKK.GE.ALPHA*COLMAX ) THEN 17807 KP = K 17808 ELSE 17809 CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) 17810 CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), 17811 $ 1 ) 17812 CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), 17813 $ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 ) 17814 JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 ) 17815 ROWMAX = ABS( W( JMAX, K+1 ) ) 17816 IF( IMAX.LT.N ) THEN 17817 JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 ) 17818 ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) ) 17819 END IF 17820 IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN 17821 KP = K 17822 ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN 17823 KP = IMAX 17824 CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) 17825 ELSE 17826 KP = IMAX 17827 KSTEP = 2 17828 END IF 17829 END IF 17830 KK = K + KSTEP - 1 17831 IF( KP.NE.KK ) THEN 17832 A( KP, KP ) = A( KK, KK ) 17833 CALL DCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), 17834 $ LDA ) 17835 IF( KP.LT.N ) 17836 $ CALL DCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) 17837 IF( K.GT.1 ) 17838 $ CALL DSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) 17839 CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) 17840 END IF 17841 IF( KSTEP.EQ.1 ) THEN 17842 CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) 17843 IF( K.LT.N ) THEN 17844 R1 = ONE / A( K, K ) 17845 CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) 17846 END IF 17847 ELSE 17848 IF( K.LT.N-1 ) THEN 17849 D21 = W( K+1, K ) 17850 D11 = W( K+1, K+1 ) / D21 17851 D22 = W( K, K ) / D21 17852 T = ONE / ( D11*D22-ONE ) 17853 D21 = T / D21 17854 DO 80 J = K + 2, N 17855 A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) 17856 A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) 17857 80 CONTINUE 17858 END IF 17859 A( K, K ) = W( K, K ) 17860 A( K+1, K ) = W( K+1, K ) 17861 A( K+1, K+1 ) = W( K+1, K+1 ) 17862 END IF 17863 END IF 17864 IF( KSTEP.EQ.1 ) THEN 17865 IPIV( K ) = KP 17866 ELSE 17867 IPIV( K ) = -KP 17868 IPIV( K+1 ) = -KP 17869 END IF 17870 K = K + KSTEP 17871 GO TO 70 17872 90 CONTINUE 17873 DO 110 J = K, N, NB 17874 JB = MIN( NB, N-J+1 ) 17875 DO 100 JJ = J, J + JB - 1 17876 CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, 17877 $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, 17878 $ A( JJ, JJ ), 1 ) 17879 100 CONTINUE 17880 IF( J+JB.LE.N ) 17881 $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, 17882 $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, 17883 $ ONE, A( J+JB, J ), LDA ) 17884 110 CONTINUE 17885 J = K - 1 17886 120 CONTINUE 17887 JJ = J 17888 JP = IPIV( J ) 17889 IF( JP.LT.0 ) THEN 17890 JP = -JP 17891 J = J - 1 17892 END IF 17893 J = J - 1 17894 IF( JP.NE.JJ .AND. J.GE.1 ) 17895 $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) 17896 IF( J.GT.1 ) 17897 $ GO TO 120 17898 KB = K - 1 17899 END IF 17900 RETURN 17901 END 17902! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dlatrd.f 17903 SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) 17904 CHARACTER UPLO 17905 INTEGER LDA, LDW, N, NB 17906 DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) 17907 DOUBLE PRECISION ZERO, ONE, HALF 17908 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) 17909 INTEGER I, IW 17910 DOUBLE PRECISION ALPHA 17911 EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV 17912 LOGICAL LSAME 17913 DOUBLE PRECISION DDOT 17914 EXTERNAL LSAME, DDOT 17915 INTRINSIC MIN 17916 IF( N.LE.0 ) 17917 $ RETURN 17918 IF( LSAME( UPLO, 'U' ) ) THEN 17919 DO 10 I = N, N - NB + 1, -1 17920 IW = I - N + NB 17921 IF( I.LT.N ) THEN 17922 CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), 17923 $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) 17924 CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), 17925 $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) 17926 END IF 17927 IF( I.GT.1 ) THEN 17928 CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) 17929 E( I-1 ) = A( I-1, I ) 17930 A( I-1, I ) = ONE 17931 CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, 17932 $ ZERO, W( 1, IW ), 1 ) 17933 IF( I.LT.N ) THEN 17934 CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), 17935 $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) 17936 CALL DGEMV( 'No transpose', I-1, N-I, -ONE, 17937 $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, 17938 $ W( 1, IW ), 1 ) 17939 CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), 17940 $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) 17941 CALL DGEMV( 'No transpose', I-1, N-I, -ONE, 17942 $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, 17943 $ W( 1, IW ), 1 ) 17944 END IF 17945 CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) 17946 ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, 17947 $ A( 1, I ), 1 ) 17948 CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) 17949 END IF 17950 10 CONTINUE 17951 ELSE 17952 DO 20 I = 1, NB 17953 CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), 17954 $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) 17955 CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), 17956 $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) 17957 IF( I.LT.N ) THEN 17958 CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, 17959 $ TAU( I ) ) 17960 E( I ) = A( I+1, I ) 17961 A( I+1, I ) = ONE 17962 CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, 17963 $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) 17964 CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, 17965 $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) 17966 CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), 17967 $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) 17968 CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, 17969 $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) 17970 CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), 17971 $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) 17972 CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) 17973 ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, 17974 $ A( I+1, I ), 1 ) 17975 CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) 17976 END IF 17977 20 CONTINUE 17978 END IF 17979 RETURN 17980 END 17981! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dopgtr.f 17982 SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) 17983 CHARACTER UPLO 17984 INTEGER INFO, LDQ, N 17985 DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) 17986 DOUBLE PRECISION ZERO, ONE 17987 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 17988 LOGICAL UPPER 17989 INTEGER I, IINFO, IJ, J 17990 LOGICAL LSAME 17991 EXTERNAL LSAME 17992 EXTERNAL DORG2L, DORG2R, XERBLA 17993 INTRINSIC MAX 17994 INFO = 0 17995 UPPER = LSAME( UPLO, 'U' ) 17996 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 17997 INFO = -1 17998 ELSE IF( N.LT.0 ) THEN 17999 INFO = -2 18000 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN 18001 INFO = -6 18002 END IF 18003 IF( INFO.NE.0 ) THEN 18004 CALL XERBLA( 'DOPGTR', -INFO ) 18005 RETURN 18006 END IF 18007 IF( N.EQ.0 ) 18008 $ RETURN 18009 IF( UPPER ) THEN 18010 IJ = 2 18011 DO 20 J = 1, N - 1 18012 DO 10 I = 1, J - 1 18013 Q( I, J ) = AP( IJ ) 18014 IJ = IJ + 1 18015 10 CONTINUE 18016 IJ = IJ + 2 18017 Q( N, J ) = ZERO 18018 20 CONTINUE 18019 DO 30 I = 1, N - 1 18020 Q( I, N ) = ZERO 18021 30 CONTINUE 18022 Q( N, N ) = ONE 18023 CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO ) 18024 ELSE 18025 Q( 1, 1 ) = ONE 18026 DO 40 I = 2, N 18027 Q( I, 1 ) = ZERO 18028 40 CONTINUE 18029 IJ = 3 18030 DO 60 J = 2, N 18031 Q( 1, J ) = ZERO 18032 DO 50 I = J + 1, N 18033 Q( I, J ) = AP( IJ ) 18034 IJ = IJ + 1 18035 50 CONTINUE 18036 IJ = IJ + 2 18037 60 CONTINUE 18038 IF( N.GT.1 ) THEN 18039 CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, 18040 $ IINFO ) 18041 END IF 18042 END IF 18043 RETURN 18044 END 18045! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dopmtr.f 18046 SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, 18047 $ INFO ) 18048 CHARACTER SIDE, TRANS, UPLO 18049 INTEGER INFO, LDC, M, N 18050 DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) 18051 DOUBLE PRECISION ONE 18052 PARAMETER ( ONE = 1.0D+0 ) 18053 LOGICAL FORWRD, LEFT, NOTRAN, UPPER 18054 INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ 18055 DOUBLE PRECISION AII 18056 LOGICAL LSAME 18057 EXTERNAL LSAME 18058 EXTERNAL DLARF, XERBLA 18059 INTRINSIC MAX 18060 INFO = 0 18061 LEFT = LSAME( SIDE, 'L' ) 18062 NOTRAN = LSAME( TRANS, 'N' ) 18063 UPPER = LSAME( UPLO, 'U' ) 18064 IF( LEFT ) THEN 18065 NQ = M 18066 ELSE 18067 NQ = N 18068 END IF 18069 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 18070 INFO = -1 18071 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 18072 INFO = -2 18073 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN 18074 INFO = -3 18075 ELSE IF( M.LT.0 ) THEN 18076 INFO = -4 18077 ELSE IF( N.LT.0 ) THEN 18078 INFO = -5 18079 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 18080 INFO = -9 18081 END IF 18082 IF( INFO.NE.0 ) THEN 18083 CALL XERBLA( 'DOPMTR', -INFO ) 18084 RETURN 18085 END IF 18086 IF( M.EQ.0 .OR. N.EQ.0 ) 18087 $ RETURN 18088 IF( UPPER ) THEN 18089 FORWRD = ( LEFT .AND. NOTRAN ) .OR. 18090 $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) 18091 IF( FORWRD ) THEN 18092 I1 = 1 18093 I2 = NQ - 1 18094 I3 = 1 18095 II = 2 18096 ELSE 18097 I1 = NQ - 1 18098 I2 = 1 18099 I3 = -1 18100 II = NQ*( NQ+1 ) / 2 - 1 18101 END IF 18102 IF( LEFT ) THEN 18103 NI = N 18104 ELSE 18105 MI = M 18106 END IF 18107 DO 10 I = I1, I2, I3 18108 IF( LEFT ) THEN 18109 MI = I 18110 ELSE 18111 NI = I 18112 END IF 18113 AII = AP( II ) 18114 AP( II ) = ONE 18115 CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC, 18116 $ WORK ) 18117 AP( II ) = AII 18118 IF( FORWRD ) THEN 18119 II = II + I + 2 18120 ELSE 18121 II = II - I - 1 18122 END IF 18123 10 CONTINUE 18124 ELSE 18125 FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR. 18126 $ ( .NOT.LEFT .AND. NOTRAN ) 18127 IF( FORWRD ) THEN 18128 I1 = 1 18129 I2 = NQ - 1 18130 I3 = 1 18131 II = 2 18132 ELSE 18133 I1 = NQ - 1 18134 I2 = 1 18135 I3 = -1 18136 II = NQ*( NQ+1 ) / 2 - 1 18137 END IF 18138 IF( LEFT ) THEN 18139 NI = N 18140 JC = 1 18141 ELSE 18142 MI = M 18143 IC = 1 18144 END IF 18145 DO 20 I = I1, I2, I3 18146 AII = AP( II ) 18147 AP( II ) = ONE 18148 IF( LEFT ) THEN 18149 MI = M - I 18150 IC = I + 1 18151 ELSE 18152 NI = N - I 18153 JC = I + 1 18154 END IF 18155 CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ), 18156 $ C( IC, JC ), LDC, WORK ) 18157 AP( II ) = AII 18158 IF( FORWRD ) THEN 18159 II = II + NQ - I + 1 18160 ELSE 18161 II = II - NQ + I - 2 18162 END IF 18163 20 CONTINUE 18164 END IF 18165 RETURN 18166 END 18167! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dorg2l.f 18168 SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) 18169 INTEGER INFO, K, LDA, M, N 18170 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 18171 DOUBLE PRECISION ONE, ZERO 18172 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 18173 INTEGER I, II, J, L 18174 EXTERNAL DLARF, DSCAL, XERBLA 18175 INTRINSIC MAX 18176 INFO = 0 18177 IF( M.LT.0 ) THEN 18178 INFO = -1 18179 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN 18180 INFO = -2 18181 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN 18182 INFO = -3 18183 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 18184 INFO = -5 18185 END IF 18186 IF( INFO.NE.0 ) THEN 18187 CALL XERBLA( 'DORG2L', -INFO ) 18188 RETURN 18189 END IF 18190 IF( N.LE.0 ) 18191 $ RETURN 18192 DO 20 J = 1, N - K 18193 DO 10 L = 1, M 18194 A( L, J ) = ZERO 18195 10 CONTINUE 18196 A( M-N+J, J ) = ONE 18197 20 CONTINUE 18198 DO 40 I = 1, K 18199 II = N - K + I 18200 A( M-N+II, II ) = ONE 18201 CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, 18202 $ LDA, WORK ) 18203 CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) 18204 A( M-N+II, II ) = ONE - TAU( I ) 18205 DO 30 L = M - N + II + 1, M 18206 A( L, II ) = ZERO 18207 30 CONTINUE 18208 40 CONTINUE 18209 RETURN 18210 END 18211! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dorg2r.f 18212 SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) 18213 INTEGER INFO, K, LDA, M, N 18214 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 18215 DOUBLE PRECISION ONE, ZERO 18216 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 18217 INTEGER I, J, L 18218 EXTERNAL DLARF, DSCAL, XERBLA 18219 INTRINSIC MAX 18220 INFO = 0 18221 IF( M.LT.0 ) THEN 18222 INFO = -1 18223 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN 18224 INFO = -2 18225 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN 18226 INFO = -3 18227 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 18228 INFO = -5 18229 END IF 18230 IF( INFO.NE.0 ) THEN 18231 CALL XERBLA( 'DORG2R', -INFO ) 18232 RETURN 18233 END IF 18234 IF( N.LE.0 ) 18235 $ RETURN 18236 DO 20 J = K + 1, N 18237 DO 10 L = 1, M 18238 A( L, J ) = ZERO 18239 10 CONTINUE 18240 A( J, J ) = ONE 18241 20 CONTINUE 18242 DO 40 I = K, 1, -1 18243 IF( I.LT.N ) THEN 18244 A( I, I ) = ONE 18245 CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), 18246 $ A( I, I+1 ), LDA, WORK ) 18247 END IF 18248 IF( I.LT.M ) 18249 $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) 18250 A( I, I ) = ONE - TAU( I ) 18251 DO 30 L = 1, I - 1 18252 A( L, I ) = ZERO 18253 30 CONTINUE 18254 40 CONTINUE 18255 RETURN 18256 END 18257! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dorgbr.f 18258 SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) 18259 CHARACTER VECT 18260 INTEGER INFO, K, LDA, LWORK, M, N 18261 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 18262 DOUBLE PRECISION ZERO, ONE 18263 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 18264 LOGICAL LQUERY, WANTQ 18265 INTEGER I, IINFO, J, LWKOPT, MN 18266 LOGICAL LSAME 18267 EXTERNAL LSAME 18268 EXTERNAL DORGLQ, DORGQR, XERBLA 18269 INTRINSIC MAX, MIN 18270 INFO = 0 18271 WANTQ = LSAME( VECT, 'Q' ) 18272 MN = MIN( M, N ) 18273 LQUERY = ( LWORK.EQ.-1 ) 18274 IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN 18275 INFO = -1 18276 ELSE IF( M.LT.0 ) THEN 18277 INFO = -2 18278 ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, 18279 $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. 18280 $ MIN( N, K ) ) ) ) THEN 18281 INFO = -3 18282 ELSE IF( K.LT.0 ) THEN 18283 INFO = -4 18284 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 18285 INFO = -6 18286 ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN 18287 INFO = -9 18288 END IF 18289 IF( INFO.EQ.0 ) THEN 18290 WORK( 1 ) = 1 18291 IF( WANTQ ) THEN 18292 IF( M.GE.K ) THEN 18293 CALL DORGQR( M, N, K, A, LDA, TAU, WORK, -1, IINFO ) 18294 ELSE 18295 IF( M.GT.1 ) THEN 18296 CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, 18297 $ -1, IINFO ) 18298 END IF 18299 END IF 18300 ELSE 18301 IF( K.LT.N ) THEN 18302 CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, -1, IINFO ) 18303 ELSE 18304 IF( N.GT.1 ) THEN 18305 CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, 18306 $ -1, IINFO ) 18307 END IF 18308 END IF 18309 END IF 18310 LWKOPT = WORK( 1 ) 18311 LWKOPT = MAX (LWKOPT, MN) 18312 END IF 18313 IF( INFO.NE.0 ) THEN 18314 CALL XERBLA( 'DORGBR', -INFO ) 18315 RETURN 18316 ELSE IF( LQUERY ) THEN 18317 WORK( 1 ) = LWKOPT 18318 RETURN 18319 END IF 18320 IF( M.EQ.0 .OR. N.EQ.0 ) THEN 18321 WORK( 1 ) = 1 18322 RETURN 18323 END IF 18324 IF( WANTQ ) THEN 18325 IF( M.GE.K ) THEN 18326 CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) 18327 ELSE 18328 DO 20 J = M, 2, -1 18329 A( 1, J ) = ZERO 18330 DO 10 I = J + 1, M 18331 A( I, J ) = A( I, J-1 ) 18332 10 CONTINUE 18333 20 CONTINUE 18334 A( 1, 1 ) = ONE 18335 DO 30 I = 2, M 18336 A( I, 1 ) = ZERO 18337 30 CONTINUE 18338 IF( M.GT.1 ) THEN 18339 CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, 18340 $ LWORK, IINFO ) 18341 END IF 18342 END IF 18343 ELSE 18344 IF( K.LT.N ) THEN 18345 CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) 18346 ELSE 18347 A( 1, 1 ) = ONE 18348 DO 40 I = 2, N 18349 A( I, 1 ) = ZERO 18350 40 CONTINUE 18351 DO 60 J = 2, N 18352 DO 50 I = J - 1, 2, -1 18353 A( I, J ) = A( I-1, J ) 18354 50 CONTINUE 18355 A( 1, J ) = ZERO 18356 60 CONTINUE 18357 IF( N.GT.1 ) THEN 18358 CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, 18359 $ LWORK, IINFO ) 18360 END IF 18361 END IF 18362 END IF 18363 WORK( 1 ) = LWKOPT 18364 RETURN 18365 END 18366! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dorgl2.f 18367 SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) 18368 INTEGER INFO, K, LDA, M, N 18369 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 18370 DOUBLE PRECISION ONE, ZERO 18371 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 18372 INTEGER I, J, L 18373 EXTERNAL DLARF, DSCAL, XERBLA 18374 INTRINSIC MAX 18375 INFO = 0 18376 IF( M.LT.0 ) THEN 18377 INFO = -1 18378 ELSE IF( N.LT.M ) THEN 18379 INFO = -2 18380 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN 18381 INFO = -3 18382 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 18383 INFO = -5 18384 END IF 18385 IF( INFO.NE.0 ) THEN 18386 CALL XERBLA( 'DORGL2', -INFO ) 18387 RETURN 18388 END IF 18389 IF( M.LE.0 ) 18390 $ RETURN 18391 IF( K.LT.M ) THEN 18392 DO 20 J = 1, N 18393 DO 10 L = K + 1, M 18394 A( L, J ) = ZERO 18395 10 CONTINUE 18396 IF( J.GT.K .AND. J.LE.M ) 18397 $ A( J, J ) = ONE 18398 20 CONTINUE 18399 END IF 18400 DO 40 I = K, 1, -1 18401 IF( I.LT.N ) THEN 18402 IF( I.LT.M ) THEN 18403 A( I, I ) = ONE 18404 CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, 18405 $ TAU( I ), A( I+1, I ), LDA, WORK ) 18406 END IF 18407 CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) 18408 END IF 18409 A( I, I ) = ONE - TAU( I ) 18410 DO 30 L = 1, I - 1 18411 A( I, L ) = ZERO 18412 30 CONTINUE 18413 40 CONTINUE 18414 RETURN 18415 END 18416! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dorglq.f 18417 SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) 18418 INTEGER INFO, K, LDA, LWORK, M, N 18419 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 18420 DOUBLE PRECISION ZERO 18421 PARAMETER ( ZERO = 0.0D+0 ) 18422 LOGICAL LQUERY 18423 INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, 18424 $ LWKOPT, NB, NBMIN, NX 18425 EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA 18426 INTRINSIC MAX, MIN 18427 INTEGER ILAENV 18428 EXTERNAL ILAENV 18429 INFO = 0 18430 NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) 18431 LWKOPT = MAX( 1, M )*NB 18432 WORK( 1 ) = LWKOPT 18433 LQUERY = ( LWORK.EQ.-1 ) 18434 IF( M.LT.0 ) THEN 18435 INFO = -1 18436 ELSE IF( N.LT.M ) THEN 18437 INFO = -2 18438 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN 18439 INFO = -3 18440 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 18441 INFO = -5 18442 ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN 18443 INFO = -8 18444 END IF 18445 IF( INFO.NE.0 ) THEN 18446 CALL XERBLA( 'DORGLQ', -INFO ) 18447 RETURN 18448 ELSE IF( LQUERY ) THEN 18449 RETURN 18450 END IF 18451 IF( M.LE.0 ) THEN 18452 WORK( 1 ) = 1 18453 RETURN 18454 END IF 18455 NBMIN = 2 18456 NX = 0 18457 IWS = M 18458 IF( NB.GT.1 .AND. NB.LT.K ) THEN 18459 NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) ) 18460 IF( NX.LT.K ) THEN 18461 LDWORK = M 18462 IWS = LDWORK*NB 18463 IF( LWORK.LT.IWS ) THEN 18464 NB = LWORK / LDWORK 18465 NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) ) 18466 END IF 18467 END IF 18468 END IF 18469 IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN 18470 KI = ( ( K-NX-1 ) / NB )*NB 18471 KK = MIN( K, KI+NB ) 18472 DO 20 J = 1, KK 18473 DO 10 I = KK + 1, M 18474 A( I, J ) = ZERO 18475 10 CONTINUE 18476 20 CONTINUE 18477 ELSE 18478 KK = 0 18479 END IF 18480 IF( KK.LT.M ) 18481 $ CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, 18482 $ TAU( KK+1 ), WORK, IINFO ) 18483 IF( KK.GT.0 ) THEN 18484 DO 50 I = KI + 1, 1, -NB 18485 IB = MIN( NB, K-I+1 ) 18486 IF( I+IB.LE.M ) THEN 18487 CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), 18488 $ LDA, TAU( I ), WORK, LDWORK ) 18489 CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise', 18490 $ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK, 18491 $ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ), 18492 $ LDWORK ) 18493 END IF 18494 CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, 18495 $ IINFO ) 18496 DO 40 J = 1, I - 1 18497 DO 30 L = I, I + IB - 1 18498 A( L, J ) = ZERO 18499 30 CONTINUE 18500 40 CONTINUE 18501 50 CONTINUE 18502 END IF 18503 WORK( 1 ) = IWS 18504 RETURN 18505 END 18506! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dorgql.f 18507 SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) 18508 INTEGER INFO, K, LDA, LWORK, M, N 18509 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 18510 DOUBLE PRECISION ZERO 18511 PARAMETER ( ZERO = 0.0D+0 ) 18512 LOGICAL LQUERY 18513 INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, 18514 $ NB, NBMIN, NX 18515 EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA 18516 INTRINSIC MAX, MIN 18517 INTEGER ILAENV 18518 EXTERNAL ILAENV 18519 INFO = 0 18520 LQUERY = ( LWORK.EQ.-1 ) 18521 IF( M.LT.0 ) THEN 18522 INFO = -1 18523 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN 18524 INFO = -2 18525 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN 18526 INFO = -3 18527 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 18528 INFO = -5 18529 END IF 18530 IF( INFO.EQ.0 ) THEN 18531 IF( N.EQ.0 ) THEN 18532 LWKOPT = 1 18533 ELSE 18534 NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) 18535 LWKOPT = N*NB 18536 END IF 18537 WORK( 1 ) = LWKOPT 18538 IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 18539 INFO = -8 18540 END IF 18541 END IF 18542 IF( INFO.NE.0 ) THEN 18543 CALL XERBLA( 'DORGQL', -INFO ) 18544 RETURN 18545 ELSE IF( LQUERY ) THEN 18546 RETURN 18547 END IF 18548 IF( N.LE.0 ) THEN 18549 RETURN 18550 END IF 18551 NBMIN = 2 18552 NX = 0 18553 IWS = N 18554 IF( NB.GT.1 .AND. NB.LT.K ) THEN 18555 NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) ) 18556 IF( NX.LT.K ) THEN 18557 LDWORK = N 18558 IWS = LDWORK*NB 18559 IF( LWORK.LT.IWS ) THEN 18560 NB = LWORK / LDWORK 18561 NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) 18562 END IF 18563 END IF 18564 END IF 18565 IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN 18566 KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) 18567 DO 20 J = 1, N - KK 18568 DO 10 I = M - KK + 1, M 18569 A( I, J ) = ZERO 18570 10 CONTINUE 18571 20 CONTINUE 18572 ELSE 18573 KK = 0 18574 END IF 18575 CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) 18576 IF( KK.GT.0 ) THEN 18577 DO 50 I = K - KK + 1, K, NB 18578 IB = MIN( NB, K-I+1 ) 18579 IF( N-K+I.GT.1 ) THEN 18580 CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, 18581 $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) 18582 CALL DLARFB( 'Left', 'No transpose', 'Backward', 18583 $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, 18584 $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, 18585 $ WORK( IB+1 ), LDWORK ) 18586 END IF 18587 CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, 18588 $ TAU( I ), WORK, IINFO ) 18589 DO 40 J = N - K + I, N - K + I + IB - 1 18590 DO 30 L = M - K + I + IB, M 18591 A( L, J ) = ZERO 18592 30 CONTINUE 18593 40 CONTINUE 18594 50 CONTINUE 18595 END IF 18596 WORK( 1 ) = IWS 18597 RETURN 18598 END 18599! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dorgqr.f 18600 SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) 18601 INTEGER INFO, K, LDA, LWORK, M, N 18602 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 18603 DOUBLE PRECISION ZERO 18604 PARAMETER ( ZERO = 0.0D+0 ) 18605 LOGICAL LQUERY 18606 INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, 18607 $ LWKOPT, NB, NBMIN, NX 18608 EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA 18609 INTRINSIC MAX, MIN 18610 INTEGER ILAENV 18611 EXTERNAL ILAENV 18612 INFO = 0 18613 NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) 18614 LWKOPT = MAX( 1, N )*NB 18615 WORK( 1 ) = LWKOPT 18616 LQUERY = ( LWORK.EQ.-1 ) 18617 IF( M.LT.0 ) THEN 18618 INFO = -1 18619 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN 18620 INFO = -2 18621 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN 18622 INFO = -3 18623 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 18624 INFO = -5 18625 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 18626 INFO = -8 18627 END IF 18628 IF( INFO.NE.0 ) THEN 18629 CALL XERBLA( 'DORGQR', -INFO ) 18630 RETURN 18631 ELSE IF( LQUERY ) THEN 18632 RETURN 18633 END IF 18634 IF( N.LE.0 ) THEN 18635 WORK( 1 ) = 1 18636 RETURN 18637 END IF 18638 NBMIN = 2 18639 NX = 0 18640 IWS = N 18641 IF( NB.GT.1 .AND. NB.LT.K ) THEN 18642 NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) 18643 IF( NX.LT.K ) THEN 18644 LDWORK = N 18645 IWS = LDWORK*NB 18646 IF( LWORK.LT.IWS ) THEN 18647 NB = LWORK / LDWORK 18648 NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) 18649 END IF 18650 END IF 18651 END IF 18652 IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN 18653 KI = ( ( K-NX-1 ) / NB )*NB 18654 KK = MIN( K, KI+NB ) 18655 DO 20 J = KK + 1, N 18656 DO 10 I = 1, KK 18657 A( I, J ) = ZERO 18658 10 CONTINUE 18659 20 CONTINUE 18660 ELSE 18661 KK = 0 18662 END IF 18663 IF( KK.LT.N ) 18664 $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, 18665 $ TAU( KK+1 ), WORK, IINFO ) 18666 IF( KK.GT.0 ) THEN 18667 DO 50 I = KI + 1, 1, -NB 18668 IB = MIN( NB, K-I+1 ) 18669 IF( I+IB.LE.N ) THEN 18670 CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, 18671 $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) 18672 CALL DLARFB( 'Left', 'No transpose', 'Forward', 18673 $ 'Columnwise', M-I+1, N-I-IB+1, IB, 18674 $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), 18675 $ LDA, WORK( IB+1 ), LDWORK ) 18676 END IF 18677 CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, 18678 $ IINFO ) 18679 DO 40 J = I, I + IB - 1 18680 DO 30 L = 1, I - 1 18681 A( L, J ) = ZERO 18682 30 CONTINUE 18683 40 CONTINUE 18684 50 CONTINUE 18685 END IF 18686 WORK( 1 ) = IWS 18687 RETURN 18688 END 18689! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dorgtr.f 18690 SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) 18691 CHARACTER UPLO 18692 INTEGER INFO, LDA, LWORK, N 18693 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 18694 DOUBLE PRECISION ZERO, ONE 18695 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 18696 LOGICAL LQUERY, UPPER 18697 INTEGER I, IINFO, J, LWKOPT, NB 18698 LOGICAL LSAME 18699 INTEGER ILAENV 18700 EXTERNAL LSAME, ILAENV 18701 EXTERNAL DORGQL, DORGQR, XERBLA 18702 INTRINSIC MAX 18703 INFO = 0 18704 LQUERY = ( LWORK.EQ.-1 ) 18705 UPPER = LSAME( UPLO, 'U' ) 18706 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 18707 INFO = -1 18708 ELSE IF( N.LT.0 ) THEN 18709 INFO = -2 18710 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 18711 INFO = -4 18712 ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN 18713 INFO = -7 18714 END IF 18715 IF( INFO.EQ.0 ) THEN 18716 IF( UPPER ) THEN 18717 NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 ) 18718 ELSE 18719 NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 ) 18720 END IF 18721 LWKOPT = MAX( 1, N-1 )*NB 18722 WORK( 1 ) = LWKOPT 18723 END IF 18724 IF( INFO.NE.0 ) THEN 18725 CALL XERBLA( 'DORGTR', -INFO ) 18726 RETURN 18727 ELSE IF( LQUERY ) THEN 18728 RETURN 18729 END IF 18730 IF( N.EQ.0 ) THEN 18731 WORK( 1 ) = 1 18732 RETURN 18733 END IF 18734 IF( UPPER ) THEN 18735 DO 20 J = 1, N - 1 18736 DO 10 I = 1, J - 1 18737 A( I, J ) = A( I, J+1 ) 18738 10 CONTINUE 18739 A( N, J ) = ZERO 18740 20 CONTINUE 18741 DO 30 I = 1, N - 1 18742 A( I, N ) = ZERO 18743 30 CONTINUE 18744 A( N, N ) = ONE 18745 CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) 18746 ELSE 18747 DO 50 J = N, 2, -1 18748 A( 1, J ) = ZERO 18749 DO 40 I = J + 1, N 18750 A( I, J ) = A( I, J-1 ) 18751 40 CONTINUE 18752 50 CONTINUE 18753 A( 1, 1 ) = ONE 18754 DO 60 I = 2, N 18755 A( I, 1 ) = ZERO 18756 60 CONTINUE 18757 IF( N.GT.1 ) THEN 18758 CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, 18759 $ LWORK, IINFO ) 18760 END IF 18761 END IF 18762 WORK( 1 ) = LWKOPT 18763 RETURN 18764 END 18765! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dorm2l.f 18766 SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, 18767 $ WORK, INFO ) 18768 CHARACTER SIDE, TRANS 18769 INTEGER INFO, K, LDA, LDC, M, N 18770 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 18771 DOUBLE PRECISION ONE 18772 PARAMETER ( ONE = 1.0D+0 ) 18773 LOGICAL LEFT, NOTRAN 18774 INTEGER I, I1, I2, I3, MI, NI, NQ 18775 DOUBLE PRECISION AII 18776 LOGICAL LSAME 18777 EXTERNAL LSAME 18778 EXTERNAL DLARF, XERBLA 18779 INTRINSIC MAX 18780 INFO = 0 18781 LEFT = LSAME( SIDE, 'L' ) 18782 NOTRAN = LSAME( TRANS, 'N' ) 18783 IF( LEFT ) THEN 18784 NQ = M 18785 ELSE 18786 NQ = N 18787 END IF 18788 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 18789 INFO = -1 18790 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN 18791 INFO = -2 18792 ELSE IF( M.LT.0 ) THEN 18793 INFO = -3 18794 ELSE IF( N.LT.0 ) THEN 18795 INFO = -4 18796 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN 18797 INFO = -5 18798 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 18799 INFO = -7 18800 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 18801 INFO = -10 18802 END IF 18803 IF( INFO.NE.0 ) THEN 18804 CALL XERBLA( 'DORM2L', -INFO ) 18805 RETURN 18806 END IF 18807 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) 18808 $ RETURN 18809 IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) 18810 $ THEN 18811 I1 = 1 18812 I2 = K 18813 I3 = 1 18814 ELSE 18815 I1 = K 18816 I2 = 1 18817 I3 = -1 18818 END IF 18819 IF( LEFT ) THEN 18820 NI = N 18821 ELSE 18822 MI = M 18823 END IF 18824 DO 10 I = I1, I2, I3 18825 IF( LEFT ) THEN 18826 MI = M - K + I 18827 ELSE 18828 NI = N - K + I 18829 END IF 18830 AII = A( NQ-K+I, I ) 18831 A( NQ-K+I, I ) = ONE 18832 CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, 18833 $ WORK ) 18834 A( NQ-K+I, I ) = AII 18835 10 CONTINUE 18836 RETURN 18837 END 18838! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dorm2r.f 18839 SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, 18840 $ WORK, INFO ) 18841 CHARACTER SIDE, TRANS 18842 INTEGER INFO, K, LDA, LDC, M, N 18843 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 18844 DOUBLE PRECISION ONE 18845 PARAMETER ( ONE = 1.0D+0 ) 18846 LOGICAL LEFT, NOTRAN 18847 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ 18848 DOUBLE PRECISION AII 18849 LOGICAL LSAME 18850 EXTERNAL LSAME 18851 EXTERNAL DLARF, XERBLA 18852 INTRINSIC MAX 18853 INFO = 0 18854 LEFT = LSAME( SIDE, 'L' ) 18855 NOTRAN = LSAME( TRANS, 'N' ) 18856 IF( LEFT ) THEN 18857 NQ = M 18858 ELSE 18859 NQ = N 18860 END IF 18861 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 18862 INFO = -1 18863 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN 18864 INFO = -2 18865 ELSE IF( M.LT.0 ) THEN 18866 INFO = -3 18867 ELSE IF( N.LT.0 ) THEN 18868 INFO = -4 18869 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN 18870 INFO = -5 18871 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 18872 INFO = -7 18873 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 18874 INFO = -10 18875 END IF 18876 IF( INFO.NE.0 ) THEN 18877 CALL XERBLA( 'DORM2R', -INFO ) 18878 RETURN 18879 END IF 18880 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) 18881 $ RETURN 18882 IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) 18883 $ THEN 18884 I1 = 1 18885 I2 = K 18886 I3 = 1 18887 ELSE 18888 I1 = K 18889 I2 = 1 18890 I3 = -1 18891 END IF 18892 IF( LEFT ) THEN 18893 NI = N 18894 JC = 1 18895 ELSE 18896 MI = M 18897 IC = 1 18898 END IF 18899 DO 10 I = I1, I2, I3 18900 IF( LEFT ) THEN 18901 MI = M - I + 1 18902 IC = I 18903 ELSE 18904 NI = N - I + 1 18905 JC = I 18906 END IF 18907 AII = A( I, I ) 18908 A( I, I ) = ONE 18909 CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), 18910 $ LDC, WORK ) 18911 A( I, I ) = AII 18912 10 CONTINUE 18913 RETURN 18914 END 18915! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dormbr.f 18916 SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, 18917 $ LDC, WORK, LWORK, INFO ) 18918 CHARACTER SIDE, TRANS, VECT 18919 INTEGER INFO, K, LDA, LDC, LWORK, M, N 18920 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 18921 LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN 18922 CHARACTER TRANST 18923 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW 18924 LOGICAL LSAME 18925 INTEGER ILAENV 18926 EXTERNAL LSAME, ILAENV 18927 EXTERNAL DORMLQ, DORMQR, XERBLA 18928 INTRINSIC MAX, MIN 18929 INFO = 0 18930 APPLYQ = LSAME( VECT, 'Q' ) 18931 LEFT = LSAME( SIDE, 'L' ) 18932 NOTRAN = LSAME( TRANS, 'N' ) 18933 LQUERY = ( LWORK.EQ.-1 ) 18934 IF( LEFT ) THEN 18935 NQ = M 18936 NW = N 18937 ELSE 18938 NQ = N 18939 NW = M 18940 END IF 18941 IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN 18942 INFO = -1 18943 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 18944 INFO = -2 18945 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN 18946 INFO = -3 18947 ELSE IF( M.LT.0 ) THEN 18948 INFO = -4 18949 ELSE IF( N.LT.0 ) THEN 18950 INFO = -5 18951 ELSE IF( K.LT.0 ) THEN 18952 INFO = -6 18953 ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. 18954 $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) 18955 $ THEN 18956 INFO = -8 18957 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 18958 INFO = -11 18959 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN 18960 INFO = -13 18961 END IF 18962 IF( INFO.EQ.0 ) THEN 18963 IF( APPLYQ ) THEN 18964 IF( LEFT ) THEN 18965 NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, 18966 $ -1 ) 18967 ELSE 18968 NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, 18969 $ -1 ) 18970 END IF 18971 ELSE 18972 IF( LEFT ) THEN 18973 NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1, 18974 $ -1 ) 18975 ELSE 18976 NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1, 18977 $ -1 ) 18978 END IF 18979 END IF 18980 LWKOPT = MAX( 1, NW )*NB 18981 WORK( 1 ) = LWKOPT 18982 END IF 18983 IF( INFO.NE.0 ) THEN 18984 CALL XERBLA( 'DORMBR', -INFO ) 18985 RETURN 18986 ELSE IF( LQUERY ) THEN 18987 RETURN 18988 END IF 18989 WORK( 1 ) = 1 18990 IF( M.EQ.0 .OR. N.EQ.0 ) 18991 $ RETURN 18992 IF( APPLYQ ) THEN 18993 IF( NQ.GE.K ) THEN 18994 CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, 18995 $ WORK, LWORK, IINFO ) 18996 ELSE IF( NQ.GT.1 ) THEN 18997 IF( LEFT ) THEN 18998 MI = M - 1 18999 NI = N 19000 I1 = 2 19001 I2 = 1 19002 ELSE 19003 MI = M 19004 NI = N - 1 19005 I1 = 1 19006 I2 = 2 19007 END IF 19008 CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, 19009 $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) 19010 END IF 19011 ELSE 19012 IF( NOTRAN ) THEN 19013 TRANST = 'T' 19014 ELSE 19015 TRANST = 'N' 19016 END IF 19017 IF( NQ.GT.K ) THEN 19018 CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, 19019 $ WORK, LWORK, IINFO ) 19020 ELSE IF( NQ.GT.1 ) THEN 19021 IF( LEFT ) THEN 19022 MI = M - 1 19023 NI = N 19024 I1 = 2 19025 I2 = 1 19026 ELSE 19027 MI = M 19028 NI = N - 1 19029 I1 = 1 19030 I2 = 2 19031 END IF 19032 CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, 19033 $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) 19034 END IF 19035 END IF 19036 WORK( 1 ) = LWKOPT 19037 RETURN 19038 END 19039! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dorml2.f 19040 SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, 19041 $ WORK, INFO ) 19042 CHARACTER SIDE, TRANS 19043 INTEGER INFO, K, LDA, LDC, M, N 19044 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 19045 DOUBLE PRECISION ONE 19046 PARAMETER ( ONE = 1.0D+0 ) 19047 LOGICAL LEFT, NOTRAN 19048 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ 19049 DOUBLE PRECISION AII 19050 LOGICAL LSAME 19051 EXTERNAL LSAME 19052 EXTERNAL DLARF, XERBLA 19053 INTRINSIC MAX 19054 INFO = 0 19055 LEFT = LSAME( SIDE, 'L' ) 19056 NOTRAN = LSAME( TRANS, 'N' ) 19057 IF( LEFT ) THEN 19058 NQ = M 19059 ELSE 19060 NQ = N 19061 END IF 19062 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 19063 INFO = -1 19064 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN 19065 INFO = -2 19066 ELSE IF( M.LT.0 ) THEN 19067 INFO = -3 19068 ELSE IF( N.LT.0 ) THEN 19069 INFO = -4 19070 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN 19071 INFO = -5 19072 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN 19073 INFO = -7 19074 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 19075 INFO = -10 19076 END IF 19077 IF( INFO.NE.0 ) THEN 19078 CALL XERBLA( 'DORML2', -INFO ) 19079 RETURN 19080 END IF 19081 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) 19082 $ RETURN 19083 IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) 19084 $ THEN 19085 I1 = 1 19086 I2 = K 19087 I3 = 1 19088 ELSE 19089 I1 = K 19090 I2 = 1 19091 I3 = -1 19092 END IF 19093 IF( LEFT ) THEN 19094 NI = N 19095 JC = 1 19096 ELSE 19097 MI = M 19098 IC = 1 19099 END IF 19100 DO 10 I = I1, I2, I3 19101 IF( LEFT ) THEN 19102 MI = M - I + 1 19103 IC = I 19104 ELSE 19105 NI = N - I + 1 19106 JC = I 19107 END IF 19108 AII = A( I, I ) 19109 A( I, I ) = ONE 19110 CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), 19111 $ C( IC, JC ), LDC, WORK ) 19112 A( I, I ) = AII 19113 10 CONTINUE 19114 RETURN 19115 END 19116! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dormlq.f 19117 SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, 19118 $ WORK, LWORK, INFO ) 19119 CHARACTER SIDE, TRANS 19120 INTEGER INFO, K, LDA, LDC, LWORK, M, N 19121 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 19122 INTEGER NBMAX, LDT, TSIZE 19123 PARAMETER ( NBMAX = 64, LDT = NBMAX+1, 19124 $ TSIZE = LDT*NBMAX ) 19125 LOGICAL LEFT, LQUERY, NOTRAN 19126 CHARACTER TRANST 19127 INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, 19128 $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW 19129 LOGICAL LSAME 19130 INTEGER ILAENV 19131 EXTERNAL LSAME, ILAENV 19132 EXTERNAL DLARFB, DLARFT, DORML2, XERBLA 19133 INTRINSIC MAX, MIN 19134 INFO = 0 19135 LEFT = LSAME( SIDE, 'L' ) 19136 NOTRAN = LSAME( TRANS, 'N' ) 19137 LQUERY = ( LWORK.EQ.-1 ) 19138 IF( LEFT ) THEN 19139 NQ = M 19140 NW = N 19141 ELSE 19142 NQ = N 19143 NW = M 19144 END IF 19145 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 19146 INFO = -1 19147 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN 19148 INFO = -2 19149 ELSE IF( M.LT.0 ) THEN 19150 INFO = -3 19151 ELSE IF( N.LT.0 ) THEN 19152 INFO = -4 19153 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN 19154 INFO = -5 19155 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN 19156 INFO = -7 19157 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 19158 INFO = -10 19159 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN 19160 INFO = -12 19161 END IF 19162 IF( INFO.EQ.0 ) THEN 19163 NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, 19164 $ -1 ) ) 19165 LWKOPT = MAX( 1, NW )*NB + TSIZE 19166 WORK( 1 ) = LWKOPT 19167 END IF 19168 IF( INFO.NE.0 ) THEN 19169 CALL XERBLA( 'DORMLQ', -INFO ) 19170 RETURN 19171 ELSE IF( LQUERY ) THEN 19172 RETURN 19173 END IF 19174 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN 19175 WORK( 1 ) = 1 19176 RETURN 19177 END IF 19178 NBMIN = 2 19179 LDWORK = NW 19180 IF( NB.GT.1 .AND. NB.LT.K ) THEN 19181 IF( LWORK.LT.NW*NB+TSIZE ) THEN 19182 NB = (LWORK-TSIZE) / LDWORK 19183 NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, 19184 $ -1 ) ) 19185 END IF 19186 END IF 19187 IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN 19188 CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, 19189 $ IINFO ) 19190 ELSE 19191 IWT = 1 + NW*NB 19192 IF( ( LEFT .AND. NOTRAN ) .OR. 19193 $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN 19194 I1 = 1 19195 I2 = K 19196 I3 = NB 19197 ELSE 19198 I1 = ( ( K-1 ) / NB )*NB + 1 19199 I2 = 1 19200 I3 = -NB 19201 END IF 19202 IF( LEFT ) THEN 19203 NI = N 19204 JC = 1 19205 ELSE 19206 MI = M 19207 IC = 1 19208 END IF 19209 IF( NOTRAN ) THEN 19210 TRANST = 'T' 19211 ELSE 19212 TRANST = 'N' 19213 END IF 19214 DO 10 I = I1, I2, I3 19215 IB = MIN( NB, K-I+1 ) 19216 CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), 19217 $ LDA, TAU( I ), WORK( IWT ), LDT ) 19218 IF( LEFT ) THEN 19219 MI = M - I + 1 19220 IC = I 19221 ELSE 19222 NI = N - I + 1 19223 JC = I 19224 END IF 19225 CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, 19226 $ A( I, I ), LDA, WORK( IWT ), LDT, 19227 $ C( IC, JC ), LDC, WORK, LDWORK ) 19228 10 CONTINUE 19229 END IF 19230 WORK( 1 ) = LWKOPT 19231 RETURN 19232 END 19233! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dormql.f 19234 SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, 19235 $ WORK, LWORK, INFO ) 19236 CHARACTER SIDE, TRANS 19237 INTEGER INFO, K, LDA, LDC, LWORK, M, N 19238 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 19239 INTEGER NBMAX, LDT, TSIZE 19240 PARAMETER ( NBMAX = 64, LDT = NBMAX+1, 19241 $ TSIZE = LDT*NBMAX ) 19242 LOGICAL LEFT, LQUERY, NOTRAN 19243 INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT, 19244 $ MI, NB, NBMIN, NI, NQ, NW 19245 LOGICAL LSAME 19246 INTEGER ILAENV 19247 EXTERNAL LSAME, ILAENV 19248 EXTERNAL DLARFB, DLARFT, DORM2L, XERBLA 19249 INTRINSIC MAX, MIN 19250 INFO = 0 19251 LEFT = LSAME( SIDE, 'L' ) 19252 NOTRAN = LSAME( TRANS, 'N' ) 19253 LQUERY = ( LWORK.EQ.-1 ) 19254 IF( LEFT ) THEN 19255 NQ = M 19256 NW = MAX( 1, N ) 19257 ELSE 19258 NQ = N 19259 NW = MAX( 1, M ) 19260 END IF 19261 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 19262 INFO = -1 19263 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN 19264 INFO = -2 19265 ELSE IF( M.LT.0 ) THEN 19266 INFO = -3 19267 ELSE IF( N.LT.0 ) THEN 19268 INFO = -4 19269 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN 19270 INFO = -5 19271 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 19272 INFO = -7 19273 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 19274 INFO = -10 19275 ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN 19276 INFO = -12 19277 END IF 19278 IF( INFO.EQ.0 ) THEN 19279 IF( M.EQ.0 .OR. N.EQ.0 ) THEN 19280 LWKOPT = 1 19281 ELSE 19282 NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, 19283 $ K, -1 ) ) 19284 LWKOPT = NW*NB + TSIZE 19285 END IF 19286 WORK( 1 ) = LWKOPT 19287 END IF 19288 IF( INFO.NE.0 ) THEN 19289 CALL XERBLA( 'DORMQL', -INFO ) 19290 RETURN 19291 ELSE IF( LQUERY ) THEN 19292 RETURN 19293 END IF 19294 IF( M.EQ.0 .OR. N.EQ.0 ) THEN 19295 RETURN 19296 END IF 19297 NBMIN = 2 19298 LDWORK = NW 19299 IF( NB.GT.1 .AND. NB.LT.K ) THEN 19300 IF( LWORK.LT.NW*NB+TSIZE ) THEN 19301 NB = (LWORK-TSIZE) / LDWORK 19302 NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, 19303 $ -1 ) ) 19304 END IF 19305 END IF 19306 IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN 19307 CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, 19308 $ IINFO ) 19309 ELSE 19310 IWT = 1 + NW*NB 19311 IF( ( LEFT .AND. NOTRAN ) .OR. 19312 $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN 19313 I1 = 1 19314 I2 = K 19315 I3 = NB 19316 ELSE 19317 I1 = ( ( K-1 ) / NB )*NB + 1 19318 I2 = 1 19319 I3 = -NB 19320 END IF 19321 IF( LEFT ) THEN 19322 NI = N 19323 ELSE 19324 MI = M 19325 END IF 19326 DO 10 I = I1, I2, I3 19327 IB = MIN( NB, K-I+1 ) 19328 CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, 19329 $ A( 1, I ), LDA, TAU( I ), WORK( IWT ), LDT ) 19330 IF( LEFT ) THEN 19331 MI = M - K + I + IB - 1 19332 ELSE 19333 NI = N - K + I + IB - 1 19334 END IF 19335 CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, 19336 $ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC, 19337 $ WORK, LDWORK ) 19338 10 CONTINUE 19339 END IF 19340 WORK( 1 ) = LWKOPT 19341 RETURN 19342 END 19343! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dormqr.f 19344 SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, 19345 $ WORK, LWORK, INFO ) 19346 CHARACTER SIDE, TRANS 19347 INTEGER INFO, K, LDA, LDC, LWORK, M, N 19348 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 19349 INTEGER NBMAX, LDT, TSIZE 19350 PARAMETER ( NBMAX = 64, LDT = NBMAX+1, 19351 $ TSIZE = LDT*NBMAX ) 19352 LOGICAL LEFT, LQUERY, NOTRAN 19353 INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, 19354 $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW 19355 LOGICAL LSAME 19356 INTEGER ILAENV 19357 EXTERNAL LSAME, ILAENV 19358 EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA 19359 INTRINSIC MAX, MIN 19360 INFO = 0 19361 LEFT = LSAME( SIDE, 'L' ) 19362 NOTRAN = LSAME( TRANS, 'N' ) 19363 LQUERY = ( LWORK.EQ.-1 ) 19364 IF( LEFT ) THEN 19365 NQ = M 19366 NW = N 19367 ELSE 19368 NQ = N 19369 NW = M 19370 END IF 19371 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 19372 INFO = -1 19373 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN 19374 INFO = -2 19375 ELSE IF( M.LT.0 ) THEN 19376 INFO = -3 19377 ELSE IF( N.LT.0 ) THEN 19378 INFO = -4 19379 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN 19380 INFO = -5 19381 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 19382 INFO = -7 19383 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 19384 INFO = -10 19385 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN 19386 INFO = -12 19387 END IF 19388 IF( INFO.EQ.0 ) THEN 19389 NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, 19390 $ -1 ) ) 19391 LWKOPT = MAX( 1, NW )*NB + TSIZE 19392 WORK( 1 ) = LWKOPT 19393 END IF 19394 IF( INFO.NE.0 ) THEN 19395 CALL XERBLA( 'DORMQR', -INFO ) 19396 RETURN 19397 ELSE IF( LQUERY ) THEN 19398 RETURN 19399 END IF 19400 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN 19401 WORK( 1 ) = 1 19402 RETURN 19403 END IF 19404 NBMIN = 2 19405 LDWORK = NW 19406 IF( NB.GT.1 .AND. NB.LT.K ) THEN 19407 IF( LWORK.LT.NW*NB+TSIZE ) THEN 19408 NB = (LWORK-TSIZE) / LDWORK 19409 NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, 19410 $ -1 ) ) 19411 END IF 19412 END IF 19413 IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN 19414 CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, 19415 $ IINFO ) 19416 ELSE 19417 IWT = 1 + NW*NB 19418 IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. 19419 $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN 19420 I1 = 1 19421 I2 = K 19422 I3 = NB 19423 ELSE 19424 I1 = ( ( K-1 ) / NB )*NB + 1 19425 I2 = 1 19426 I3 = -NB 19427 END IF 19428 IF( LEFT ) THEN 19429 NI = N 19430 JC = 1 19431 ELSE 19432 MI = M 19433 IC = 1 19434 END IF 19435 DO 10 I = I1, I2, I3 19436 IB = MIN( NB, K-I+1 ) 19437 CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), 19438 $ LDA, TAU( I ), WORK( IWT ), LDT ) 19439 IF( LEFT ) THEN 19440 MI = M - I + 1 19441 IC = I 19442 ELSE 19443 NI = N - I + 1 19444 JC = I 19445 END IF 19446 CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, 19447 $ IB, A( I, I ), LDA, WORK( IWT ), LDT, 19448 $ C( IC, JC ), LDC, WORK, LDWORK ) 19449 10 CONTINUE 19450 END IF 19451 WORK( 1 ) = LWKOPT 19452 RETURN 19453 END 19454! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dormtr.f 19455 SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, 19456 $ WORK, LWORK, INFO ) 19457 CHARACTER SIDE, TRANS, UPLO 19458 INTEGER INFO, LDA, LDC, LWORK, M, N 19459 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 19460 LOGICAL LEFT, LQUERY, UPPER 19461 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW 19462 LOGICAL LSAME 19463 INTEGER ILAENV 19464 EXTERNAL LSAME, ILAENV 19465 EXTERNAL DORMQL, DORMQR, XERBLA 19466 INTRINSIC MAX 19467 INFO = 0 19468 LEFT = LSAME( SIDE, 'L' ) 19469 UPPER = LSAME( UPLO, 'U' ) 19470 LQUERY = ( LWORK.EQ.-1 ) 19471 IF( LEFT ) THEN 19472 NQ = M 19473 NW = N 19474 ELSE 19475 NQ = N 19476 NW = M 19477 END IF 19478 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 19479 INFO = -1 19480 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 19481 INFO = -2 19482 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) 19483 $ THEN 19484 INFO = -3 19485 ELSE IF( M.LT.0 ) THEN 19486 INFO = -4 19487 ELSE IF( N.LT.0 ) THEN 19488 INFO = -5 19489 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 19490 INFO = -7 19491 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 19492 INFO = -10 19493 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN 19494 INFO = -12 19495 END IF 19496 IF( INFO.EQ.0 ) THEN 19497 IF( UPPER ) THEN 19498 IF( LEFT ) THEN 19499 NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1, 19500 $ -1 ) 19501 ELSE 19502 NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1, 19503 $ -1 ) 19504 END IF 19505 ELSE 19506 IF( LEFT ) THEN 19507 NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, 19508 $ -1 ) 19509 ELSE 19510 NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, 19511 $ -1 ) 19512 END IF 19513 END IF 19514 LWKOPT = MAX( 1, NW )*NB 19515 WORK( 1 ) = LWKOPT 19516 END IF 19517 IF( INFO.NE.0 ) THEN 19518 CALL XERBLA( 'DORMTR', -INFO ) 19519 RETURN 19520 ELSE IF( LQUERY ) THEN 19521 RETURN 19522 END IF 19523 IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN 19524 WORK( 1 ) = 1 19525 RETURN 19526 END IF 19527 IF( LEFT ) THEN 19528 MI = M - 1 19529 NI = N 19530 ELSE 19531 MI = M 19532 NI = N - 1 19533 END IF 19534 IF( UPPER ) THEN 19535 CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, 19536 $ LDC, WORK, LWORK, IINFO ) 19537 ELSE 19538 IF( LEFT ) THEN 19539 I1 = 2 19540 I2 = 1 19541 ELSE 19542 I1 = 1 19543 I2 = 2 19544 END IF 19545 CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, 19546 $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) 19547 END IF 19548 WORK( 1 ) = LWKOPT 19549 RETURN 19550 END 19551! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dpotrf.f 19552 SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) 19553 CHARACTER UPLO 19554 INTEGER INFO, LDA, N 19555 DOUBLE PRECISION A( LDA, * ) 19556 DOUBLE PRECISION ONE 19557 PARAMETER ( ONE = 1.0D+0 ) 19558 LOGICAL UPPER 19559 INTEGER J, JB, NB 19560 LOGICAL LSAME 19561 INTEGER ILAENV 19562 EXTERNAL LSAME, ILAENV 19563 EXTERNAL DGEMM, DPOTRF2, DSYRK, DTRSM, XERBLA 19564 INTRINSIC MAX, MIN 19565 INFO = 0 19566 UPPER = LSAME( UPLO, 'U' ) 19567 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 19568 INFO = -1 19569 ELSE IF( N.LT.0 ) THEN 19570 INFO = -2 19571 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 19572 INFO = -4 19573 END IF 19574 IF( INFO.NE.0 ) THEN 19575 CALL XERBLA( 'DPOTRF', -INFO ) 19576 RETURN 19577 END IF 19578 IF( N.EQ.0 ) 19579 $ RETURN 19580 NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 ) 19581 IF( NB.LE.1 .OR. NB.GE.N ) THEN 19582 CALL DPOTRF2( UPLO, N, A, LDA, INFO ) 19583 ELSE 19584 IF( UPPER ) THEN 19585 DO 10 J = 1, N, NB 19586 JB = MIN( NB, N-J+1 ) 19587 CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, 19588 $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) 19589 CALL DPOTRF2( 'Upper', JB, A( J, J ), LDA, INFO ) 19590 IF( INFO.NE.0 ) 19591 $ GO TO 30 19592 IF( J+JB.LE.N ) THEN 19593 CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, 19594 $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), 19595 $ LDA, ONE, A( J, J+JB ), LDA ) 19596 CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', 19597 $ JB, N-J-JB+1, ONE, A( J, J ), LDA, 19598 $ A( J, J+JB ), LDA ) 19599 END IF 19600 10 CONTINUE 19601 ELSE 19602 DO 20 J = 1, N, NB 19603 JB = MIN( NB, N-J+1 ) 19604 CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, 19605 $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) 19606 CALL DPOTRF2( 'Lower', JB, A( J, J ), LDA, INFO ) 19607 IF( INFO.NE.0 ) 19608 $ GO TO 30 19609 IF( J+JB.LE.N ) THEN 19610 CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, 19611 $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), 19612 $ LDA, ONE, A( J+JB, J ), LDA ) 19613 CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', 19614 $ N-J-JB+1, JB, ONE, A( J, J ), LDA, 19615 $ A( J+JB, J ), LDA ) 19616 END IF 19617 20 CONTINUE 19618 END IF 19619 END IF 19620 GO TO 40 19621 30 CONTINUE 19622 INFO = INFO + J - 1 19623 40 CONTINUE 19624 RETURN 19625 END 19626! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dpotrf2.f 19627 RECURSIVE SUBROUTINE DPOTRF2( UPLO, N, A, LDA, INFO ) 19628 CHARACTER UPLO 19629 INTEGER INFO, LDA, N 19630 DOUBLE PRECISION A( LDA, * ) 19631 DOUBLE PRECISION ONE, ZERO 19632 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 19633 LOGICAL UPPER 19634 INTEGER N1, N2, IINFO 19635 LOGICAL LSAME, DISNAN 19636 EXTERNAL LSAME, DISNAN 19637 EXTERNAL DSYRK, DTRSM, XERBLA 19638 INTRINSIC MAX, SQRT 19639 INFO = 0 19640 UPPER = LSAME( UPLO, 'U' ) 19641 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 19642 INFO = -1 19643 ELSE IF( N.LT.0 ) THEN 19644 INFO = -2 19645 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 19646 INFO = -4 19647 END IF 19648 IF( INFO.NE.0 ) THEN 19649 CALL XERBLA( 'DPOTRF2', -INFO ) 19650 RETURN 19651 END IF 19652 IF( N.EQ.0 ) 19653 $ RETURN 19654 IF( N.EQ.1 ) THEN 19655 IF( A( 1, 1 ).LE.ZERO.OR.DISNAN( A( 1, 1 ) ) ) THEN 19656 INFO = 1 19657 RETURN 19658 END IF 19659 A( 1, 1 ) = SQRT( A( 1, 1 ) ) 19660 ELSE 19661 N1 = N/2 19662 N2 = N-N1 19663 CALL DPOTRF2( UPLO, N1, A( 1, 1 ), LDA, IINFO ) 19664 IF ( IINFO.NE.0 ) THEN 19665 INFO = IINFO 19666 RETURN 19667 END IF 19668 IF( UPPER ) THEN 19669 CALL DTRSM( 'L', 'U', 'T', 'N', N1, N2, ONE, 19670 $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) 19671 CALL DSYRK( UPLO, 'T', N2, N1, -ONE, A( 1, N1+1 ), LDA, 19672 $ ONE, A( N1+1, N1+1 ), LDA ) 19673 CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) 19674 IF ( IINFO.NE.0 ) THEN 19675 INFO = IINFO + N1 19676 RETURN 19677 END IF 19678 ELSE 19679 CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, 19680 $ A( 1, 1 ), LDA, A( N1+1, 1 ), LDA ) 19681 CALL DSYRK( UPLO, 'N', N2, N1, -ONE, A( N1+1, 1 ), LDA, 19682 $ ONE, A( N1+1, N1+1 ), LDA ) 19683 CALL DPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) 19684 IF ( IINFO.NE.0 ) THEN 19685 INFO = IINFO + N1 19686 RETURN 19687 END IF 19688 END IF 19689 END IF 19690 RETURN 19691 END 19692! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dpotrs.f 19693 SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) 19694 CHARACTER UPLO 19695 INTEGER INFO, LDA, LDB, N, NRHS 19696 DOUBLE PRECISION A( LDA, * ), B( LDB, * ) 19697 DOUBLE PRECISION ONE 19698 PARAMETER ( ONE = 1.0D+0 ) 19699 LOGICAL UPPER 19700 LOGICAL LSAME 19701 EXTERNAL LSAME 19702 EXTERNAL DTRSM, XERBLA 19703 INTRINSIC MAX 19704 INFO = 0 19705 UPPER = LSAME( UPLO, 'U' ) 19706 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 19707 INFO = -1 19708 ELSE IF( N.LT.0 ) THEN 19709 INFO = -2 19710 ELSE IF( NRHS.LT.0 ) THEN 19711 INFO = -3 19712 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 19713 INFO = -5 19714 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 19715 INFO = -7 19716 END IF 19717 IF( INFO.NE.0 ) THEN 19718 CALL XERBLA( 'DPOTRS', -INFO ) 19719 RETURN 19720 END IF 19721 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 19722 $ RETURN 19723 IF( UPPER ) THEN 19724 CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, 19725 $ ONE, A, LDA, B, LDB ) 19726 CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, 19727 $ NRHS, ONE, A, LDA, B, LDB ) 19728 ELSE 19729 CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, 19730 $ NRHS, ONE, A, LDA, B, LDB ) 19731 CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, 19732 $ ONE, A, LDA, B, LDB ) 19733 END IF 19734 RETURN 19735 END 19736! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dpptrf.f 19737 SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) 19738 CHARACTER UPLO 19739 INTEGER INFO, N 19740 DOUBLE PRECISION AP( * ) 19741 DOUBLE PRECISION ONE, ZERO 19742 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 19743 LOGICAL UPPER 19744 INTEGER J, JC, JJ 19745 DOUBLE PRECISION AJJ 19746 LOGICAL LSAME 19747 DOUBLE PRECISION DDOT 19748 EXTERNAL LSAME, DDOT 19749 EXTERNAL DSCAL, DSPR, DTPSV, XERBLA 19750 INTRINSIC SQRT 19751 INFO = 0 19752 UPPER = LSAME( UPLO, 'U' ) 19753 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 19754 INFO = -1 19755 ELSE IF( N.LT.0 ) THEN 19756 INFO = -2 19757 END IF 19758 IF( INFO.NE.0 ) THEN 19759 CALL XERBLA( 'DPPTRF', -INFO ) 19760 RETURN 19761 END IF 19762 IF( N.EQ.0 ) 19763 $ RETURN 19764 IF( UPPER ) THEN 19765 JJ = 0 19766 DO 10 J = 1, N 19767 JC = JJ + 1 19768 JJ = JJ + J 19769 IF( J.GT.1 ) 19770 $ CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP, 19771 $ AP( JC ), 1 ) 19772 AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 ) 19773 IF( AJJ.LE.ZERO ) THEN 19774 AP( JJ ) = AJJ 19775 GO TO 30 19776 END IF 19777 AP( JJ ) = SQRT( AJJ ) 19778 10 CONTINUE 19779 ELSE 19780 JJ = 1 19781 DO 20 J = 1, N 19782 AJJ = AP( JJ ) 19783 IF( AJJ.LE.ZERO ) THEN 19784 AP( JJ ) = AJJ 19785 GO TO 30 19786 END IF 19787 AJJ = SQRT( AJJ ) 19788 AP( JJ ) = AJJ 19789 IF( J.LT.N ) THEN 19790 CALL DSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 ) 19791 CALL DSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1, 19792 $ AP( JJ+N-J+1 ) ) 19793 JJ = JJ + N - J + 1 19794 END IF 19795 20 CONTINUE 19796 END IF 19797 GO TO 40 19798 30 CONTINUE 19799 INFO = J 19800 40 CONTINUE 19801 RETURN 19802 END 19803! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/drscl.f 19804 SUBROUTINE DRSCL( N, SA, SX, INCX ) 19805 INTEGER INCX, N 19806 DOUBLE PRECISION SA 19807 DOUBLE PRECISION SX( * ) 19808 DOUBLE PRECISION ONE, ZERO 19809 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 19810 LOGICAL DONE 19811 DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM 19812 DOUBLE PRECISION DLAMCH 19813 EXTERNAL DLAMCH 19814 EXTERNAL DSCAL, DLABAD 19815 INTRINSIC ABS 19816 IF( N.LE.0 ) 19817 $ RETURN 19818 SMLNUM = DLAMCH( 'S' ) 19819 BIGNUM = ONE / SMLNUM 19820 CALL DLABAD( SMLNUM, BIGNUM ) 19821 CDEN = SA 19822 CNUM = ONE 19823 10 CONTINUE 19824 CDEN1 = CDEN*SMLNUM 19825 CNUM1 = CNUM / BIGNUM 19826 IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN 19827 MUL = SMLNUM 19828 DONE = .FALSE. 19829 CDEN = CDEN1 19830 ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN 19831 MUL = BIGNUM 19832 DONE = .FALSE. 19833 CNUM = CNUM1 19834 ELSE 19835 MUL = CNUM / CDEN 19836 DONE = .TRUE. 19837 END IF 19838 CALL DSCAL( N, MUL, SX, INCX ) 19839 IF( .NOT.DONE ) 19840 $ GO TO 10 19841 RETURN 19842 END 19843! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsb2st_kernels.f 19844 SUBROUTINE DSB2ST_KERNELS( UPLO, WANTZ, TTYPE, 19845 $ ST, ED, SWEEP, N, NB, IB, 19846 $ A, LDA, V, TAU, LDVT, WORK) 19847 IMPLICIT NONE 19848 CHARACTER UPLO 19849 LOGICAL WANTZ 19850 INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT 19851 DOUBLE PRECISION A( LDA, * ), V( * ), 19852 $ TAU( * ), WORK( * ) 19853 DOUBLE PRECISION ZERO, ONE 19854 PARAMETER ( ZERO = 0.0D+0, 19855 $ ONE = 1.0D+0 ) 19856 LOGICAL UPPER 19857 INTEGER I, J1, J2, LM, LN, VPOS, TAUPOS, 19858 $ DPOS, OFDPOS, AJETER 19859 DOUBLE PRECISION CTMP 19860 EXTERNAL DLARFG, DLARFX, DLARFY 19861 INTRINSIC MOD 19862 LOGICAL LSAME 19863 EXTERNAL LSAME 19864 AJETER = IB + LDVT 19865 UPPER = LSAME( UPLO, 'U' ) 19866 IF( UPPER ) THEN 19867 DPOS = 2 * NB + 1 19868 OFDPOS = 2 * NB 19869 ELSE 19870 DPOS = 1 19871 OFDPOS = 2 19872 ENDIF 19873 IF( UPPER ) THEN 19874 IF( WANTZ ) THEN 19875 VPOS = MOD( SWEEP-1, 2 ) * N + ST 19876 TAUPOS = MOD( SWEEP-1, 2 ) * N + ST 19877 ELSE 19878 VPOS = MOD( SWEEP-1, 2 ) * N + ST 19879 TAUPOS = MOD( SWEEP-1, 2 ) * N + ST 19880 ENDIF 19881 IF( TTYPE.EQ.1 ) THEN 19882 LM = ED - ST + 1 19883 V( VPOS ) = ONE 19884 DO 10 I = 1, LM-1 19885 V( VPOS+I ) = ( A( OFDPOS-I, ST+I ) ) 19886 A( OFDPOS-I, ST+I ) = ZERO 19887 10 CONTINUE 19888 CTMP = ( A( OFDPOS, ST ) ) 19889 CALL DLARFG( LM, CTMP, V( VPOS+1 ), 1, 19890 $ TAU( TAUPOS ) ) 19891 A( OFDPOS, ST ) = CTMP 19892 LM = ED - ST + 1 19893 CALL DLARFY( UPLO, LM, V( VPOS ), 1, 19894 $ ( TAU( TAUPOS ) ), 19895 $ A( DPOS, ST ), LDA-1, WORK) 19896 ENDIF 19897 IF( TTYPE.EQ.3 ) THEN 19898 LM = ED - ST + 1 19899 CALL DLARFY( UPLO, LM, V( VPOS ), 1, 19900 $ ( TAU( TAUPOS ) ), 19901 $ A( DPOS, ST ), LDA-1, WORK) 19902 ENDIF 19903 IF( TTYPE.EQ.2 ) THEN 19904 J1 = ED+1 19905 J2 = MIN( ED+NB, N ) 19906 LN = ED-ST+1 19907 LM = J2-J1+1 19908 IF( LM.GT.0) THEN 19909 CALL DLARFX( 'Left', LN, LM, V( VPOS ), 19910 $ ( TAU( TAUPOS ) ), 19911 $ A( DPOS-NB, J1 ), LDA-1, WORK) 19912 IF( WANTZ ) THEN 19913 VPOS = MOD( SWEEP-1, 2 ) * N + J1 19914 TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 19915 ELSE 19916 VPOS = MOD( SWEEP-1, 2 ) * N + J1 19917 TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 19918 ENDIF 19919 V( VPOS ) = ONE 19920 DO 30 I = 1, LM-1 19921 V( VPOS+I ) = 19922 $ ( A( DPOS-NB-I, J1+I ) ) 19923 A( DPOS-NB-I, J1+I ) = ZERO 19924 30 CONTINUE 19925 CTMP = ( A( DPOS-NB, J1 ) ) 19926 CALL DLARFG( LM, CTMP, V( VPOS+1 ), 1, TAU( TAUPOS ) ) 19927 A( DPOS-NB, J1 ) = CTMP 19928 CALL DLARFX( 'Right', LN-1, LM, V( VPOS ), 19929 $ TAU( TAUPOS ), 19930 $ A( DPOS-NB+1, J1 ), LDA-1, WORK) 19931 ENDIF 19932 ENDIF 19933 ELSE 19934 IF( WANTZ ) THEN 19935 VPOS = MOD( SWEEP-1, 2 ) * N + ST 19936 TAUPOS = MOD( SWEEP-1, 2 ) * N + ST 19937 ELSE 19938 VPOS = MOD( SWEEP-1, 2 ) * N + ST 19939 TAUPOS = MOD( SWEEP-1, 2 ) * N + ST 19940 ENDIF 19941 IF( TTYPE.EQ.1 ) THEN 19942 LM = ED - ST + 1 19943 V( VPOS ) = ONE 19944 DO 20 I = 1, LM-1 19945 V( VPOS+I ) = A( OFDPOS+I, ST-1 ) 19946 A( OFDPOS+I, ST-1 ) = ZERO 19947 20 CONTINUE 19948 CALL DLARFG( LM, A( OFDPOS, ST-1 ), V( VPOS+1 ), 1, 19949 $ TAU( TAUPOS ) ) 19950 LM = ED - ST + 1 19951 CALL DLARFY( UPLO, LM, V( VPOS ), 1, 19952 $ ( TAU( TAUPOS ) ), 19953 $ A( DPOS, ST ), LDA-1, WORK) 19954 ENDIF 19955 IF( TTYPE.EQ.3 ) THEN 19956 LM = ED - ST + 1 19957 CALL DLARFY( UPLO, LM, V( VPOS ), 1, 19958 $ ( TAU( TAUPOS ) ), 19959 $ A( DPOS, ST ), LDA-1, WORK) 19960 ENDIF 19961 IF( TTYPE.EQ.2 ) THEN 19962 J1 = ED+1 19963 J2 = MIN( ED+NB, N ) 19964 LN = ED-ST+1 19965 LM = J2-J1+1 19966 IF( LM.GT.0) THEN 19967 CALL DLARFX( 'Right', LM, LN, V( VPOS ), 19968 $ TAU( TAUPOS ), A( DPOS+NB, ST ), 19969 $ LDA-1, WORK) 19970 IF( WANTZ ) THEN 19971 VPOS = MOD( SWEEP-1, 2 ) * N + J1 19972 TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 19973 ELSE 19974 VPOS = MOD( SWEEP-1, 2 ) * N + J1 19975 TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 19976 ENDIF 19977 V( VPOS ) = ONE 19978 DO 40 I = 1, LM-1 19979 V( VPOS+I ) = A( DPOS+NB+I, ST ) 19980 A( DPOS+NB+I, ST ) = ZERO 19981 40 CONTINUE 19982 CALL DLARFG( LM, A( DPOS+NB, ST ), V( VPOS+1 ), 1, 19983 $ TAU( TAUPOS ) ) 19984 CALL DLARFX( 'Left', LM, LN-1, V( VPOS ), 19985 $ ( TAU( TAUPOS ) ), 19986 $ A( DPOS+NB-1, ST+1 ), LDA-1, WORK) 19987 ENDIF 19988 ENDIF 19989 ENDIF 19990 RETURN 19991 END 19992! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dspev.f 19993 SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) 19994 CHARACTER JOBZ, UPLO 19995 INTEGER INFO, LDZ, N 19996 DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) 19997 DOUBLE PRECISION ZERO, ONE 19998 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 19999 LOGICAL WANTZ 20000 INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE 20001 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 20002 $ SMLNUM 20003 LOGICAL LSAME 20004 DOUBLE PRECISION DLAMCH, DLANSP 20005 EXTERNAL LSAME, DLAMCH, DLANSP 20006 EXTERNAL DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA 20007 INTRINSIC SQRT 20008 WANTZ = LSAME( JOBZ, 'V' ) 20009 INFO = 0 20010 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 20011 INFO = -1 20012 ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) 20013 $ THEN 20014 INFO = -2 20015 ELSE IF( N.LT.0 ) THEN 20016 INFO = -3 20017 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 20018 INFO = -7 20019 END IF 20020 IF( INFO.NE.0 ) THEN 20021 CALL XERBLA( 'DSPEV ', -INFO ) 20022 RETURN 20023 END IF 20024 IF( N.EQ.0 ) 20025 $ RETURN 20026 IF( N.EQ.1 ) THEN 20027 W( 1 ) = AP( 1 ) 20028 IF( WANTZ ) 20029 $ Z( 1, 1 ) = ONE 20030 RETURN 20031 END IF 20032 SAFMIN = DLAMCH( 'Safe minimum' ) 20033 EPS = DLAMCH( 'Precision' ) 20034 SMLNUM = SAFMIN / EPS 20035 BIGNUM = ONE / SMLNUM 20036 RMIN = SQRT( SMLNUM ) 20037 RMAX = SQRT( BIGNUM ) 20038 ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) 20039 ISCALE = 0 20040 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 20041 ISCALE = 1 20042 SIGMA = RMIN / ANRM 20043 ELSE IF( ANRM.GT.RMAX ) THEN 20044 ISCALE = 1 20045 SIGMA = RMAX / ANRM 20046 END IF 20047 IF( ISCALE.EQ.1 ) THEN 20048 CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) 20049 END IF 20050 INDE = 1 20051 INDTAU = INDE + N 20052 CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO ) 20053 IF( .NOT.WANTZ ) THEN 20054 CALL DSTERF( N, W, WORK( INDE ), INFO ) 20055 ELSE 20056 INDWRK = INDTAU + N 20057 CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, 20058 $ WORK( INDWRK ), IINFO ) 20059 CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ), 20060 $ INFO ) 20061 END IF 20062 IF( ISCALE.EQ.1 ) THEN 20063 IF( INFO.EQ.0 ) THEN 20064 IMAX = N 20065 ELSE 20066 IMAX = INFO - 1 20067 END IF 20068 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 20069 END IF 20070 RETURN 20071 END 20072! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dspevd.f 20073 SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, 20074 $ IWORK, LIWORK, INFO ) 20075 CHARACTER JOBZ, UPLO 20076 INTEGER INFO, LDZ, LIWORK, LWORK, N 20077 INTEGER IWORK( * ) 20078 DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) 20079 DOUBLE PRECISION ZERO, ONE 20080 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 20081 LOGICAL LQUERY, WANTZ 20082 INTEGER IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN, 20083 $ LLWORK, LWMIN 20084 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 20085 $ SMLNUM 20086 LOGICAL LSAME 20087 DOUBLE PRECISION DLAMCH, DLANSP 20088 EXTERNAL LSAME, DLAMCH, DLANSP 20089 EXTERNAL DOPMTR, DSCAL, DSPTRD, DSTEDC, DSTERF, XERBLA 20090 INTRINSIC SQRT 20091 WANTZ = LSAME( JOBZ, 'V' ) 20092 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 20093 INFO = 0 20094 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 20095 INFO = -1 20096 ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) 20097 $ THEN 20098 INFO = -2 20099 ELSE IF( N.LT.0 ) THEN 20100 INFO = -3 20101 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 20102 INFO = -7 20103 END IF 20104 IF( INFO.EQ.0 ) THEN 20105 IF( N.LE.1 ) THEN 20106 LIWMIN = 1 20107 LWMIN = 1 20108 ELSE 20109 IF( WANTZ ) THEN 20110 LIWMIN = 3 + 5*N 20111 LWMIN = 1 + 6*N + N**2 20112 ELSE 20113 LIWMIN = 1 20114 LWMIN = 2*N 20115 END IF 20116 END IF 20117 IWORK( 1 ) = LIWMIN 20118 WORK( 1 ) = LWMIN 20119 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 20120 INFO = -9 20121 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 20122 INFO = -11 20123 END IF 20124 END IF 20125 IF( INFO.NE.0 ) THEN 20126 CALL XERBLA( 'DSPEVD', -INFO ) 20127 RETURN 20128 ELSE IF( LQUERY ) THEN 20129 RETURN 20130 END IF 20131 IF( N.EQ.0 ) 20132 $ RETURN 20133 IF( N.EQ.1 ) THEN 20134 W( 1 ) = AP( 1 ) 20135 IF( WANTZ ) 20136 $ Z( 1, 1 ) = ONE 20137 RETURN 20138 END IF 20139 SAFMIN = DLAMCH( 'Safe minimum' ) 20140 EPS = DLAMCH( 'Precision' ) 20141 SMLNUM = SAFMIN / EPS 20142 BIGNUM = ONE / SMLNUM 20143 RMIN = SQRT( SMLNUM ) 20144 RMAX = SQRT( BIGNUM ) 20145 ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) 20146 ISCALE = 0 20147 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 20148 ISCALE = 1 20149 SIGMA = RMIN / ANRM 20150 ELSE IF( ANRM.GT.RMAX ) THEN 20151 ISCALE = 1 20152 SIGMA = RMAX / ANRM 20153 END IF 20154 IF( ISCALE.EQ.1 ) THEN 20155 CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) 20156 END IF 20157 INDE = 1 20158 INDTAU = INDE + N 20159 CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO ) 20160 IF( .NOT.WANTZ ) THEN 20161 CALL DSTERF( N, W, WORK( INDE ), INFO ) 20162 ELSE 20163 INDWRK = INDTAU + N 20164 LLWORK = LWORK - INDWRK + 1 20165 CALL DSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ), 20166 $ LLWORK, IWORK, LIWORK, INFO ) 20167 CALL DOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ, 20168 $ WORK( INDWRK ), IINFO ) 20169 END IF 20170 IF( ISCALE.EQ.1 ) 20171 $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) 20172 WORK( 1 ) = LWMIN 20173 IWORK( 1 ) = LIWMIN 20174 RETURN 20175 END 20176! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dspgst.f 20177 SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) 20178 CHARACTER UPLO 20179 INTEGER INFO, ITYPE, N 20180 DOUBLE PRECISION AP( * ), BP( * ) 20181 DOUBLE PRECISION ONE, HALF 20182 PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) 20183 LOGICAL UPPER 20184 INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK 20185 DOUBLE PRECISION AJJ, AKK, BJJ, BKK, CT 20186 EXTERNAL DAXPY, DSCAL, DSPMV, DSPR2, DTPMV, DTPSV, 20187 $ XERBLA 20188 LOGICAL LSAME 20189 DOUBLE PRECISION DDOT 20190 EXTERNAL LSAME, DDOT 20191 INFO = 0 20192 UPPER = LSAME( UPLO, 'U' ) 20193 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN 20194 INFO = -1 20195 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 20196 INFO = -2 20197 ELSE IF( N.LT.0 ) THEN 20198 INFO = -3 20199 END IF 20200 IF( INFO.NE.0 ) THEN 20201 CALL XERBLA( 'DSPGST', -INFO ) 20202 RETURN 20203 END IF 20204 IF( ITYPE.EQ.1 ) THEN 20205 IF( UPPER ) THEN 20206 JJ = 0 20207 DO 10 J = 1, N 20208 J1 = JJ + 1 20209 JJ = JJ + J 20210 BJJ = BP( JJ ) 20211 CALL DTPSV( UPLO, 'Transpose', 'Nonunit', J, BP, 20212 $ AP( J1 ), 1 ) 20213 CALL DSPMV( UPLO, J-1, -ONE, AP, BP( J1 ), 1, ONE, 20214 $ AP( J1 ), 1 ) 20215 CALL DSCAL( J-1, ONE / BJJ, AP( J1 ), 1 ) 20216 AP( JJ ) = ( AP( JJ )-DDOT( J-1, AP( J1 ), 1, BP( J1 ), 20217 $ 1 ) ) / BJJ 20218 10 CONTINUE 20219 ELSE 20220 KK = 1 20221 DO 20 K = 1, N 20222 K1K1 = KK + N - K + 1 20223 AKK = AP( KK ) 20224 BKK = BP( KK ) 20225 AKK = AKK / BKK**2 20226 AP( KK ) = AKK 20227 IF( K.LT.N ) THEN 20228 CALL DSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 ) 20229 CT = -HALF*AKK 20230 CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 ) 20231 CALL DSPR2( UPLO, N-K, -ONE, AP( KK+1 ), 1, 20232 $ BP( KK+1 ), 1, AP( K1K1 ) ) 20233 CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 ) 20234 CALL DTPSV( UPLO, 'No transpose', 'Non-unit', N-K, 20235 $ BP( K1K1 ), AP( KK+1 ), 1 ) 20236 END IF 20237 KK = K1K1 20238 20 CONTINUE 20239 END IF 20240 ELSE 20241 IF( UPPER ) THEN 20242 KK = 0 20243 DO 30 K = 1, N 20244 K1 = KK + 1 20245 KK = KK + K 20246 AKK = AP( KK ) 20247 BKK = BP( KK ) 20248 CALL DTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP, 20249 $ AP( K1 ), 1 ) 20250 CT = HALF*AKK 20251 CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 ) 20252 CALL DSPR2( UPLO, K-1, ONE, AP( K1 ), 1, BP( K1 ), 1, 20253 $ AP ) 20254 CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 ) 20255 CALL DSCAL( K-1, BKK, AP( K1 ), 1 ) 20256 AP( KK ) = AKK*BKK**2 20257 30 CONTINUE 20258 ELSE 20259 JJ = 1 20260 DO 40 J = 1, N 20261 J1J1 = JJ + N - J + 1 20262 AJJ = AP( JJ ) 20263 BJJ = BP( JJ ) 20264 AP( JJ ) = AJJ*BJJ + DDOT( N-J, AP( JJ+1 ), 1, 20265 $ BP( JJ+1 ), 1 ) 20266 CALL DSCAL( N-J, BJJ, AP( JJ+1 ), 1 ) 20267 CALL DSPMV( UPLO, N-J, ONE, AP( J1J1 ), BP( JJ+1 ), 1, 20268 $ ONE, AP( JJ+1 ), 1 ) 20269 CALL DTPMV( UPLO, 'Transpose', 'Non-unit', N-J+1, 20270 $ BP( JJ ), AP( JJ ), 1 ) 20271 JJ = J1J1 20272 40 CONTINUE 20273 END IF 20274 END IF 20275 RETURN 20276 END 20277! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dspgv.f 20278 SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, 20279 $ INFO ) 20280 CHARACTER JOBZ, UPLO 20281 INTEGER INFO, ITYPE, LDZ, N 20282 DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), 20283 $ Z( LDZ, * ) 20284 LOGICAL UPPER, WANTZ 20285 CHARACTER TRANS 20286 INTEGER J, NEIG 20287 LOGICAL LSAME 20288 EXTERNAL LSAME 20289 EXTERNAL DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA 20290 WANTZ = LSAME( JOBZ, 'V' ) 20291 UPPER = LSAME( UPLO, 'U' ) 20292 INFO = 0 20293 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN 20294 INFO = -1 20295 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 20296 INFO = -2 20297 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN 20298 INFO = -3 20299 ELSE IF( N.LT.0 ) THEN 20300 INFO = -4 20301 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 20302 INFO = -9 20303 END IF 20304 IF( INFO.NE.0 ) THEN 20305 CALL XERBLA( 'DSPGV ', -INFO ) 20306 RETURN 20307 END IF 20308 IF( N.EQ.0 ) 20309 $ RETURN 20310 CALL DPPTRF( UPLO, N, BP, INFO ) 20311 IF( INFO.NE.0 ) THEN 20312 INFO = N + INFO 20313 RETURN 20314 END IF 20315 CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) 20316 CALL DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) 20317 IF( WANTZ ) THEN 20318 NEIG = N 20319 IF( INFO.GT.0 ) 20320 $ NEIG = INFO - 1 20321 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN 20322 IF( UPPER ) THEN 20323 TRANS = 'N' 20324 ELSE 20325 TRANS = 'T' 20326 END IF 20327 DO 10 J = 1, NEIG 20328 CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), 20329 $ 1 ) 20330 10 CONTINUE 20331 ELSE IF( ITYPE.EQ.3 ) THEN 20332 IF( UPPER ) THEN 20333 TRANS = 'T' 20334 ELSE 20335 TRANS = 'N' 20336 END IF 20337 DO 20 J = 1, NEIG 20338 CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), 20339 $ 1 ) 20340 20 CONTINUE 20341 END IF 20342 END IF 20343 RETURN 20344 END 20345! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dspgvd.f 20346 SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, 20347 $ LWORK, IWORK, LIWORK, INFO ) 20348 CHARACTER JOBZ, UPLO 20349 INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N 20350 INTEGER IWORK( * ) 20351 DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ), 20352 $ Z( LDZ, * ) 20353 LOGICAL LQUERY, UPPER, WANTZ 20354 CHARACTER TRANS 20355 INTEGER J, LIWMIN, LWMIN, NEIG 20356 LOGICAL LSAME 20357 EXTERNAL LSAME 20358 EXTERNAL DPPTRF, DSPEVD, DSPGST, DTPMV, DTPSV, XERBLA 20359 INTRINSIC DBLE, MAX 20360 WANTZ = LSAME( JOBZ, 'V' ) 20361 UPPER = LSAME( UPLO, 'U' ) 20362 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 20363 INFO = 0 20364 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN 20365 INFO = -1 20366 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 20367 INFO = -2 20368 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN 20369 INFO = -3 20370 ELSE IF( N.LT.0 ) THEN 20371 INFO = -4 20372 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 20373 INFO = -9 20374 END IF 20375 IF( INFO.EQ.0 ) THEN 20376 IF( N.LE.1 ) THEN 20377 LIWMIN = 1 20378 LWMIN = 1 20379 ELSE 20380 IF( WANTZ ) THEN 20381 LIWMIN = 3 + 5*N 20382 LWMIN = 1 + 6*N + 2*N**2 20383 ELSE 20384 LIWMIN = 1 20385 LWMIN = 2*N 20386 END IF 20387 END IF 20388 WORK( 1 ) = LWMIN 20389 IWORK( 1 ) = LIWMIN 20390 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 20391 INFO = -11 20392 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 20393 INFO = -13 20394 END IF 20395 END IF 20396 IF( INFO.NE.0 ) THEN 20397 CALL XERBLA( 'DSPGVD', -INFO ) 20398 RETURN 20399 ELSE IF( LQUERY ) THEN 20400 RETURN 20401 END IF 20402 IF( N.EQ.0 ) 20403 $ RETURN 20404 CALL DPPTRF( UPLO, N, BP, INFO ) 20405 IF( INFO.NE.0 ) THEN 20406 INFO = N + INFO 20407 RETURN 20408 END IF 20409 CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) 20410 CALL DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, 20411 $ LIWORK, INFO ) 20412 LWMIN = MAX( DBLE( LWMIN ), DBLE( WORK( 1 ) ) ) 20413 LIWMIN = MAX( DBLE( LIWMIN ), DBLE( IWORK( 1 ) ) ) 20414 IF( WANTZ ) THEN 20415 NEIG = N 20416 IF( INFO.GT.0 ) 20417 $ NEIG = INFO - 1 20418 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN 20419 IF( UPPER ) THEN 20420 TRANS = 'N' 20421 ELSE 20422 TRANS = 'T' 20423 END IF 20424 DO 10 J = 1, NEIG 20425 CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), 20426 $ 1 ) 20427 10 CONTINUE 20428 ELSE IF( ITYPE.EQ.3 ) THEN 20429 IF( UPPER ) THEN 20430 TRANS = 'T' 20431 ELSE 20432 TRANS = 'N' 20433 END IF 20434 DO 20 J = 1, NEIG 20435 CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), 20436 $ 1 ) 20437 20 CONTINUE 20438 END IF 20439 END IF 20440 WORK( 1 ) = LWMIN 20441 IWORK( 1 ) = LIWMIN 20442 RETURN 20443 END 20444! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsptrd.f 20445 SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) 20446 CHARACTER UPLO 20447 INTEGER INFO, N 20448 DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) 20449 DOUBLE PRECISION ONE, ZERO, HALF 20450 PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, 20451 $ HALF = 1.0D0 / 2.0D0 ) 20452 LOGICAL UPPER 20453 INTEGER I, I1, I1I1, II 20454 DOUBLE PRECISION ALPHA, TAUI 20455 EXTERNAL DAXPY, DLARFG, DSPMV, DSPR2, XERBLA 20456 LOGICAL LSAME 20457 DOUBLE PRECISION DDOT 20458 EXTERNAL LSAME, DDOT 20459 INFO = 0 20460 UPPER = LSAME( UPLO, 'U' ) 20461 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 20462 INFO = -1 20463 ELSE IF( N.LT.0 ) THEN 20464 INFO = -2 20465 END IF 20466 IF( INFO.NE.0 ) THEN 20467 CALL XERBLA( 'DSPTRD', -INFO ) 20468 RETURN 20469 END IF 20470 IF( N.LE.0 ) 20471 $ RETURN 20472 IF( UPPER ) THEN 20473 I1 = N*( N-1 ) / 2 + 1 20474 DO 10 I = N - 1, 1, -1 20475 CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI ) 20476 E( I ) = AP( I1+I-1 ) 20477 IF( TAUI.NE.ZERO ) THEN 20478 AP( I1+I-1 ) = ONE 20479 CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, 20480 $ 1 ) 20481 ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 ) 20482 CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 ) 20483 CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP ) 20484 AP( I1+I-1 ) = E( I ) 20485 END IF 20486 D( I+1 ) = AP( I1+I ) 20487 TAU( I ) = TAUI 20488 I1 = I1 - I 20489 10 CONTINUE 20490 D( 1 ) = AP( 1 ) 20491 ELSE 20492 II = 1 20493 DO 20 I = 1, N - 1 20494 I1I1 = II + N - I + 1 20495 CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI ) 20496 E( I ) = AP( II+1 ) 20497 IF( TAUI.NE.ZERO ) THEN 20498 AP( II+1 ) = ONE 20499 CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1, 20500 $ ZERO, TAU( I ), 1 ) 20501 ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ), 20502 $ 1 ) 20503 CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 ) 20504 CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1, 20505 $ AP( I1I1 ) ) 20506 AP( II+1 ) = E( I ) 20507 END IF 20508 D( I ) = AP( II ) 20509 TAU( I ) = TAUI 20510 II = I1I1 20511 20 CONTINUE 20512 D( N ) = AP( II ) 20513 END IF 20514 RETURN 20515 END 20516! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dstebz.f 20517 SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, 20518 $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, 20519 $ INFO ) 20520 CHARACTER ORDER, RANGE 20521 INTEGER IL, INFO, IU, M, N, NSPLIT 20522 DOUBLE PRECISION ABSTOL, VL, VU 20523 INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) 20524 DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) 20525 DOUBLE PRECISION ZERO, ONE, TWO, HALF 20526 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 20527 $ HALF = 1.0D0 / TWO ) 20528 DOUBLE PRECISION FUDGE, RELFAC 20529 PARAMETER ( FUDGE = 2.1D0, RELFAC = 2.0D0 ) 20530 LOGICAL NCNVRG, TOOFEW 20531 INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, 20532 $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX, 20533 $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL, 20534 $ NWU 20535 DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN, 20536 $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL 20537 INTEGER IDUMMA( 1 ) 20538 LOGICAL LSAME 20539 INTEGER ILAENV 20540 DOUBLE PRECISION DLAMCH 20541 EXTERNAL LSAME, ILAENV, DLAMCH 20542 EXTERNAL DLAEBZ, XERBLA 20543 INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT 20544 INFO = 0 20545 IF( LSAME( RANGE, 'A' ) ) THEN 20546 IRANGE = 1 20547 ELSE IF( LSAME( RANGE, 'V' ) ) THEN 20548 IRANGE = 2 20549 ELSE IF( LSAME( RANGE, 'I' ) ) THEN 20550 IRANGE = 3 20551 ELSE 20552 IRANGE = 0 20553 END IF 20554 IF( LSAME( ORDER, 'B' ) ) THEN 20555 IORDER = 2 20556 ELSE IF( LSAME( ORDER, 'E' ) ) THEN 20557 IORDER = 1 20558 ELSE 20559 IORDER = 0 20560 END IF 20561 IF( IRANGE.LE.0 ) THEN 20562 INFO = -1 20563 ELSE IF( IORDER.LE.0 ) THEN 20564 INFO = -2 20565 ELSE IF( N.LT.0 ) THEN 20566 INFO = -3 20567 ELSE IF( IRANGE.EQ.2 ) THEN 20568 IF( VL.GE.VU ) 20569 $ INFO = -5 20570 ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) 20571 $ THEN 20572 INFO = -6 20573 ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) 20574 $ THEN 20575 INFO = -7 20576 END IF 20577 IF( INFO.NE.0 ) THEN 20578 CALL XERBLA( 'DSTEBZ', -INFO ) 20579 RETURN 20580 END IF 20581 INFO = 0 20582 NCNVRG = .FALSE. 20583 TOOFEW = .FALSE. 20584 M = 0 20585 IF( N.EQ.0 ) 20586 $ RETURN 20587 IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N ) 20588 $ IRANGE = 1 20589 SAFEMN = DLAMCH( 'S' ) 20590 ULP = DLAMCH( 'P' ) 20591 RTOLI = ULP*RELFAC 20592 NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) 20593 IF( NB.LE.1 ) 20594 $ NB = 0 20595 IF( N.EQ.1 ) THEN 20596 NSPLIT = 1 20597 ISPLIT( 1 ) = 1 20598 IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN 20599 M = 0 20600 ELSE 20601 W( 1 ) = D( 1 ) 20602 IBLOCK( 1 ) = 1 20603 M = 1 20604 END IF 20605 RETURN 20606 END IF 20607 NSPLIT = 1 20608 WORK( N ) = ZERO 20609 PIVMIN = ONE 20610 DO 10 J = 2, N 20611 TMP1 = E( J-1 )**2 20612 IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN 20613 ISPLIT( NSPLIT ) = J - 1 20614 NSPLIT = NSPLIT + 1 20615 WORK( J-1 ) = ZERO 20616 ELSE 20617 WORK( J-1 ) = TMP1 20618 PIVMIN = MAX( PIVMIN, TMP1 ) 20619 END IF 20620 10 CONTINUE 20621 ISPLIT( NSPLIT ) = N 20622 PIVMIN = PIVMIN*SAFEMN 20623 IF( IRANGE.EQ.3 ) THEN 20624 GU = D( 1 ) 20625 GL = D( 1 ) 20626 TMP1 = ZERO 20627 DO 20 J = 1, N - 1 20628 TMP2 = SQRT( WORK( J ) ) 20629 GU = MAX( GU, D( J )+TMP1+TMP2 ) 20630 GL = MIN( GL, D( J )-TMP1-TMP2 ) 20631 TMP1 = TMP2 20632 20 CONTINUE 20633 GU = MAX( GU, D( N )+TMP1 ) 20634 GL = MIN( GL, D( N )-TMP1 ) 20635 TNORM = MAX( ABS( GL ), ABS( GU ) ) 20636 GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN 20637 GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN 20638 ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / 20639 $ LOG( TWO ) ) + 2 20640 IF( ABSTOL.LE.ZERO ) THEN 20641 ATOLI = ULP*TNORM 20642 ELSE 20643 ATOLI = ABSTOL 20644 END IF 20645 WORK( N+1 ) = GL 20646 WORK( N+2 ) = GL 20647 WORK( N+3 ) = GU 20648 WORK( N+4 ) = GU 20649 WORK( N+5 ) = GL 20650 WORK( N+6 ) = GU 20651 IWORK( 1 ) = -1 20652 IWORK( 2 ) = -1 20653 IWORK( 3 ) = N + 1 20654 IWORK( 4 ) = N + 1 20655 IWORK( 5 ) = IL - 1 20656 IWORK( 6 ) = IU 20657 CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E, 20658 $ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, 20659 $ IWORK, W, IBLOCK, IINFO ) 20660 IF( IWORK( 6 ).EQ.IU ) THEN 20661 WL = WORK( N+1 ) 20662 WLU = WORK( N+3 ) 20663 NWL = IWORK( 1 ) 20664 WU = WORK( N+4 ) 20665 WUL = WORK( N+2 ) 20666 NWU = IWORK( 4 ) 20667 ELSE 20668 WL = WORK( N+2 ) 20669 WLU = WORK( N+4 ) 20670 NWL = IWORK( 2 ) 20671 WU = WORK( N+3 ) 20672 WUL = WORK( N+1 ) 20673 NWU = IWORK( 3 ) 20674 END IF 20675 IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN 20676 INFO = 4 20677 RETURN 20678 END IF 20679 ELSE 20680 TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), 20681 $ ABS( D( N ) )+ABS( E( N-1 ) ) ) 20682 DO 30 J = 2, N - 1 20683 TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+ 20684 $ ABS( E( J ) ) ) 20685 30 CONTINUE 20686 IF( ABSTOL.LE.ZERO ) THEN 20687 ATOLI = ULP*TNORM 20688 ELSE 20689 ATOLI = ABSTOL 20690 END IF 20691 IF( IRANGE.EQ.2 ) THEN 20692 WL = VL 20693 WU = VU 20694 ELSE 20695 WL = ZERO 20696 WU = ZERO 20697 END IF 20698 END IF 20699 M = 0 20700 IEND = 0 20701 INFO = 0 20702 NWL = 0 20703 NWU = 0 20704 DO 70 JB = 1, NSPLIT 20705 IOFF = IEND 20706 IBEGIN = IOFF + 1 20707 IEND = ISPLIT( JB ) 20708 IN = IEND - IOFF 20709 IF( IN.EQ.1 ) THEN 20710 IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN ) 20711 $ NWL = NWL + 1 20712 IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN ) 20713 $ NWU = NWU + 1 20714 IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE. 20715 $ D( IBEGIN )-PIVMIN ) ) THEN 20716 M = M + 1 20717 W( M ) = D( IBEGIN ) 20718 IBLOCK( M ) = JB 20719 END IF 20720 ELSE 20721 GU = D( IBEGIN ) 20722 GL = D( IBEGIN ) 20723 TMP1 = ZERO 20724 DO 40 J = IBEGIN, IEND - 1 20725 TMP2 = ABS( E( J ) ) 20726 GU = MAX( GU, D( J )+TMP1+TMP2 ) 20727 GL = MIN( GL, D( J )-TMP1-TMP2 ) 20728 TMP1 = TMP2 20729 40 CONTINUE 20730 GU = MAX( GU, D( IEND )+TMP1 ) 20731 GL = MIN( GL, D( IEND )-TMP1 ) 20732 BNORM = MAX( ABS( GL ), ABS( GU ) ) 20733 GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN 20734 GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN 20735 IF( ABSTOL.LE.ZERO ) THEN 20736 ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) ) 20737 ELSE 20738 ATOLI = ABSTOL 20739 END IF 20740 IF( IRANGE.GT.1 ) THEN 20741 IF( GU.LT.WL ) THEN 20742 NWL = NWL + IN 20743 NWU = NWU + IN 20744 GO TO 70 20745 END IF 20746 GL = MAX( GL, WL ) 20747 GU = MIN( GU, WU ) 20748 IF( GL.GE.GU ) 20749 $ GO TO 70 20750 END IF 20751 WORK( N+1 ) = GL 20752 WORK( N+IN+1 ) = GU 20753 CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, 20754 $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), 20755 $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, 20756 $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) 20757 NWL = NWL + IWORK( 1 ) 20758 NWU = NWU + IWORK( IN+1 ) 20759 IWOFF = M - IWORK( 1 ) 20760 ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / 20761 $ LOG( TWO ) ) + 2 20762 CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, 20763 $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), 20764 $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, 20765 $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) 20766 DO 60 J = 1, IOUT 20767 TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) 20768 IF( J.GT.IOUT-IINFO ) THEN 20769 NCNVRG = .TRUE. 20770 IB = -JB 20771 ELSE 20772 IB = JB 20773 END IF 20774 DO 50 JE = IWORK( J ) + 1 + IWOFF, 20775 $ IWORK( J+IN ) + IWOFF 20776 W( JE ) = TMP1 20777 IBLOCK( JE ) = IB 20778 50 CONTINUE 20779 60 CONTINUE 20780 M = M + IM 20781 END IF 20782 70 CONTINUE 20783 IF( IRANGE.EQ.3 ) THEN 20784 IM = 0 20785 IDISCL = IL - 1 - NWL 20786 IDISCU = NWU - IU 20787 IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN 20788 DO 80 JE = 1, M 20789 IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN 20790 IDISCL = IDISCL - 1 20791 ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN 20792 IDISCU = IDISCU - 1 20793 ELSE 20794 IM = IM + 1 20795 W( IM ) = W( JE ) 20796 IBLOCK( IM ) = IBLOCK( JE ) 20797 END IF 20798 80 CONTINUE 20799 M = IM 20800 END IF 20801 IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN 20802 IF( IDISCL.GT.0 ) THEN 20803 WKILL = WU 20804 DO 100 JDISC = 1, IDISCL 20805 IW = 0 20806 DO 90 JE = 1, M 20807 IF( IBLOCK( JE ).NE.0 .AND. 20808 $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN 20809 IW = JE 20810 WKILL = W( JE ) 20811 END IF 20812 90 CONTINUE 20813 IBLOCK( IW ) = 0 20814 100 CONTINUE 20815 END IF 20816 IF( IDISCU.GT.0 ) THEN 20817 WKILL = WL 20818 DO 120 JDISC = 1, IDISCU 20819 IW = 0 20820 DO 110 JE = 1, M 20821 IF( IBLOCK( JE ).NE.0 .AND. 20822 $ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN 20823 IW = JE 20824 WKILL = W( JE ) 20825 END IF 20826 110 CONTINUE 20827 IBLOCK( IW ) = 0 20828 120 CONTINUE 20829 END IF 20830 IM = 0 20831 DO 130 JE = 1, M 20832 IF( IBLOCK( JE ).NE.0 ) THEN 20833 IM = IM + 1 20834 W( IM ) = W( JE ) 20835 IBLOCK( IM ) = IBLOCK( JE ) 20836 END IF 20837 130 CONTINUE 20838 M = IM 20839 END IF 20840 IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN 20841 TOOFEW = .TRUE. 20842 END IF 20843 END IF 20844 IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN 20845 DO 150 JE = 1, M - 1 20846 IE = 0 20847 TMP1 = W( JE ) 20848 DO 140 J = JE + 1, M 20849 IF( W( J ).LT.TMP1 ) THEN 20850 IE = J 20851 TMP1 = W( J ) 20852 END IF 20853 140 CONTINUE 20854 IF( IE.NE.0 ) THEN 20855 ITMP1 = IBLOCK( IE ) 20856 W( IE ) = W( JE ) 20857 IBLOCK( IE ) = IBLOCK( JE ) 20858 W( JE ) = TMP1 20859 IBLOCK( JE ) = ITMP1 20860 END IF 20861 150 CONTINUE 20862 END IF 20863 INFO = 0 20864 IF( NCNVRG ) 20865 $ INFO = INFO + 1 20866 IF( TOOFEW ) 20867 $ INFO = INFO + 2 20868 RETURN 20869 END 20870! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dstedc.f 20871 SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, 20872 $ LIWORK, INFO ) 20873 CHARACTER COMPZ 20874 INTEGER INFO, LDZ, LIWORK, LWORK, N 20875 INTEGER IWORK( * ) 20876 DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) 20877 DOUBLE PRECISION ZERO, ONE, TWO 20878 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) 20879 LOGICAL LQUERY 20880 INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, 20881 $ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW 20882 DOUBLE PRECISION EPS, ORGNRM, P, TINY 20883 LOGICAL LSAME 20884 INTEGER ILAENV 20885 DOUBLE PRECISION DLAMCH, DLANST 20886 EXTERNAL LSAME, ILAENV, DLAMCH, DLANST 20887 EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT, 20888 $ DSTEQR, DSTERF, DSWAP, XERBLA 20889 INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT 20890 INFO = 0 20891 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 20892 IF( LSAME( COMPZ, 'N' ) ) THEN 20893 ICOMPZ = 0 20894 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN 20895 ICOMPZ = 1 20896 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN 20897 ICOMPZ = 2 20898 ELSE 20899 ICOMPZ = -1 20900 END IF 20901 IF( ICOMPZ.LT.0 ) THEN 20902 INFO = -1 20903 ELSE IF( N.LT.0 ) THEN 20904 INFO = -2 20905 ELSE IF( ( LDZ.LT.1 ) .OR. 20906 $ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN 20907 INFO = -6 20908 END IF 20909 IF( INFO.EQ.0 ) THEN 20910 SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 ) 20911 IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN 20912 LIWMIN = 1 20913 LWMIN = 1 20914 ELSE IF( N.LE.SMLSIZ ) THEN 20915 LIWMIN = 1 20916 LWMIN = 2*( N - 1 ) 20917 ELSE 20918 LGN = INT( LOG( DBLE( N ) )/LOG( TWO ) ) 20919 IF( 2**LGN.LT.N ) 20920 $ LGN = LGN + 1 20921 IF( 2**LGN.LT.N ) 20922 $ LGN = LGN + 1 20923 IF( ICOMPZ.EQ.1 ) THEN 20924 LWMIN = 1 + 3*N + 2*N*LGN + 4*N**2 20925 LIWMIN = 6 + 6*N + 5*N*LGN 20926 ELSE IF( ICOMPZ.EQ.2 ) THEN 20927 LWMIN = 1 + 4*N + N**2 20928 LIWMIN = 3 + 5*N 20929 END IF 20930 END IF 20931 WORK( 1 ) = LWMIN 20932 IWORK( 1 ) = LIWMIN 20933 IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN 20934 INFO = -8 20935 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN 20936 INFO = -10 20937 END IF 20938 END IF 20939 IF( INFO.NE.0 ) THEN 20940 CALL XERBLA( 'DSTEDC', -INFO ) 20941 RETURN 20942 ELSE IF (LQUERY) THEN 20943 RETURN 20944 END IF 20945 IF( N.EQ.0 ) 20946 $ RETURN 20947 IF( N.EQ.1 ) THEN 20948 IF( ICOMPZ.NE.0 ) 20949 $ Z( 1, 1 ) = ONE 20950 RETURN 20951 END IF 20952 IF( ICOMPZ.EQ.0 ) THEN 20953 CALL DSTERF( N, D, E, INFO ) 20954 GO TO 50 20955 END IF 20956 IF( N.LE.SMLSIZ ) THEN 20957 CALL DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) 20958 ELSE 20959 IF( ICOMPZ.EQ.1 ) THEN 20960 STOREZ = 1 + N*N 20961 ELSE 20962 STOREZ = 1 20963 END IF 20964 IF( ICOMPZ.EQ.2 ) THEN 20965 CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) 20966 END IF 20967 ORGNRM = DLANST( 'M', N, D, E ) 20968 IF( ORGNRM.EQ.ZERO ) 20969 $ GO TO 50 20970 EPS = DLAMCH( 'Epsilon' ) 20971 START = 1 20972 10 CONTINUE 20973 IF( START.LE.N ) THEN 20974 FINISH = START 20975 20 CONTINUE 20976 IF( FINISH.LT.N ) THEN 20977 TINY = EPS*SQRT( ABS( D( FINISH ) ) )* 20978 $ SQRT( ABS( D( FINISH+1 ) ) ) 20979 IF( ABS( E( FINISH ) ).GT.TINY ) THEN 20980 FINISH = FINISH + 1 20981 GO TO 20 20982 END IF 20983 END IF 20984 M = FINISH - START + 1 20985 IF( M.EQ.1 ) THEN 20986 START = FINISH + 1 20987 GO TO 10 20988 END IF 20989 IF( M.GT.SMLSIZ ) THEN 20990 ORGNRM = DLANST( 'M', M, D( START ), E( START ) ) 20991 CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M, 20992 $ INFO ) 20993 CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ), 20994 $ M-1, INFO ) 20995 IF( ICOMPZ.EQ.1 ) THEN 20996 STRTRW = 1 20997 ELSE 20998 STRTRW = START 20999 END IF 21000 CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ), 21001 $ Z( STRTRW, START ), LDZ, WORK( 1 ), N, 21002 $ WORK( STOREZ ), IWORK, INFO ) 21003 IF( INFO.NE.0 ) THEN 21004 INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + 21005 $ MOD( INFO, ( M+1 ) ) + START - 1 21006 GO TO 50 21007 END IF 21008 CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M, 21009 $ INFO ) 21010 ELSE 21011 IF( ICOMPZ.EQ.1 ) THEN 21012 CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M, 21013 $ WORK( M*M+1 ), INFO ) 21014 CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ, 21015 $ WORK( STOREZ ), N ) 21016 CALL DGEMM( 'N', 'N', N, M, M, ONE, 21017 $ WORK( STOREZ ), N, WORK, M, ZERO, 21018 $ Z( 1, START ), LDZ ) 21019 ELSE IF( ICOMPZ.EQ.2 ) THEN 21020 CALL DSTEQR( 'I', M, D( START ), E( START ), 21021 $ Z( START, START ), LDZ, WORK, INFO ) 21022 ELSE 21023 CALL DSTERF( M, D( START ), E( START ), INFO ) 21024 END IF 21025 IF( INFO.NE.0 ) THEN 21026 INFO = START*( N+1 ) + FINISH 21027 GO TO 50 21028 END IF 21029 END IF 21030 START = FINISH + 1 21031 GO TO 10 21032 END IF 21033 IF( ICOMPZ.EQ.0 ) THEN 21034 CALL DLASRT( 'I', N, D, INFO ) 21035 ELSE 21036 DO 40 II = 2, N 21037 I = II - 1 21038 K = I 21039 P = D( I ) 21040 DO 30 J = II, N 21041 IF( D( J ).LT.P ) THEN 21042 K = J 21043 P = D( J ) 21044 END IF 21045 30 CONTINUE 21046 IF( K.NE.I ) THEN 21047 D( K ) = D( I ) 21048 D( I ) = P 21049 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) 21050 END IF 21051 40 CONTINUE 21052 END IF 21053 END IF 21054 50 CONTINUE 21055 WORK( 1 ) = LWMIN 21056 IWORK( 1 ) = LIWMIN 21057 RETURN 21058 END 21059! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dstein.f 21060 SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, 21061 $ IWORK, IFAIL, INFO ) 21062 INTEGER INFO, LDZ, M, N 21063 INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), 21064 $ IWORK( * ) 21065 DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) 21066 DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1 21067 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, 21068 $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 ) 21069 INTEGER MAXITS, EXTRA 21070 PARAMETER ( MAXITS = 5, EXTRA = 2 ) 21071 INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, 21072 $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, 21073 $ JBLK, JMAX, NBLK, NRMCHK 21074 DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, 21075 $ SCL, SEP, TOL, XJ, XJM, ZTR 21076 INTEGER ISEED( 4 ) 21077 INTEGER IDAMAX 21078 DOUBLE PRECISION DDOT, DLAMCH, DNRM2 21079 EXTERNAL IDAMAX, DDOT, DLAMCH, DNRM2 21080 EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, 21081 $ XERBLA 21082 INTRINSIC ABS, MAX, SQRT 21083 INFO = 0 21084 DO 10 I = 1, M 21085 IFAIL( I ) = 0 21086 10 CONTINUE 21087 IF( N.LT.0 ) THEN 21088 INFO = -1 21089 ELSE IF( M.LT.0 .OR. M.GT.N ) THEN 21090 INFO = -4 21091 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN 21092 INFO = -9 21093 ELSE 21094 DO 20 J = 2, M 21095 IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN 21096 INFO = -6 21097 GO TO 30 21098 END IF 21099 IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) 21100 $ THEN 21101 INFO = -5 21102 GO TO 30 21103 END IF 21104 20 CONTINUE 21105 30 CONTINUE 21106 END IF 21107 IF( INFO.NE.0 ) THEN 21108 CALL XERBLA( 'DSTEIN', -INFO ) 21109 RETURN 21110 END IF 21111 IF( N.EQ.0 .OR. M.EQ.0 ) THEN 21112 RETURN 21113 ELSE IF( N.EQ.1 ) THEN 21114 Z( 1, 1 ) = ONE 21115 RETURN 21116 END IF 21117 EPS = DLAMCH( 'Precision' ) 21118 DO 40 I = 1, 4 21119 ISEED( I ) = 1 21120 40 CONTINUE 21121 INDRV1 = 0 21122 INDRV2 = INDRV1 + N 21123 INDRV3 = INDRV2 + N 21124 INDRV4 = INDRV3 + N 21125 INDRV5 = INDRV4 + N 21126 J1 = 1 21127 DO 160 NBLK = 1, IBLOCK( M ) 21128 IF( NBLK.EQ.1 ) THEN 21129 B1 = 1 21130 ELSE 21131 B1 = ISPLIT( NBLK-1 ) + 1 21132 END IF 21133 BN = ISPLIT( NBLK ) 21134 BLKSIZ = BN - B1 + 1 21135 IF( BLKSIZ.EQ.1 ) 21136 $ GO TO 60 21137 GPIND = J1 21138 ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) ) 21139 ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) ) 21140 DO 50 I = B1 + 1, BN - 1 21141 ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ 21142 $ ABS( E( I ) ) ) 21143 50 CONTINUE 21144 ORTOL = ODM3*ONENRM 21145 DTPCRT = SQRT( ODM1 / BLKSIZ ) 21146 60 CONTINUE 21147 JBLK = 0 21148 DO 150 J = J1, M 21149 IF( IBLOCK( J ).NE.NBLK ) THEN 21150 J1 = J 21151 GO TO 160 21152 END IF 21153 JBLK = JBLK + 1 21154 XJ = W( J ) 21155 IF( BLKSIZ.EQ.1 ) THEN 21156 WORK( INDRV1+1 ) = ONE 21157 GO TO 120 21158 END IF 21159 IF( JBLK.GT.1 ) THEN 21160 EPS1 = ABS( EPS*XJ ) 21161 PERTOL = TEN*EPS1 21162 SEP = XJ - XJM 21163 IF( SEP.LT.PERTOL ) 21164 $ XJ = XJM + PERTOL 21165 END IF 21166 ITS = 0 21167 NRMCHK = 0 21168 CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) ) 21169 CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 ) 21170 CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 ) 21171 CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 ) 21172 TOL = ZERO 21173 CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), 21174 $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, 21175 $ IINFO ) 21176 70 CONTINUE 21177 ITS = ITS + 1 21178 IF( ITS.GT.MAXITS ) 21179 $ GO TO 100 21180 JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) 21181 SCL = BLKSIZ*ONENRM*MAX( EPS, 21182 $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / 21183 $ ABS( WORK( INDRV1+JMAX ) ) 21184 CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) 21185 CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), 21186 $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, 21187 $ WORK( INDRV1+1 ), TOL, IINFO ) 21188 IF( JBLK.EQ.1 ) 21189 $ GO TO 90 21190 IF( ABS( XJ-XJM ).GT.ORTOL ) 21191 $ GPIND = J 21192 IF( GPIND.NE.J ) THEN 21193 DO 80 I = GPIND, J - 1 21194 ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ), 21195 $ 1 ) 21196 CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1, 21197 $ WORK( INDRV1+1 ), 1 ) 21198 80 CONTINUE 21199 END IF 21200 90 CONTINUE 21201 JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) 21202 NRM = ABS( WORK( INDRV1+JMAX ) ) 21203 IF( NRM.LT.DTPCRT ) 21204 $ GO TO 70 21205 NRMCHK = NRMCHK + 1 21206 IF( NRMCHK.LT.EXTRA+1 ) 21207 $ GO TO 70 21208 GO TO 110 21209 100 CONTINUE 21210 INFO = INFO + 1 21211 IFAIL( INFO ) = J 21212 110 CONTINUE 21213 SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 ) 21214 JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) 21215 IF( WORK( INDRV1+JMAX ).LT.ZERO ) 21216 $ SCL = -SCL 21217 CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) 21218 120 CONTINUE 21219 DO 130 I = 1, N 21220 Z( I, J ) = ZERO 21221 130 CONTINUE 21222 DO 140 I = 1, BLKSIZ 21223 Z( B1+I-1, J ) = WORK( INDRV1+I ) 21224 140 CONTINUE 21225 XJM = XJ 21226 150 CONTINUE 21227 160 CONTINUE 21228 RETURN 21229 END 21230! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dstemr.f 21231 SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, 21232 $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, 21233 $ IWORK, LIWORK, INFO ) 21234 CHARACTER JOBZ, RANGE 21235 LOGICAL TRYRAC 21236 INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N 21237 DOUBLE PRECISION VL, VU 21238 INTEGER ISUPPZ( * ), IWORK( * ) 21239 DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) 21240 DOUBLE PRECISION Z( LDZ, * ) 21241 DOUBLE PRECISION ZERO, ONE, FOUR, MINRGP 21242 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, 21243 $ FOUR = 4.0D0, 21244 $ MINRGP = 1.0D-3 ) 21245 LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY 21246 INTEGER I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW, 21247 $ IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD, 21248 $ INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP, 21249 $ ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT, 21250 $ NZCMIN, OFFSET, WBEGIN, WEND 21251 DOUBLE PRECISION BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN, 21252 $ RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN, 21253 $ THRESH, TMP, TNRM, WL, WU 21254 LOGICAL LSAME 21255 DOUBLE PRECISION DLAMCH, DLANST 21256 EXTERNAL LSAME, DLAMCH, DLANST 21257 EXTERNAL DCOPY, DLAE2, DLAEV2, DLARRC, DLARRE, DLARRJ, 21258 $ DLARRR, DLARRV, DLASRT, DSCAL, DSWAP, XERBLA 21259 INTRINSIC MAX, MIN, SQRT 21260 WANTZ = LSAME( JOBZ, 'V' ) 21261 ALLEIG = LSAME( RANGE, 'A' ) 21262 VALEIG = LSAME( RANGE, 'V' ) 21263 INDEIG = LSAME( RANGE, 'I' ) 21264 LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) ) 21265 ZQUERY = ( NZC.EQ.-1 ) 21266 IF( WANTZ ) THEN 21267 LWMIN = 18*N 21268 LIWMIN = 10*N 21269 ELSE 21270 LWMIN = 12*N 21271 LIWMIN = 8*N 21272 ENDIF 21273 WL = ZERO 21274 WU = ZERO 21275 IIL = 0 21276 IIU = 0 21277 NSPLIT = 0 21278 IF( VALEIG ) THEN 21279 WL = VL 21280 WU = VU 21281 ELSEIF( INDEIG ) THEN 21282 IIL = IL 21283 IIU = IU 21284 ENDIF 21285 INFO = 0 21286 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 21287 INFO = -1 21288 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN 21289 INFO = -2 21290 ELSE IF( N.LT.0 ) THEN 21291 INFO = -3 21292 ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN 21293 INFO = -7 21294 ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN 21295 INFO = -8 21296 ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN 21297 INFO = -9 21298 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 21299 INFO = -13 21300 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 21301 INFO = -17 21302 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 21303 INFO = -19 21304 END IF 21305 SAFMIN = DLAMCH( 'Safe minimum' ) 21306 EPS = DLAMCH( 'Precision' ) 21307 SMLNUM = SAFMIN / EPS 21308 BIGNUM = ONE / SMLNUM 21309 RMIN = SQRT( SMLNUM ) 21310 RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) 21311 IF( INFO.EQ.0 ) THEN 21312 WORK( 1 ) = LWMIN 21313 IWORK( 1 ) = LIWMIN 21314 IF( WANTZ .AND. ALLEIG ) THEN 21315 NZCMIN = N 21316 ELSE IF( WANTZ .AND. VALEIG ) THEN 21317 CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN, 21318 $ NZCMIN, ITMP, ITMP2, INFO ) 21319 ELSE IF( WANTZ .AND. INDEIG ) THEN 21320 NZCMIN = IIU-IIL+1 21321 ELSE 21322 NZCMIN = 0 21323 ENDIF 21324 IF( ZQUERY .AND. INFO.EQ.0 ) THEN 21325 Z( 1,1 ) = NZCMIN 21326 ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN 21327 INFO = -14 21328 END IF 21329 END IF 21330 IF( INFO.NE.0 ) THEN 21331 CALL XERBLA( 'DSTEMR', -INFO ) 21332 RETURN 21333 ELSE IF( LQUERY .OR. ZQUERY ) THEN 21334 RETURN 21335 END IF 21336 M = 0 21337 IF( N.EQ.0 ) 21338 $ RETURN 21339 IF( N.EQ.1 ) THEN 21340 IF( ALLEIG .OR. INDEIG ) THEN 21341 M = 1 21342 W( 1 ) = D( 1 ) 21343 ELSE 21344 IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN 21345 M = 1 21346 W( 1 ) = D( 1 ) 21347 END IF 21348 END IF 21349 IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN 21350 Z( 1, 1 ) = ONE 21351 ISUPPZ(1) = 1 21352 ISUPPZ(2) = 1 21353 END IF 21354 RETURN 21355 END IF 21356 IF( N.EQ.2 ) THEN 21357 IF( .NOT.WANTZ ) THEN 21358 CALL DLAE2( D(1), E(1), D(2), R1, R2 ) 21359 ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN 21360 CALL DLAEV2( D(1), E(1), D(2), R1, R2, CS, SN ) 21361 END IF 21362 IF( ALLEIG.OR. 21363 $ (VALEIG.AND.(R2.GT.WL).AND. 21364 $ (R2.LE.WU)).OR. 21365 $ (INDEIG.AND.(IIL.EQ.1)) ) THEN 21366 M = M+1 21367 W( M ) = R2 21368 IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN 21369 Z( 1, M ) = -SN 21370 Z( 2, M ) = CS 21371 IF (SN.NE.ZERO) THEN 21372 IF (CS.NE.ZERO) THEN 21373 ISUPPZ(2*M-1) = 1 21374 ISUPPZ(2*M) = 2 21375 ELSE 21376 ISUPPZ(2*M-1) = 1 21377 ISUPPZ(2*M) = 1 21378 END IF 21379 ELSE 21380 ISUPPZ(2*M-1) = 2 21381 ISUPPZ(2*M) = 2 21382 END IF 21383 ENDIF 21384 ENDIF 21385 IF( ALLEIG.OR. 21386 $ (VALEIG.AND.(R1.GT.WL).AND. 21387 $ (R1.LE.WU)).OR. 21388 $ (INDEIG.AND.(IIU.EQ.2)) ) THEN 21389 M = M+1 21390 W( M ) = R1 21391 IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN 21392 Z( 1, M ) = CS 21393 Z( 2, M ) = SN 21394 IF (SN.NE.ZERO) THEN 21395 IF (CS.NE.ZERO) THEN 21396 ISUPPZ(2*M-1) = 1 21397 ISUPPZ(2*M) = 2 21398 ELSE 21399 ISUPPZ(2*M-1) = 1 21400 ISUPPZ(2*M) = 1 21401 END IF 21402 ELSE 21403 ISUPPZ(2*M-1) = 2 21404 ISUPPZ(2*M) = 2 21405 END IF 21406 ENDIF 21407 ENDIF 21408 ELSE 21409 INDGRS = 1 21410 INDERR = 2*N + 1 21411 INDGP = 3*N + 1 21412 INDD = 4*N + 1 21413 INDE2 = 5*N + 1 21414 INDWRK = 6*N + 1 21415 IINSPL = 1 21416 IINDBL = N + 1 21417 IINDW = 2*N + 1 21418 IINDWK = 3*N + 1 21419 SCALE = ONE 21420 TNRM = DLANST( 'M', N, D, E ) 21421 IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN 21422 SCALE = RMIN / TNRM 21423 ELSE IF( TNRM.GT.RMAX ) THEN 21424 SCALE = RMAX / TNRM 21425 END IF 21426 IF( SCALE.NE.ONE ) THEN 21427 CALL DSCAL( N, SCALE, D, 1 ) 21428 CALL DSCAL( N-1, SCALE, E, 1 ) 21429 TNRM = TNRM*SCALE 21430 IF( VALEIG ) THEN 21431 WL = WL*SCALE 21432 WU = WU*SCALE 21433 ENDIF 21434 END IF 21435 IF( TRYRAC ) THEN 21436 CALL DLARRR( N, D, E, IINFO ) 21437 ELSE 21438 IINFO = -1 21439 ENDIF 21440 IF (IINFO.EQ.0) THEN 21441 THRESH = EPS 21442 ELSE 21443 THRESH = -EPS 21444 TRYRAC = .FALSE. 21445 ENDIF 21446 IF( TRYRAC ) THEN 21447 CALL DCOPY(N,D,1,WORK(INDD),1) 21448 ENDIF 21449 DO 5 J = 1, N-1 21450 WORK( INDE2+J-1 ) = E(J)**2 21451 5 CONTINUE 21452 IF( .NOT.WANTZ ) THEN 21453 RTOL1 = FOUR * EPS 21454 RTOL2 = FOUR * EPS 21455 ELSE 21456 RTOL1 = SQRT(EPS) 21457 RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS ) 21458 ENDIF 21459 CALL DLARRE( RANGE, N, WL, WU, IIL, IIU, D, E, 21460 $ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT, 21461 $ IWORK( IINSPL ), M, W, WORK( INDERR ), 21462 $ WORK( INDGP ), IWORK( IINDBL ), 21463 $ IWORK( IINDW ), WORK( INDGRS ), PIVMIN, 21464 $ WORK( INDWRK ), IWORK( IINDWK ), IINFO ) 21465 IF( IINFO.NE.0 ) THEN 21466 INFO = 10 + ABS( IINFO ) 21467 RETURN 21468 END IF 21469 IF( WANTZ ) THEN 21470 CALL DLARRV( N, WL, WU, D, E, 21471 $ PIVMIN, IWORK( IINSPL ), M, 21472 $ 1, M, MINRGP, RTOL1, RTOL2, 21473 $ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ), 21474 $ IWORK( IINDW ), WORK( INDGRS ), Z, LDZ, 21475 $ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO ) 21476 IF( IINFO.NE.0 ) THEN 21477 INFO = 20 + ABS( IINFO ) 21478 RETURN 21479 END IF 21480 ELSE 21481 DO 20 J = 1, M 21482 ITMP = IWORK( IINDBL+J-1 ) 21483 W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) ) 21484 20 CONTINUE 21485 END IF 21486 IF ( TRYRAC ) THEN 21487 IBEGIN = 1 21488 WBEGIN = 1 21489 DO 39 JBLK = 1, IWORK( IINDBL+M-1 ) 21490 IEND = IWORK( IINSPL+JBLK-1 ) 21491 IN = IEND - IBEGIN + 1 21492 WEND = WBEGIN - 1 21493 36 CONTINUE 21494 IF( WEND.LT.M ) THEN 21495 IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN 21496 WEND = WEND + 1 21497 GO TO 36 21498 END IF 21499 END IF 21500 IF( WEND.LT.WBEGIN ) THEN 21501 IBEGIN = IEND + 1 21502 GO TO 39 21503 END IF 21504 OFFSET = IWORK(IINDW+WBEGIN-1)-1 21505 IFIRST = IWORK(IINDW+WBEGIN-1) 21506 ILAST = IWORK(IINDW+WEND-1) 21507 RTOL2 = FOUR * EPS 21508 CALL DLARRJ( IN, 21509 $ WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1), 21510 $ IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN), 21511 $ WORK( INDERR+WBEGIN-1 ), 21512 $ WORK( INDWRK ), IWORK( IINDWK ), PIVMIN, 21513 $ TNRM, IINFO ) 21514 IBEGIN = IEND + 1 21515 WBEGIN = WEND + 1 21516 39 CONTINUE 21517 ENDIF 21518 IF( SCALE.NE.ONE ) THEN 21519 CALL DSCAL( M, ONE / SCALE, W, 1 ) 21520 END IF 21521 END IF 21522 IF( NSPLIT.GT.1 .OR. N.EQ.2 ) THEN 21523 IF( .NOT. WANTZ ) THEN 21524 CALL DLASRT( 'I', M, W, IINFO ) 21525 IF( IINFO.NE.0 ) THEN 21526 INFO = 3 21527 RETURN 21528 END IF 21529 ELSE 21530 DO 60 J = 1, M - 1 21531 I = 0 21532 TMP = W( J ) 21533 DO 50 JJ = J + 1, M 21534 IF( W( JJ ).LT.TMP ) THEN 21535 I = JJ 21536 TMP = W( JJ ) 21537 END IF 21538 50 CONTINUE 21539 IF( I.NE.0 ) THEN 21540 W( I ) = W( J ) 21541 W( J ) = TMP 21542 IF( WANTZ ) THEN 21543 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) 21544 ITMP = ISUPPZ( 2*I-1 ) 21545 ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 ) 21546 ISUPPZ( 2*J-1 ) = ITMP 21547 ITMP = ISUPPZ( 2*I ) 21548 ISUPPZ( 2*I ) = ISUPPZ( 2*J ) 21549 ISUPPZ( 2*J ) = ITMP 21550 END IF 21551 END IF 21552 60 CONTINUE 21553 END IF 21554 ENDIF 21555 WORK( 1 ) = LWMIN 21556 IWORK( 1 ) = LIWMIN 21557 RETURN 21558 END 21559! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsteqr.f 21560 SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) 21561 CHARACTER COMPZ 21562 INTEGER INFO, LDZ, N 21563 DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) 21564 DOUBLE PRECISION ZERO, ONE, TWO, THREE 21565 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 21566 $ THREE = 3.0D0 ) 21567 INTEGER MAXIT 21568 PARAMETER ( MAXIT = 30 ) 21569 INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, 21570 $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, 21571 $ NM1, NMAXIT 21572 DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, 21573 $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST 21574 LOGICAL LSAME 21575 DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 21576 EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 21577 EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, 21578 $ DLASRT, DSWAP, XERBLA 21579 INTRINSIC ABS, MAX, SIGN, SQRT 21580 INFO = 0 21581 IF( LSAME( COMPZ, 'N' ) ) THEN 21582 ICOMPZ = 0 21583 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN 21584 ICOMPZ = 1 21585 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN 21586 ICOMPZ = 2 21587 ELSE 21588 ICOMPZ = -1 21589 END IF 21590 IF( ICOMPZ.LT.0 ) THEN 21591 INFO = -1 21592 ELSE IF( N.LT.0 ) THEN 21593 INFO = -2 21594 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, 21595 $ N ) ) ) THEN 21596 INFO = -6 21597 END IF 21598 IF( INFO.NE.0 ) THEN 21599 CALL XERBLA( 'DSTEQR', -INFO ) 21600 RETURN 21601 END IF 21602 IF( N.EQ.0 ) 21603 $ RETURN 21604 IF( N.EQ.1 ) THEN 21605 IF( ICOMPZ.EQ.2 ) 21606 $ Z( 1, 1 ) = ONE 21607 RETURN 21608 END IF 21609 EPS = DLAMCH( 'E' ) 21610 EPS2 = EPS**2 21611 SAFMIN = DLAMCH( 'S' ) 21612 SAFMAX = ONE / SAFMIN 21613 SSFMAX = SQRT( SAFMAX ) / THREE 21614 SSFMIN = SQRT( SAFMIN ) / EPS2 21615 IF( ICOMPZ.EQ.2 ) 21616 $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) 21617 NMAXIT = N*MAXIT 21618 JTOT = 0 21619 L1 = 1 21620 NM1 = N - 1 21621 10 CONTINUE 21622 IF( L1.GT.N ) 21623 $ GO TO 160 21624 IF( L1.GT.1 ) 21625 $ E( L1-1 ) = ZERO 21626 IF( L1.LE.NM1 ) THEN 21627 DO 20 M = L1, NM1 21628 TST = ABS( E( M ) ) 21629 IF( TST.EQ.ZERO ) 21630 $ GO TO 30 21631 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ 21632 $ 1 ) ) ) )*EPS ) THEN 21633 E( M ) = ZERO 21634 GO TO 30 21635 END IF 21636 20 CONTINUE 21637 END IF 21638 M = N 21639 30 CONTINUE 21640 L = L1 21641 LSV = L 21642 LEND = M 21643 LENDSV = LEND 21644 L1 = M + 1 21645 IF( LEND.EQ.L ) 21646 $ GO TO 10 21647 ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) 21648 ISCALE = 0 21649 IF( ANORM.EQ.ZERO ) 21650 $ GO TO 10 21651 IF( ANORM.GT.SSFMAX ) THEN 21652 ISCALE = 1 21653 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, 21654 $ INFO ) 21655 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, 21656 $ INFO ) 21657 ELSE IF( ANORM.LT.SSFMIN ) THEN 21658 ISCALE = 2 21659 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, 21660 $ INFO ) 21661 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, 21662 $ INFO ) 21663 END IF 21664 IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN 21665 LEND = LSV 21666 L = LENDSV 21667 END IF 21668 IF( LEND.GT.L ) THEN 21669 40 CONTINUE 21670 IF( L.NE.LEND ) THEN 21671 LENDM1 = LEND - 1 21672 DO 50 M = L, LENDM1 21673 TST = ABS( E( M ) )**2 21674 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ 21675 $ SAFMIN )GO TO 60 21676 50 CONTINUE 21677 END IF 21678 M = LEND 21679 60 CONTINUE 21680 IF( M.LT.LEND ) 21681 $ E( M ) = ZERO 21682 P = D( L ) 21683 IF( M.EQ.L ) 21684 $ GO TO 80 21685 IF( M.EQ.L+1 ) THEN 21686 IF( ICOMPZ.GT.0 ) THEN 21687 CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) 21688 WORK( L ) = C 21689 WORK( N-1+L ) = S 21690 CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), 21691 $ WORK( N-1+L ), Z( 1, L ), LDZ ) 21692 ELSE 21693 CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) 21694 END IF 21695 D( L ) = RT1 21696 D( L+1 ) = RT2 21697 E( L ) = ZERO 21698 L = L + 2 21699 IF( L.LE.LEND ) 21700 $ GO TO 40 21701 GO TO 140 21702 END IF 21703 IF( JTOT.EQ.NMAXIT ) 21704 $ GO TO 140 21705 JTOT = JTOT + 1 21706 G = ( D( L+1 )-P ) / ( TWO*E( L ) ) 21707 R = DLAPY2( G, ONE ) 21708 G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) 21709 S = ONE 21710 C = ONE 21711 P = ZERO 21712 MM1 = M - 1 21713 DO 70 I = MM1, L, -1 21714 F = S*E( I ) 21715 B = C*E( I ) 21716 CALL DLARTG( G, F, C, S, R ) 21717 IF( I.NE.M-1 ) 21718 $ E( I+1 ) = R 21719 G = D( I+1 ) - P 21720 R = ( D( I )-G )*S + TWO*C*B 21721 P = S*R 21722 D( I+1 ) = G + P 21723 G = C*R - B 21724 IF( ICOMPZ.GT.0 ) THEN 21725 WORK( I ) = C 21726 WORK( N-1+I ) = -S 21727 END IF 21728 70 CONTINUE 21729 IF( ICOMPZ.GT.0 ) THEN 21730 MM = M - L + 1 21731 CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), 21732 $ Z( 1, L ), LDZ ) 21733 END IF 21734 D( L ) = D( L ) - P 21735 E( L ) = G 21736 GO TO 40 21737 80 CONTINUE 21738 D( L ) = P 21739 L = L + 1 21740 IF( L.LE.LEND ) 21741 $ GO TO 40 21742 GO TO 140 21743 ELSE 21744 90 CONTINUE 21745 IF( L.NE.LEND ) THEN 21746 LENDP1 = LEND + 1 21747 DO 100 M = L, LENDP1, -1 21748 TST = ABS( E( M-1 ) )**2 21749 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ 21750 $ SAFMIN )GO TO 110 21751 100 CONTINUE 21752 END IF 21753 M = LEND 21754 110 CONTINUE 21755 IF( M.GT.LEND ) 21756 $ E( M-1 ) = ZERO 21757 P = D( L ) 21758 IF( M.EQ.L ) 21759 $ GO TO 130 21760 IF( M.EQ.L-1 ) THEN 21761 IF( ICOMPZ.GT.0 ) THEN 21762 CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) 21763 WORK( M ) = C 21764 WORK( N-1+M ) = S 21765 CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), 21766 $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) 21767 ELSE 21768 CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) 21769 END IF 21770 D( L-1 ) = RT1 21771 D( L ) = RT2 21772 E( L-1 ) = ZERO 21773 L = L - 2 21774 IF( L.GE.LEND ) 21775 $ GO TO 90 21776 GO TO 140 21777 END IF 21778 IF( JTOT.EQ.NMAXIT ) 21779 $ GO TO 140 21780 JTOT = JTOT + 1 21781 G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) 21782 R = DLAPY2( G, ONE ) 21783 G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) 21784 S = ONE 21785 C = ONE 21786 P = ZERO 21787 LM1 = L - 1 21788 DO 120 I = M, LM1 21789 F = S*E( I ) 21790 B = C*E( I ) 21791 CALL DLARTG( G, F, C, S, R ) 21792 IF( I.NE.M ) 21793 $ E( I-1 ) = R 21794 G = D( I ) - P 21795 R = ( D( I+1 )-G )*S + TWO*C*B 21796 P = S*R 21797 D( I ) = G + P 21798 G = C*R - B 21799 IF( ICOMPZ.GT.0 ) THEN 21800 WORK( I ) = C 21801 WORK( N-1+I ) = S 21802 END IF 21803 120 CONTINUE 21804 IF( ICOMPZ.GT.0 ) THEN 21805 MM = L - M + 1 21806 CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), 21807 $ Z( 1, M ), LDZ ) 21808 END IF 21809 D( L ) = D( L ) - P 21810 E( LM1 ) = G 21811 GO TO 90 21812 130 CONTINUE 21813 D( L ) = P 21814 L = L - 1 21815 IF( L.GE.LEND ) 21816 $ GO TO 90 21817 GO TO 140 21818 END IF 21819 140 CONTINUE 21820 IF( ISCALE.EQ.1 ) THEN 21821 CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, 21822 $ D( LSV ), N, INFO ) 21823 CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), 21824 $ N, INFO ) 21825 ELSE IF( ISCALE.EQ.2 ) THEN 21826 CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, 21827 $ D( LSV ), N, INFO ) 21828 CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), 21829 $ N, INFO ) 21830 END IF 21831 IF( JTOT.LT.NMAXIT ) 21832 $ GO TO 10 21833 DO 150 I = 1, N - 1 21834 IF( E( I ).NE.ZERO ) 21835 $ INFO = INFO + 1 21836 150 CONTINUE 21837 GO TO 190 21838 160 CONTINUE 21839 IF( ICOMPZ.EQ.0 ) THEN 21840 CALL DLASRT( 'I', N, D, INFO ) 21841 ELSE 21842 DO 180 II = 2, N 21843 I = II - 1 21844 K = I 21845 P = D( I ) 21846 DO 170 J = II, N 21847 IF( D( J ).LT.P ) THEN 21848 K = J 21849 P = D( J ) 21850 END IF 21851 170 CONTINUE 21852 IF( K.NE.I ) THEN 21853 D( K ) = D( I ) 21854 D( I ) = P 21855 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) 21856 END IF 21857 180 CONTINUE 21858 END IF 21859 190 CONTINUE 21860 RETURN 21861 END 21862! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsterf.f 21863 SUBROUTINE DSTERF( N, D, E, INFO ) 21864 INTEGER INFO, N 21865 DOUBLE PRECISION D( * ), E( * ) 21866 DOUBLE PRECISION ZERO, ONE, TWO, THREE 21867 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 21868 $ THREE = 3.0D0 ) 21869 INTEGER MAXIT 21870 PARAMETER ( MAXIT = 30 ) 21871 INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M, 21872 $ NMAXIT 21873 DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, 21874 $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, 21875 $ SIGMA, SSFMAX, SSFMIN, RMAX 21876 DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 21877 EXTERNAL DLAMCH, DLANST, DLAPY2 21878 EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA 21879 INTRINSIC ABS, SIGN, SQRT 21880 INFO = 0 21881 IF( N.LT.0 ) THEN 21882 INFO = -1 21883 CALL XERBLA( 'DSTERF', -INFO ) 21884 RETURN 21885 END IF 21886 IF( N.LE.1 ) 21887 $ RETURN 21888 EPS = DLAMCH( 'E' ) 21889 EPS2 = EPS**2 21890 SAFMIN = DLAMCH( 'S' ) 21891 SAFMAX = ONE / SAFMIN 21892 SSFMAX = SQRT( SAFMAX ) / THREE 21893 SSFMIN = SQRT( SAFMIN ) / EPS2 21894 RMAX = DLAMCH( 'O' ) 21895 NMAXIT = N*MAXIT 21896 SIGMA = ZERO 21897 JTOT = 0 21898 L1 = 1 21899 10 CONTINUE 21900 IF( L1.GT.N ) 21901 $ GO TO 170 21902 IF( L1.GT.1 ) 21903 $ E( L1-1 ) = ZERO 21904 DO 20 M = L1, N - 1 21905 IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ 21906 $ 1 ) ) ) )*EPS ) THEN 21907 E( M ) = ZERO 21908 GO TO 30 21909 END IF 21910 20 CONTINUE 21911 M = N 21912 30 CONTINUE 21913 L = L1 21914 LSV = L 21915 LEND = M 21916 LENDSV = LEND 21917 L1 = M + 1 21918 IF( LEND.EQ.L ) 21919 $ GO TO 10 21920 ANORM = DLANST( 'M', LEND-L+1, D( L ), E( L ) ) 21921 ISCALE = 0 21922 IF( ANORM.EQ.ZERO ) 21923 $ GO TO 10 21924 IF( (ANORM.GT.SSFMAX) ) THEN 21925 ISCALE = 1 21926 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, 21927 $ INFO ) 21928 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, 21929 $ INFO ) 21930 ELSE IF( ANORM.LT.SSFMIN ) THEN 21931 ISCALE = 2 21932 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, 21933 $ INFO ) 21934 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, 21935 $ INFO ) 21936 END IF 21937 DO 40 I = L, LEND - 1 21938 E( I ) = E( I )**2 21939 40 CONTINUE 21940 IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN 21941 LEND = LSV 21942 L = LENDSV 21943 END IF 21944 IF( LEND.GE.L ) THEN 21945 50 CONTINUE 21946 IF( L.NE.LEND ) THEN 21947 DO 60 M = L, LEND - 1 21948 IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) 21949 $ GO TO 70 21950 60 CONTINUE 21951 END IF 21952 M = LEND 21953 70 CONTINUE 21954 IF( M.LT.LEND ) 21955 $ E( M ) = ZERO 21956 P = D( L ) 21957 IF( M.EQ.L ) 21958 $ GO TO 90 21959 IF( M.EQ.L+1 ) THEN 21960 RTE = SQRT( E( L ) ) 21961 CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) 21962 D( L ) = RT1 21963 D( L+1 ) = RT2 21964 E( L ) = ZERO 21965 L = L + 2 21966 IF( L.LE.LEND ) 21967 $ GO TO 50 21968 GO TO 150 21969 END IF 21970 IF( JTOT.EQ.NMAXIT ) 21971 $ GO TO 150 21972 JTOT = JTOT + 1 21973 RTE = SQRT( E( L ) ) 21974 SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) 21975 R = DLAPY2( SIGMA, ONE ) 21976 SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) 21977 C = ONE 21978 S = ZERO 21979 GAMMA = D( M ) - SIGMA 21980 P = GAMMA*GAMMA 21981 DO 80 I = M - 1, L, -1 21982 BB = E( I ) 21983 R = P + BB 21984 IF( I.NE.M-1 ) 21985 $ E( I+1 ) = S*R 21986 OLDC = C 21987 C = P / R 21988 S = BB / R 21989 OLDGAM = GAMMA 21990 ALPHA = D( I ) 21991 GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM 21992 D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) 21993 IF( C.NE.ZERO ) THEN 21994 P = ( GAMMA*GAMMA ) / C 21995 ELSE 21996 P = OLDC*BB 21997 END IF 21998 80 CONTINUE 21999 E( L ) = S*P 22000 D( L ) = SIGMA + GAMMA 22001 GO TO 50 22002 90 CONTINUE 22003 D( L ) = P 22004 L = L + 1 22005 IF( L.LE.LEND ) 22006 $ GO TO 50 22007 GO TO 150 22008 ELSE 22009 100 CONTINUE 22010 DO 110 M = L, LEND + 1, -1 22011 IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) 22012 $ GO TO 120 22013 110 CONTINUE 22014 M = LEND 22015 120 CONTINUE 22016 IF( M.GT.LEND ) 22017 $ E( M-1 ) = ZERO 22018 P = D( L ) 22019 IF( M.EQ.L ) 22020 $ GO TO 140 22021 IF( M.EQ.L-1 ) THEN 22022 RTE = SQRT( E( L-1 ) ) 22023 CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) 22024 D( L ) = RT1 22025 D( L-1 ) = RT2 22026 E( L-1 ) = ZERO 22027 L = L - 2 22028 IF( L.GE.LEND ) 22029 $ GO TO 100 22030 GO TO 150 22031 END IF 22032 IF( JTOT.EQ.NMAXIT ) 22033 $ GO TO 150 22034 JTOT = JTOT + 1 22035 RTE = SQRT( E( L-1 ) ) 22036 SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) 22037 R = DLAPY2( SIGMA, ONE ) 22038 SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) 22039 C = ONE 22040 S = ZERO 22041 GAMMA = D( M ) - SIGMA 22042 P = GAMMA*GAMMA 22043 DO 130 I = M, L - 1 22044 BB = E( I ) 22045 R = P + BB 22046 IF( I.NE.M ) 22047 $ E( I-1 ) = S*R 22048 OLDC = C 22049 C = P / R 22050 S = BB / R 22051 OLDGAM = GAMMA 22052 ALPHA = D( I+1 ) 22053 GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM 22054 D( I ) = OLDGAM + ( ALPHA-GAMMA ) 22055 IF( C.NE.ZERO ) THEN 22056 P = ( GAMMA*GAMMA ) / C 22057 ELSE 22058 P = OLDC*BB 22059 END IF 22060 130 CONTINUE 22061 E( L-1 ) = S*P 22062 D( L ) = SIGMA + GAMMA 22063 GO TO 100 22064 140 CONTINUE 22065 D( L ) = P 22066 L = L - 1 22067 IF( L.GE.LEND ) 22068 $ GO TO 100 22069 GO TO 150 22070 END IF 22071 150 CONTINUE 22072 IF( ISCALE.EQ.1 ) 22073 $ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, 22074 $ D( LSV ), N, INFO ) 22075 IF( ISCALE.EQ.2 ) 22076 $ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, 22077 $ D( LSV ), N, INFO ) 22078 IF( JTOT.LT.NMAXIT ) 22079 $ GO TO 10 22080 DO 160 I = 1, N - 1 22081 IF( E( I ).NE.ZERO ) 22082 $ INFO = INFO + 1 22083 160 CONTINUE 22084 GO TO 180 22085 170 CONTINUE 22086 CALL DLASRT( 'I', N, D, INFO ) 22087 180 CONTINUE 22088 RETURN 22089 END 22090! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsyev.f 22091 SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) 22092 CHARACTER JOBZ, UPLO 22093 INTEGER INFO, LDA, LWORK, N 22094 DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) 22095 DOUBLE PRECISION ZERO, ONE 22096 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 22097 LOGICAL LOWER, LQUERY, WANTZ 22098 INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, 22099 $ LLWORK, LWKOPT, NB 22100 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 22101 $ SMLNUM 22102 LOGICAL LSAME 22103 INTEGER ILAENV 22104 DOUBLE PRECISION DLAMCH, DLANSY 22105 EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY 22106 EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD, 22107 $ XERBLA 22108 INTRINSIC MAX, SQRT 22109 WANTZ = LSAME( JOBZ, 'V' ) 22110 LOWER = LSAME( UPLO, 'L' ) 22111 LQUERY = ( LWORK.EQ.-1 ) 22112 INFO = 0 22113 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 22114 INFO = -1 22115 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 22116 INFO = -2 22117 ELSE IF( N.LT.0 ) THEN 22118 INFO = -3 22119 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 22120 INFO = -5 22121 END IF 22122 IF( INFO.EQ.0 ) THEN 22123 NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) 22124 LWKOPT = MAX( 1, ( NB+2 )*N ) 22125 WORK( 1 ) = LWKOPT 22126 IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) 22127 $ INFO = -8 22128 END IF 22129 IF( INFO.NE.0 ) THEN 22130 CALL XERBLA( 'DSYEV ', -INFO ) 22131 RETURN 22132 ELSE IF( LQUERY ) THEN 22133 RETURN 22134 END IF 22135 IF( N.EQ.0 ) THEN 22136 RETURN 22137 END IF 22138 IF( N.EQ.1 ) THEN 22139 W( 1 ) = A( 1, 1 ) 22140 WORK( 1 ) = 2 22141 IF( WANTZ ) 22142 $ A( 1, 1 ) = ONE 22143 RETURN 22144 END IF 22145 SAFMIN = DLAMCH( 'Safe minimum' ) 22146 EPS = DLAMCH( 'Precision' ) 22147 SMLNUM = SAFMIN / EPS 22148 BIGNUM = ONE / SMLNUM 22149 RMIN = SQRT( SMLNUM ) 22150 RMAX = SQRT( BIGNUM ) 22151 ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) 22152 ISCALE = 0 22153 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 22154 ISCALE = 1 22155 SIGMA = RMIN / ANRM 22156 ELSE IF( ANRM.GT.RMAX ) THEN 22157 ISCALE = 1 22158 SIGMA = RMAX / ANRM 22159 END IF 22160 IF( ISCALE.EQ.1 ) 22161 $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) 22162 INDE = 1 22163 INDTAU = INDE + N 22164 INDWRK = INDTAU + N 22165 LLWORK = LWORK - INDWRK + 1 22166 CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), 22167 $ WORK( INDWRK ), LLWORK, IINFO ) 22168 IF( .NOT.WANTZ ) THEN 22169 CALL DSTERF( N, W, WORK( INDE ), INFO ) 22170 ELSE 22171 CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), 22172 $ LLWORK, IINFO ) 22173 CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), 22174 $ INFO ) 22175 END IF 22176 IF( ISCALE.EQ.1 ) THEN 22177 IF( INFO.EQ.0 ) THEN 22178 IMAX = N 22179 ELSE 22180 IMAX = INFO - 1 22181 END IF 22182 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 22183 END IF 22184 WORK( 1 ) = LWKOPT 22185 RETURN 22186 END 22187! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsyev_2stage.f 22188 SUBROUTINE DSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, 22189 $ INFO ) 22190 IMPLICIT NONE 22191 CHARACTER JOBZ, UPLO 22192 INTEGER INFO, LDA, LWORK, N 22193 DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) 22194 DOUBLE PRECISION ZERO, ONE 22195 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 22196 LOGICAL LOWER, LQUERY, WANTZ 22197 INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, 22198 $ LLWORK, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS 22199 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 22200 $ SMLNUM 22201 LOGICAL LSAME 22202 INTEGER ILAENV2STAGE 22203 DOUBLE PRECISION DLAMCH, DLANSY 22204 EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV2STAGE 22205 EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, 22206 $ XERBLA, DSYTRD_2STAGE 22207 INTRINSIC MAX, SQRT 22208 WANTZ = LSAME( JOBZ, 'V' ) 22209 LOWER = LSAME( UPLO, 'L' ) 22210 LQUERY = ( LWORK.EQ.-1 ) 22211 INFO = 0 22212 IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN 22213 INFO = -1 22214 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 22215 INFO = -2 22216 ELSE IF( N.LT.0 ) THEN 22217 INFO = -3 22218 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 22219 INFO = -5 22220 END IF 22221 IF( INFO.EQ.0 ) THEN 22222 KD = ILAENV2STAGE( 1, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) 22223 IB = ILAENV2STAGE( 2, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) 22224 LHTRD = ILAENV2STAGE( 3, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) 22225 LWTRD = ILAENV2STAGE( 4, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) 22226 LWMIN = 2*N + LHTRD + LWTRD 22227 WORK( 1 ) = LWMIN 22228 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) 22229 $ INFO = -8 22230 END IF 22231 IF( INFO.NE.0 ) THEN 22232 CALL XERBLA( 'DSYEV_2STAGE ', -INFO ) 22233 RETURN 22234 ELSE IF( LQUERY ) THEN 22235 RETURN 22236 END IF 22237 IF( N.EQ.0 ) THEN 22238 RETURN 22239 END IF 22240 IF( N.EQ.1 ) THEN 22241 W( 1 ) = A( 1, 1 ) 22242 WORK( 1 ) = 2 22243 IF( WANTZ ) 22244 $ A( 1, 1 ) = ONE 22245 RETURN 22246 END IF 22247 SAFMIN = DLAMCH( 'Safe minimum' ) 22248 EPS = DLAMCH( 'Precision' ) 22249 SMLNUM = SAFMIN / EPS 22250 BIGNUM = ONE / SMLNUM 22251 RMIN = SQRT( SMLNUM ) 22252 RMAX = SQRT( BIGNUM ) 22253 ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) 22254 ISCALE = 0 22255 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 22256 ISCALE = 1 22257 SIGMA = RMIN / ANRM 22258 ELSE IF( ANRM.GT.RMAX ) THEN 22259 ISCALE = 1 22260 SIGMA = RMAX / ANRM 22261 END IF 22262 IF( ISCALE.EQ.1 ) 22263 $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) 22264 INDE = 1 22265 INDTAU = INDE + N 22266 INDHOUS = INDTAU + N 22267 INDWRK = INDHOUS + LHTRD 22268 LLWORK = LWORK - INDWRK + 1 22269 CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK( INDE ), 22270 $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, 22271 $ WORK( INDWRK ), LLWORK, IINFO ) 22272 IF( .NOT.WANTZ ) THEN 22273 CALL DSTERF( N, W, WORK( INDE ), INFO ) 22274 ELSE 22275 RETURN 22276 CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), 22277 $ LLWORK, IINFO ) 22278 CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), 22279 $ INFO ) 22280 END IF 22281 IF( ISCALE.EQ.1 ) THEN 22282 IF( INFO.EQ.0 ) THEN 22283 IMAX = N 22284 ELSE 22285 IMAX = INFO - 1 22286 END IF 22287 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 22288 END IF 22289 WORK( 1 ) = LWMIN 22290 RETURN 22291 END 22292! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsyevd.f 22293 SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, 22294 $ LIWORK, INFO ) 22295 CHARACTER JOBZ, UPLO 22296 INTEGER INFO, LDA, LIWORK, LWORK, N 22297 INTEGER IWORK( * ) 22298 DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) 22299 DOUBLE PRECISION ZERO, ONE 22300 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 22301 LOGICAL LOWER, LQUERY, WANTZ 22302 INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE, 22303 $ LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN 22304 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 22305 $ SMLNUM 22306 LOGICAL LSAME 22307 INTEGER ILAENV 22308 DOUBLE PRECISION DLAMCH, DLANSY 22309 EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV 22310 EXTERNAL DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF, 22311 $ DSYTRD, XERBLA 22312 INTRINSIC MAX, SQRT 22313 WANTZ = LSAME( JOBZ, 'V' ) 22314 LOWER = LSAME( UPLO, 'L' ) 22315 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 22316 INFO = 0 22317 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 22318 INFO = -1 22319 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 22320 INFO = -2 22321 ELSE IF( N.LT.0 ) THEN 22322 INFO = -3 22323 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 22324 INFO = -5 22325 END IF 22326 IF( INFO.EQ.0 ) THEN 22327 IF( N.LE.1 ) THEN 22328 LIWMIN = 1 22329 LWMIN = 1 22330 LOPT = LWMIN 22331 LIOPT = LIWMIN 22332 ELSE 22333 IF( WANTZ ) THEN 22334 LIWMIN = 3 + 5*N 22335 LWMIN = 1 + 6*N + 2*N**2 22336 ELSE 22337 LIWMIN = 1 22338 LWMIN = 2*N + 1 22339 END IF 22340 LOPT = MAX( LWMIN, 2*N + 22341 $ ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) 22342 LIOPT = LIWMIN 22343 END IF 22344 WORK( 1 ) = LOPT 22345 IWORK( 1 ) = LIOPT 22346 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 22347 INFO = -8 22348 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 22349 INFO = -10 22350 END IF 22351 END IF 22352 IF( INFO.NE.0 ) THEN 22353 CALL XERBLA( 'DSYEVD', -INFO ) 22354 RETURN 22355 ELSE IF( LQUERY ) THEN 22356 RETURN 22357 END IF 22358 IF( N.EQ.0 ) 22359 $ RETURN 22360 IF( N.EQ.1 ) THEN 22361 W( 1 ) = A( 1, 1 ) 22362 IF( WANTZ ) 22363 $ A( 1, 1 ) = ONE 22364 RETURN 22365 END IF 22366 SAFMIN = DLAMCH( 'Safe minimum' ) 22367 EPS = DLAMCH( 'Precision' ) 22368 SMLNUM = SAFMIN / EPS 22369 BIGNUM = ONE / SMLNUM 22370 RMIN = SQRT( SMLNUM ) 22371 RMAX = SQRT( BIGNUM ) 22372 ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) 22373 ISCALE = 0 22374 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 22375 ISCALE = 1 22376 SIGMA = RMIN / ANRM 22377 ELSE IF( ANRM.GT.RMAX ) THEN 22378 ISCALE = 1 22379 SIGMA = RMAX / ANRM 22380 END IF 22381 IF( ISCALE.EQ.1 ) 22382 $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) 22383 INDE = 1 22384 INDTAU = INDE + N 22385 INDWRK = INDTAU + N 22386 LLWORK = LWORK - INDWRK + 1 22387 INDWK2 = INDWRK + N*N 22388 LLWRK2 = LWORK - INDWK2 + 1 22389 CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), 22390 $ WORK( INDWRK ), LLWORK, IINFO ) 22391 IF( .NOT.WANTZ ) THEN 22392 CALL DSTERF( N, W, WORK( INDE ), INFO ) 22393 ELSE 22394 CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, 22395 $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) 22396 CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), 22397 $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) 22398 CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) 22399 END IF 22400 IF( ISCALE.EQ.1 ) 22401 $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) 22402 WORK( 1 ) = LOPT 22403 IWORK( 1 ) = LIOPT 22404 RETURN 22405 END 22406! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsyevd_2stage.f 22407 SUBROUTINE DSYEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, 22408 $ IWORK, LIWORK, INFO ) 22409 IMPLICIT NONE 22410 CHARACTER JOBZ, UPLO 22411 INTEGER INFO, LDA, LIWORK, LWORK, N 22412 INTEGER IWORK( * ) 22413 DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) 22414 DOUBLE PRECISION ZERO, ONE 22415 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 22416 LOGICAL LOWER, LQUERY, WANTZ 22417 INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE, 22418 $ LIWMIN, LLWORK, LLWRK2, LWMIN, 22419 $ LHTRD, LWTRD, KD, IB, INDHOUS 22420 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 22421 $ SMLNUM 22422 LOGICAL LSAME 22423 INTEGER ILAENV2STAGE 22424 DOUBLE PRECISION DLAMCH, DLANSY 22425 EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV2STAGE 22426 EXTERNAL DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF, 22427 $ DSYTRD_2STAGE, XERBLA 22428 INTRINSIC MAX, SQRT 22429 WANTZ = LSAME( JOBZ, 'V' ) 22430 LOWER = LSAME( UPLO, 'L' ) 22431 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 22432 INFO = 0 22433 IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN 22434 INFO = -1 22435 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 22436 INFO = -2 22437 ELSE IF( N.LT.0 ) THEN 22438 INFO = -3 22439 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 22440 INFO = -5 22441 END IF 22442 IF( INFO.EQ.0 ) THEN 22443 IF( N.LE.1 ) THEN 22444 LIWMIN = 1 22445 LWMIN = 1 22446 ELSE 22447 KD = ILAENV2STAGE( 1, 'DSYTRD_2STAGE', JOBZ, 22448 $ N, -1, -1, -1 ) 22449 IB = ILAENV2STAGE( 2, 'DSYTRD_2STAGE', JOBZ, 22450 $ N, KD, -1, -1 ) 22451 LHTRD = ILAENV2STAGE( 3, 'DSYTRD_2STAGE', JOBZ, 22452 $ N, KD, IB, -1 ) 22453 LWTRD = ILAENV2STAGE( 4, 'DSYTRD_2STAGE', JOBZ, 22454 $ N, KD, IB, -1 ) 22455 IF( WANTZ ) THEN 22456 LIWMIN = 3 + 5*N 22457 LWMIN = 1 + 6*N + 2*N**2 22458 ELSE 22459 LIWMIN = 1 22460 LWMIN = 2*N + 1 + LHTRD + LWTRD 22461 END IF 22462 END IF 22463 WORK( 1 ) = LWMIN 22464 IWORK( 1 ) = LIWMIN 22465 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 22466 INFO = -8 22467 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 22468 INFO = -10 22469 END IF 22470 END IF 22471 IF( INFO.NE.0 ) THEN 22472 CALL XERBLA( 'DSYEVD_2STAGE', -INFO ) 22473 RETURN 22474 ELSE IF( LQUERY ) THEN 22475 RETURN 22476 END IF 22477 IF( N.EQ.0 ) 22478 $ RETURN 22479 IF( N.EQ.1 ) THEN 22480 W( 1 ) = A( 1, 1 ) 22481 IF( WANTZ ) 22482 $ A( 1, 1 ) = ONE 22483 RETURN 22484 END IF 22485 SAFMIN = DLAMCH( 'Safe minimum' ) 22486 EPS = DLAMCH( 'Precision' ) 22487 SMLNUM = SAFMIN / EPS 22488 BIGNUM = ONE / SMLNUM 22489 RMIN = SQRT( SMLNUM ) 22490 RMAX = SQRT( BIGNUM ) 22491 ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) 22492 ISCALE = 0 22493 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 22494 ISCALE = 1 22495 SIGMA = RMIN / ANRM 22496 ELSE IF( ANRM.GT.RMAX ) THEN 22497 ISCALE = 1 22498 SIGMA = RMAX / ANRM 22499 END IF 22500 IF( ISCALE.EQ.1 ) 22501 $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) 22502 INDE = 1 22503 INDTAU = INDE + N 22504 INDHOUS = INDTAU + N 22505 INDWRK = INDHOUS + LHTRD 22506 LLWORK = LWORK - INDWRK + 1 22507 INDWK2 = INDWRK + N*N 22508 LLWRK2 = LWORK - INDWK2 + 1 22509 CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK( INDE ), 22510 $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, 22511 $ WORK( INDWRK ), LLWORK, IINFO ) 22512 IF( .NOT.WANTZ ) THEN 22513 CALL DSTERF( N, W, WORK( INDE ), INFO ) 22514 ELSE 22515 RETURN 22516 CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N, 22517 $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO ) 22518 CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), 22519 $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) 22520 CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) 22521 END IF 22522 IF( ISCALE.EQ.1 ) 22523 $ CALL DSCAL( N, ONE / SIGMA, W, 1 ) 22524 WORK( 1 ) = LWMIN 22525 IWORK( 1 ) = LIWMIN 22526 RETURN 22527 END 22528! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsyevr.f 22529 SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, 22530 $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, 22531 $ IWORK, LIWORK, INFO ) 22532 CHARACTER JOBZ, RANGE, UPLO 22533 INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N 22534 DOUBLE PRECISION ABSTOL, VL, VU 22535 INTEGER ISUPPZ( * ), IWORK( * ) 22536 DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) 22537 DOUBLE PRECISION ZERO, ONE, TWO 22538 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) 22539 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ, 22540 $ TRYRAC 22541 CHARACTER ORDER 22542 INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, 22543 $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, 22544 $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN, 22545 $ LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT 22546 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, 22547 $ SIGMA, SMLNUM, TMP1, VLL, VUU 22548 LOGICAL LSAME 22549 INTEGER ILAENV 22550 DOUBLE PRECISION DLAMCH, DLANSY 22551 EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY 22552 EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN, 22553 $ DSTERF, DSWAP, DSYTRD, XERBLA 22554 INTRINSIC MAX, MIN, SQRT 22555 IEEEOK = ILAENV( 10, 'DSYEVR', 'N', 1, 2, 3, 4 ) 22556 LOWER = LSAME( UPLO, 'L' ) 22557 WANTZ = LSAME( JOBZ, 'V' ) 22558 ALLEIG = LSAME( RANGE, 'A' ) 22559 VALEIG = LSAME( RANGE, 'V' ) 22560 INDEIG = LSAME( RANGE, 'I' ) 22561 LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) ) 22562 LWMIN = MAX( 1, 26*N ) 22563 LIWMIN = MAX( 1, 10*N ) 22564 INFO = 0 22565 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 22566 INFO = -1 22567 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN 22568 INFO = -2 22569 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 22570 INFO = -3 22571 ELSE IF( N.LT.0 ) THEN 22572 INFO = -4 22573 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 22574 INFO = -6 22575 ELSE 22576 IF( VALEIG ) THEN 22577 IF( N.GT.0 .AND. VU.LE.VL ) 22578 $ INFO = -8 22579 ELSE IF( INDEIG ) THEN 22580 IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN 22581 INFO = -9 22582 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN 22583 INFO = -10 22584 END IF 22585 END IF 22586 END IF 22587 IF( INFO.EQ.0 ) THEN 22588 IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 22589 INFO = -15 22590 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 22591 INFO = -18 22592 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 22593 INFO = -20 22594 END IF 22595 END IF 22596 IF( INFO.EQ.0 ) THEN 22597 NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) 22598 NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) 22599 LWKOPT = MAX( ( NB+1 )*N, LWMIN ) 22600 WORK( 1 ) = LWKOPT 22601 IWORK( 1 ) = LIWMIN 22602 END IF 22603 IF( INFO.NE.0 ) THEN 22604 CALL XERBLA( 'DSYEVR', -INFO ) 22605 RETURN 22606 ELSE IF( LQUERY ) THEN 22607 RETURN 22608 END IF 22609 M = 0 22610 IF( N.EQ.0 ) THEN 22611 WORK( 1 ) = 1 22612 RETURN 22613 END IF 22614 IF( N.EQ.1 ) THEN 22615 WORK( 1 ) = 7 22616 IF( ALLEIG .OR. INDEIG ) THEN 22617 M = 1 22618 W( 1 ) = A( 1, 1 ) 22619 ELSE 22620 IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN 22621 M = 1 22622 W( 1 ) = A( 1, 1 ) 22623 END IF 22624 END IF 22625 IF( WANTZ ) THEN 22626 Z( 1, 1 ) = ONE 22627 ISUPPZ( 1 ) = 1 22628 ISUPPZ( 2 ) = 1 22629 END IF 22630 RETURN 22631 END IF 22632 SAFMIN = DLAMCH( 'Safe minimum' ) 22633 EPS = DLAMCH( 'Precision' ) 22634 SMLNUM = SAFMIN / EPS 22635 BIGNUM = ONE / SMLNUM 22636 RMIN = SQRT( SMLNUM ) 22637 RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) 22638 ISCALE = 0 22639 ABSTLL = ABSTOL 22640 IF (VALEIG) THEN 22641 VLL = VL 22642 VUU = VU 22643 END IF 22644 ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) 22645 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 22646 ISCALE = 1 22647 SIGMA = RMIN / ANRM 22648 ELSE IF( ANRM.GT.RMAX ) THEN 22649 ISCALE = 1 22650 SIGMA = RMAX / ANRM 22651 END IF 22652 IF( ISCALE.EQ.1 ) THEN 22653 IF( LOWER ) THEN 22654 DO 10 J = 1, N 22655 CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 22656 10 CONTINUE 22657 ELSE 22658 DO 20 J = 1, N 22659 CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) 22660 20 CONTINUE 22661 END IF 22662 IF( ABSTOL.GT.0 ) 22663 $ ABSTLL = ABSTOL*SIGMA 22664 IF( VALEIG ) THEN 22665 VLL = VL*SIGMA 22666 VUU = VU*SIGMA 22667 END IF 22668 END IF 22669 INDTAU = 1 22670 INDD = INDTAU + N 22671 INDE = INDD + N 22672 INDDD = INDE + N 22673 INDEE = INDDD + N 22674 INDWK = INDEE + N 22675 LLWORK = LWORK - INDWK + 1 22676 INDIBL = 1 22677 INDISP = INDIBL + N 22678 INDIFL = INDISP + N 22679 INDIWO = INDIFL + N 22680 CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), 22681 $ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO ) 22682 IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. 22683 $ IEEEOK.EQ.1 ) THEN 22684 IF( .NOT.WANTZ ) THEN 22685 CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) 22686 CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) 22687 CALL DSTERF( N, W, WORK( INDEE ), INFO ) 22688 ELSE 22689 CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) 22690 CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) 22691 IF (ABSTOL .LE. TWO*N*EPS) THEN 22692 TRYRAC = .TRUE. 22693 ELSE 22694 TRYRAC = .FALSE. 22695 END IF 22696 CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), 22697 $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ, 22698 $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK, 22699 $ INFO ) 22700 IF( WANTZ .AND. INFO.EQ.0 ) THEN 22701 INDWKN = INDE 22702 LLWRKN = LWORK - INDWKN + 1 22703 CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, 22704 $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), 22705 $ LLWRKN, IINFO ) 22706 END IF 22707 END IF 22708 IF( INFO.EQ.0 ) THEN 22709 M = N 22710 GO TO 30 22711 END IF 22712 INFO = 0 22713 END IF 22714 IF( WANTZ ) THEN 22715 ORDER = 'B' 22716 ELSE 22717 ORDER = 'E' 22718 END IF 22719 CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, 22720 $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, 22721 $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ), 22722 $ IWORK( INDIWO ), INFO ) 22723 IF( WANTZ ) THEN 22724 CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, 22725 $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, 22726 $ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ), 22727 $ INFO ) 22728 INDWKN = INDE 22729 LLWRKN = LWORK - INDWKN + 1 22730 CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, 22731 $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) 22732 END IF 22733 30 CONTINUE 22734 IF( ISCALE.EQ.1 ) THEN 22735 IF( INFO.EQ.0 ) THEN 22736 IMAX = M 22737 ELSE 22738 IMAX = INFO - 1 22739 END IF 22740 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 22741 END IF 22742 IF( WANTZ ) THEN 22743 DO 50 J = 1, M - 1 22744 I = 0 22745 TMP1 = W( J ) 22746 DO 40 JJ = J + 1, M 22747 IF( W( JJ ).LT.TMP1 ) THEN 22748 I = JJ 22749 TMP1 = W( JJ ) 22750 END IF 22751 40 CONTINUE 22752 IF( I.NE.0 ) THEN 22753 W( I ) = W( J ) 22754 W( J ) = TMP1 22755 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) 22756 END IF 22757 50 CONTINUE 22758 END IF 22759 WORK( 1 ) = LWKOPT 22760 IWORK( 1 ) = LIWMIN 22761 RETURN 22762 END 22763! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsyevr_2stage.f 22764 SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, 22765 $ IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, 22766 $ LWORK, IWORK, LIWORK, INFO ) 22767 IMPLICIT NONE 22768 CHARACTER JOBZ, RANGE, UPLO 22769 INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N 22770 DOUBLE PRECISION ABSTOL, VL, VU 22771 INTEGER ISUPPZ( * ), IWORK( * ) 22772 DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) 22773 DOUBLE PRECISION ZERO, ONE, TWO 22774 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) 22775 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ, 22776 $ TRYRAC 22777 CHARACTER ORDER 22778 INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, 22779 $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, 22780 $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN, 22781 $ LLWORK, LLWRKN, LWMIN, NSPLIT, 22782 $ LHTRD, LWTRD, KD, IB, INDHOUS 22783 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, 22784 $ SIGMA, SMLNUM, TMP1, VLL, VUU 22785 LOGICAL LSAME 22786 INTEGER ILAENV, ILAENV2STAGE 22787 DOUBLE PRECISION DLAMCH, DLANSY 22788 EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV, ILAENV2STAGE 22789 EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN, 22790 $ DSTERF, DSWAP, DSYTRD_2STAGE, XERBLA 22791 INTRINSIC MAX, MIN, SQRT 22792 IEEEOK = ILAENV( 10, 'DSYEVR', 'N', 1, 2, 3, 4 ) 22793 LOWER = LSAME( UPLO, 'L' ) 22794 WANTZ = LSAME( JOBZ, 'V' ) 22795 ALLEIG = LSAME( RANGE, 'A' ) 22796 VALEIG = LSAME( RANGE, 'V' ) 22797 INDEIG = LSAME( RANGE, 'I' ) 22798 LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) ) 22799 KD = ILAENV2STAGE( 1, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) 22800 IB = ILAENV2STAGE( 2, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) 22801 LHTRD = ILAENV2STAGE( 3, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) 22802 LWTRD = ILAENV2STAGE( 4, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) 22803 LWMIN = MAX( 26*N, 5*N + LHTRD + LWTRD ) 22804 LIWMIN = MAX( 1, 10*N ) 22805 INFO = 0 22806 IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN 22807 INFO = -1 22808 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN 22809 INFO = -2 22810 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 22811 INFO = -3 22812 ELSE IF( N.LT.0 ) THEN 22813 INFO = -4 22814 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 22815 INFO = -6 22816 ELSE 22817 IF( VALEIG ) THEN 22818 IF( N.GT.0 .AND. VU.LE.VL ) 22819 $ INFO = -8 22820 ELSE IF( INDEIG ) THEN 22821 IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN 22822 INFO = -9 22823 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN 22824 INFO = -10 22825 END IF 22826 END IF 22827 END IF 22828 IF( INFO.EQ.0 ) THEN 22829 IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 22830 INFO = -15 22831 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 22832 INFO = -18 22833 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 22834 INFO = -20 22835 END IF 22836 END IF 22837 IF( INFO.EQ.0 ) THEN 22838 WORK( 1 ) = LWMIN 22839 IWORK( 1 ) = LIWMIN 22840 END IF 22841 IF( INFO.NE.0 ) THEN 22842 CALL XERBLA( 'DSYEVR_2STAGE', -INFO ) 22843 RETURN 22844 ELSE IF( LQUERY ) THEN 22845 RETURN 22846 END IF 22847 M = 0 22848 IF( N.EQ.0 ) THEN 22849 WORK( 1 ) = 1 22850 RETURN 22851 END IF 22852 IF( N.EQ.1 ) THEN 22853 WORK( 1 ) = 7 22854 IF( ALLEIG .OR. INDEIG ) THEN 22855 M = 1 22856 W( 1 ) = A( 1, 1 ) 22857 ELSE 22858 IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN 22859 M = 1 22860 W( 1 ) = A( 1, 1 ) 22861 END IF 22862 END IF 22863 IF( WANTZ ) THEN 22864 Z( 1, 1 ) = ONE 22865 ISUPPZ( 1 ) = 1 22866 ISUPPZ( 2 ) = 1 22867 END IF 22868 RETURN 22869 END IF 22870 SAFMIN = DLAMCH( 'Safe minimum' ) 22871 EPS = DLAMCH( 'Precision' ) 22872 SMLNUM = SAFMIN / EPS 22873 BIGNUM = ONE / SMLNUM 22874 RMIN = SQRT( SMLNUM ) 22875 RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) 22876 ISCALE = 0 22877 ABSTLL = ABSTOL 22878 IF (VALEIG) THEN 22879 VLL = VL 22880 VUU = VU 22881 END IF 22882 ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) 22883 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 22884 ISCALE = 1 22885 SIGMA = RMIN / ANRM 22886 ELSE IF( ANRM.GT.RMAX ) THEN 22887 ISCALE = 1 22888 SIGMA = RMAX / ANRM 22889 END IF 22890 IF( ISCALE.EQ.1 ) THEN 22891 IF( LOWER ) THEN 22892 DO 10 J = 1, N 22893 CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 22894 10 CONTINUE 22895 ELSE 22896 DO 20 J = 1, N 22897 CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) 22898 20 CONTINUE 22899 END IF 22900 IF( ABSTOL.GT.0 ) 22901 $ ABSTLL = ABSTOL*SIGMA 22902 IF( VALEIG ) THEN 22903 VLL = VL*SIGMA 22904 VUU = VU*SIGMA 22905 END IF 22906 END IF 22907 INDTAU = 1 22908 INDD = INDTAU + N 22909 INDE = INDD + N 22910 INDDD = INDE + N 22911 INDEE = INDDD + N 22912 INDHOUS = INDEE + N 22913 INDWK = INDHOUS + LHTRD 22914 LLWORK = LWORK - INDWK + 1 22915 INDIBL = 1 22916 INDISP = INDIBL + N 22917 INDIFL = INDISP + N 22918 INDIWO = INDIFL + N 22919 CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, WORK( INDD ), 22920 $ WORK( INDE ), WORK( INDTAU ), WORK( INDHOUS ), 22921 $ LHTRD, WORK( INDWK ), LLWORK, IINFO ) 22922 IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. 22923 $ IEEEOK.EQ.1 ) THEN 22924 IF( .NOT.WANTZ ) THEN 22925 CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) 22926 CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) 22927 CALL DSTERF( N, W, WORK( INDEE ), INFO ) 22928 ELSE 22929 CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) 22930 CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) 22931 IF (ABSTOL .LE. TWO*N*EPS) THEN 22932 TRYRAC = .TRUE. 22933 ELSE 22934 TRYRAC = .FALSE. 22935 END IF 22936 CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), 22937 $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ, 22938 $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK, 22939 $ INFO ) 22940 IF( WANTZ .AND. INFO.EQ.0 ) THEN 22941 INDWKN = INDE 22942 LLWRKN = LWORK - INDWKN + 1 22943 CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, 22944 $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), 22945 $ LLWRKN, IINFO ) 22946 END IF 22947 END IF 22948 IF( INFO.EQ.0 ) THEN 22949 M = N 22950 GO TO 30 22951 END IF 22952 INFO = 0 22953 END IF 22954 IF( WANTZ ) THEN 22955 ORDER = 'B' 22956 ELSE 22957 ORDER = 'E' 22958 END IF 22959 CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, 22960 $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, 22961 $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ), 22962 $ IWORK( INDIWO ), INFO ) 22963 IF( WANTZ ) THEN 22964 CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, 22965 $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, 22966 $ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ), 22967 $ INFO ) 22968 INDWKN = INDE 22969 LLWRKN = LWORK - INDWKN + 1 22970 CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, 22971 $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) 22972 END IF 22973 30 CONTINUE 22974 IF( ISCALE.EQ.1 ) THEN 22975 IF( INFO.EQ.0 ) THEN 22976 IMAX = M 22977 ELSE 22978 IMAX = INFO - 1 22979 END IF 22980 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 22981 END IF 22982 IF( WANTZ ) THEN 22983 DO 50 J = 1, M - 1 22984 I = 0 22985 TMP1 = W( J ) 22986 DO 40 JJ = J + 1, M 22987 IF( W( JJ ).LT.TMP1 ) THEN 22988 I = JJ 22989 TMP1 = W( JJ ) 22990 END IF 22991 40 CONTINUE 22992 IF( I.NE.0 ) THEN 22993 W( I ) = W( J ) 22994 W( J ) = TMP1 22995 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) 22996 END IF 22997 50 CONTINUE 22998 END IF 22999 WORK( 1 ) = LWMIN 23000 IWORK( 1 ) = LIWMIN 23001 RETURN 23002 END 23003! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsyevx.f 23004 SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, 23005 $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, 23006 $ IFAIL, INFO ) 23007 CHARACTER JOBZ, RANGE, UPLO 23008 INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N 23009 DOUBLE PRECISION ABSTOL, VL, VU 23010 INTEGER IFAIL( * ), IWORK( * ) 23011 DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) 23012 DOUBLE PRECISION ZERO, ONE 23013 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 23014 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, 23015 $ WANTZ 23016 CHARACTER ORDER 23017 INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, 23018 $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, 23019 $ ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN, 23020 $ LWKOPT, NB, NSPLIT 23021 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, 23022 $ SIGMA, SMLNUM, TMP1, VLL, VUU 23023 LOGICAL LSAME 23024 INTEGER ILAENV 23025 DOUBLE PRECISION DLAMCH, DLANSY 23026 EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY 23027 EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, 23028 $ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA 23029 INTRINSIC MAX, MIN, SQRT 23030 LOWER = LSAME( UPLO, 'L' ) 23031 WANTZ = LSAME( JOBZ, 'V' ) 23032 ALLEIG = LSAME( RANGE, 'A' ) 23033 VALEIG = LSAME( RANGE, 'V' ) 23034 INDEIG = LSAME( RANGE, 'I' ) 23035 LQUERY = ( LWORK.EQ.-1 ) 23036 INFO = 0 23037 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 23038 INFO = -1 23039 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN 23040 INFO = -2 23041 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 23042 INFO = -3 23043 ELSE IF( N.LT.0 ) THEN 23044 INFO = -4 23045 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 23046 INFO = -6 23047 ELSE 23048 IF( VALEIG ) THEN 23049 IF( N.GT.0 .AND. VU.LE.VL ) 23050 $ INFO = -8 23051 ELSE IF( INDEIG ) THEN 23052 IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN 23053 INFO = -9 23054 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN 23055 INFO = -10 23056 END IF 23057 END IF 23058 END IF 23059 IF( INFO.EQ.0 ) THEN 23060 IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 23061 INFO = -15 23062 END IF 23063 END IF 23064 IF( INFO.EQ.0 ) THEN 23065 IF( N.LE.1 ) THEN 23066 LWKMIN = 1 23067 WORK( 1 ) = LWKMIN 23068 ELSE 23069 LWKMIN = 8*N 23070 NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) 23071 NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) 23072 LWKOPT = MAX( LWKMIN, ( NB + 3 )*N ) 23073 WORK( 1 ) = LWKOPT 23074 END IF 23075 IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) 23076 $ INFO = -17 23077 END IF 23078 IF( INFO.NE.0 ) THEN 23079 CALL XERBLA( 'DSYEVX', -INFO ) 23080 RETURN 23081 ELSE IF( LQUERY ) THEN 23082 RETURN 23083 END IF 23084 M = 0 23085 IF( N.EQ.0 ) THEN 23086 RETURN 23087 END IF 23088 IF( N.EQ.1 ) THEN 23089 IF( ALLEIG .OR. INDEIG ) THEN 23090 M = 1 23091 W( 1 ) = A( 1, 1 ) 23092 ELSE 23093 IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN 23094 M = 1 23095 W( 1 ) = A( 1, 1 ) 23096 END IF 23097 END IF 23098 IF( WANTZ ) 23099 $ Z( 1, 1 ) = ONE 23100 RETURN 23101 END IF 23102 SAFMIN = DLAMCH( 'Safe minimum' ) 23103 EPS = DLAMCH( 'Precision' ) 23104 SMLNUM = SAFMIN / EPS 23105 BIGNUM = ONE / SMLNUM 23106 RMIN = SQRT( SMLNUM ) 23107 RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) 23108 ISCALE = 0 23109 ABSTLL = ABSTOL 23110 IF( VALEIG ) THEN 23111 VLL = VL 23112 VUU = VU 23113 END IF 23114 ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) 23115 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 23116 ISCALE = 1 23117 SIGMA = RMIN / ANRM 23118 ELSE IF( ANRM.GT.RMAX ) THEN 23119 ISCALE = 1 23120 SIGMA = RMAX / ANRM 23121 END IF 23122 IF( ISCALE.EQ.1 ) THEN 23123 IF( LOWER ) THEN 23124 DO 10 J = 1, N 23125 CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 23126 10 CONTINUE 23127 ELSE 23128 DO 20 J = 1, N 23129 CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) 23130 20 CONTINUE 23131 END IF 23132 IF( ABSTOL.GT.0 ) 23133 $ ABSTLL = ABSTOL*SIGMA 23134 IF( VALEIG ) THEN 23135 VLL = VL*SIGMA 23136 VUU = VU*SIGMA 23137 END IF 23138 END IF 23139 INDTAU = 1 23140 INDE = INDTAU + N 23141 INDD = INDE + N 23142 INDWRK = INDD + N 23143 LLWORK = LWORK - INDWRK + 1 23144 CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), 23145 $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO ) 23146 TEST = .FALSE. 23147 IF( INDEIG ) THEN 23148 IF( IL.EQ.1 .AND. IU.EQ.N ) THEN 23149 TEST = .TRUE. 23150 END IF 23151 END IF 23152 IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN 23153 CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) 23154 INDEE = INDWRK + 2*N 23155 IF( .NOT.WANTZ ) THEN 23156 CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) 23157 CALL DSTERF( N, W, WORK( INDEE ), INFO ) 23158 ELSE 23159 CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ ) 23160 CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), 23161 $ WORK( INDWRK ), LLWORK, IINFO ) 23162 CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) 23163 CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, 23164 $ WORK( INDWRK ), INFO ) 23165 IF( INFO.EQ.0 ) THEN 23166 DO 30 I = 1, N 23167 IFAIL( I ) = 0 23168 30 CONTINUE 23169 END IF 23170 END IF 23171 IF( INFO.EQ.0 ) THEN 23172 M = N 23173 GO TO 40 23174 END IF 23175 INFO = 0 23176 END IF 23177 IF( WANTZ ) THEN 23178 ORDER = 'B' 23179 ELSE 23180 ORDER = 'E' 23181 END IF 23182 INDIBL = 1 23183 INDISP = INDIBL + N 23184 INDIWO = INDISP + N 23185 CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, 23186 $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, 23187 $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), 23188 $ IWORK( INDIWO ), INFO ) 23189 IF( WANTZ ) THEN 23190 CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, 23191 $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, 23192 $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) 23193 INDWKN = INDE 23194 LLWRKN = LWORK - INDWKN + 1 23195 CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, 23196 $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) 23197 END IF 23198 40 CONTINUE 23199 IF( ISCALE.EQ.1 ) THEN 23200 IF( INFO.EQ.0 ) THEN 23201 IMAX = M 23202 ELSE 23203 IMAX = INFO - 1 23204 END IF 23205 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 23206 END IF 23207 IF( WANTZ ) THEN 23208 DO 60 J = 1, M - 1 23209 I = 0 23210 TMP1 = W( J ) 23211 DO 50 JJ = J + 1, M 23212 IF( W( JJ ).LT.TMP1 ) THEN 23213 I = JJ 23214 TMP1 = W( JJ ) 23215 END IF 23216 50 CONTINUE 23217 IF( I.NE.0 ) THEN 23218 ITMP1 = IWORK( INDIBL+I-1 ) 23219 W( I ) = W( J ) 23220 IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) 23221 W( J ) = TMP1 23222 IWORK( INDIBL+J-1 ) = ITMP1 23223 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) 23224 IF( INFO.NE.0 ) THEN 23225 ITMP1 = IFAIL( I ) 23226 IFAIL( I ) = IFAIL( J ) 23227 IFAIL( J ) = ITMP1 23228 END IF 23229 END IF 23230 60 CONTINUE 23231 END IF 23232 WORK( 1 ) = LWKOPT 23233 RETURN 23234 END 23235! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsyevx_2stage.f 23236 SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, 23237 $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, 23238 $ LWORK, IWORK, IFAIL, INFO ) 23239 IMPLICIT NONE 23240 CHARACTER JOBZ, RANGE, UPLO 23241 INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N 23242 DOUBLE PRECISION ABSTOL, VL, VU 23243 INTEGER IFAIL( * ), IWORK( * ) 23244 DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) 23245 DOUBLE PRECISION ZERO, ONE 23246 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 23247 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, 23248 $ WANTZ 23249 CHARACTER ORDER 23250 INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, 23251 $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, 23252 $ ITMP1, J, JJ, LLWORK, LLWRKN, 23253 $ NSPLIT, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS 23254 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, 23255 $ SIGMA, SMLNUM, TMP1, VLL, VUU 23256 LOGICAL LSAME 23257 INTEGER ILAENV2STAGE 23258 DOUBLE PRECISION DLAMCH, DLANSY 23259 EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV2STAGE 23260 EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, 23261 $ DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA, 23262 $ DSYTRD_2STAGE 23263 INTRINSIC MAX, MIN, SQRT 23264 LOWER = LSAME( UPLO, 'L' ) 23265 WANTZ = LSAME( JOBZ, 'V' ) 23266 ALLEIG = LSAME( RANGE, 'A' ) 23267 VALEIG = LSAME( RANGE, 'V' ) 23268 INDEIG = LSAME( RANGE, 'I' ) 23269 LQUERY = ( LWORK.EQ.-1 ) 23270 INFO = 0 23271 IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN 23272 INFO = -1 23273 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN 23274 INFO = -2 23275 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 23276 INFO = -3 23277 ELSE IF( N.LT.0 ) THEN 23278 INFO = -4 23279 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 23280 INFO = -6 23281 ELSE 23282 IF( VALEIG ) THEN 23283 IF( N.GT.0 .AND. VU.LE.VL ) 23284 $ INFO = -8 23285 ELSE IF( INDEIG ) THEN 23286 IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN 23287 INFO = -9 23288 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN 23289 INFO = -10 23290 END IF 23291 END IF 23292 END IF 23293 IF( INFO.EQ.0 ) THEN 23294 IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 23295 INFO = -15 23296 END IF 23297 END IF 23298 IF( INFO.EQ.0 ) THEN 23299 IF( N.LE.1 ) THEN 23300 LWMIN = 1 23301 WORK( 1 ) = LWMIN 23302 ELSE 23303 KD = ILAENV2STAGE( 1, 'DSYTRD_2STAGE', JOBZ, 23304 $ N, -1, -1, -1 ) 23305 IB = ILAENV2STAGE( 2, 'DSYTRD_2STAGE', JOBZ, 23306 $ N, KD, -1, -1 ) 23307 LHTRD = ILAENV2STAGE( 3, 'DSYTRD_2STAGE', JOBZ, 23308 $ N, KD, IB, -1 ) 23309 LWTRD = ILAENV2STAGE( 4, 'DSYTRD_2STAGE', JOBZ, 23310 $ N, KD, IB, -1 ) 23311 LWMIN = MAX( 8*N, 3*N + LHTRD + LWTRD ) 23312 WORK( 1 ) = LWMIN 23313 END IF 23314 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) 23315 $ INFO = -17 23316 END IF 23317 IF( INFO.NE.0 ) THEN 23318 CALL XERBLA( 'DSYEVX_2STAGE', -INFO ) 23319 RETURN 23320 ELSE IF( LQUERY ) THEN 23321 RETURN 23322 END IF 23323 M = 0 23324 IF( N.EQ.0 ) THEN 23325 RETURN 23326 END IF 23327 IF( N.EQ.1 ) THEN 23328 IF( ALLEIG .OR. INDEIG ) THEN 23329 M = 1 23330 W( 1 ) = A( 1, 1 ) 23331 ELSE 23332 IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN 23333 M = 1 23334 W( 1 ) = A( 1, 1 ) 23335 END IF 23336 END IF 23337 IF( WANTZ ) 23338 $ Z( 1, 1 ) = ONE 23339 RETURN 23340 END IF 23341 SAFMIN = DLAMCH( 'Safe minimum' ) 23342 EPS = DLAMCH( 'Precision' ) 23343 SMLNUM = SAFMIN / EPS 23344 BIGNUM = ONE / SMLNUM 23345 RMIN = SQRT( SMLNUM ) 23346 RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) 23347 ISCALE = 0 23348 ABSTLL = ABSTOL 23349 IF( VALEIG ) THEN 23350 VLL = VL 23351 VUU = VU 23352 END IF 23353 ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) 23354 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 23355 ISCALE = 1 23356 SIGMA = RMIN / ANRM 23357 ELSE IF( ANRM.GT.RMAX ) THEN 23358 ISCALE = 1 23359 SIGMA = RMAX / ANRM 23360 END IF 23361 IF( ISCALE.EQ.1 ) THEN 23362 IF( LOWER ) THEN 23363 DO 10 J = 1, N 23364 CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 23365 10 CONTINUE 23366 ELSE 23367 DO 20 J = 1, N 23368 CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) 23369 20 CONTINUE 23370 END IF 23371 IF( ABSTOL.GT.0 ) 23372 $ ABSTLL = ABSTOL*SIGMA 23373 IF( VALEIG ) THEN 23374 VLL = VL*SIGMA 23375 VUU = VU*SIGMA 23376 END IF 23377 END IF 23378 INDTAU = 1 23379 INDE = INDTAU + N 23380 INDD = INDE + N 23381 INDHOUS = INDD + N 23382 INDWRK = INDHOUS + LHTRD 23383 LLWORK = LWORK - INDWRK + 1 23384 CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, WORK( INDD ), 23385 $ WORK( INDE ), WORK( INDTAU ), WORK( INDHOUS ), 23386 $ LHTRD, WORK( INDWRK ), LLWORK, IINFO ) 23387 TEST = .FALSE. 23388 IF( INDEIG ) THEN 23389 IF( IL.EQ.1 .AND. IU.EQ.N ) THEN 23390 TEST = .TRUE. 23391 END IF 23392 END IF 23393 IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN 23394 CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) 23395 INDEE = INDWRK + 2*N 23396 IF( .NOT.WANTZ ) THEN 23397 CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) 23398 CALL DSTERF( N, W, WORK( INDEE ), INFO ) 23399 ELSE 23400 CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ ) 23401 CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), 23402 $ WORK( INDWRK ), LLWORK, IINFO ) 23403 CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) 23404 CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, 23405 $ WORK( INDWRK ), INFO ) 23406 IF( INFO.EQ.0 ) THEN 23407 DO 30 I = 1, N 23408 IFAIL( I ) = 0 23409 30 CONTINUE 23410 END IF 23411 END IF 23412 IF( INFO.EQ.0 ) THEN 23413 M = N 23414 GO TO 40 23415 END IF 23416 INFO = 0 23417 END IF 23418 IF( WANTZ ) THEN 23419 ORDER = 'B' 23420 ELSE 23421 ORDER = 'E' 23422 END IF 23423 INDIBL = 1 23424 INDISP = INDIBL + N 23425 INDIWO = INDISP + N 23426 CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, 23427 $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, 23428 $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), 23429 $ IWORK( INDIWO ), INFO ) 23430 IF( WANTZ ) THEN 23431 CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, 23432 $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, 23433 $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) 23434 INDWKN = INDE 23435 LLWRKN = LWORK - INDWKN + 1 23436 CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, 23437 $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) 23438 END IF 23439 40 CONTINUE 23440 IF( ISCALE.EQ.1 ) THEN 23441 IF( INFO.EQ.0 ) THEN 23442 IMAX = M 23443 ELSE 23444 IMAX = INFO - 1 23445 END IF 23446 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 23447 END IF 23448 IF( WANTZ ) THEN 23449 DO 60 J = 1, M - 1 23450 I = 0 23451 TMP1 = W( J ) 23452 DO 50 JJ = J + 1, M 23453 IF( W( JJ ).LT.TMP1 ) THEN 23454 I = JJ 23455 TMP1 = W( JJ ) 23456 END IF 23457 50 CONTINUE 23458 IF( I.NE.0 ) THEN 23459 ITMP1 = IWORK( INDIBL+I-1 ) 23460 W( I ) = W( J ) 23461 IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) 23462 W( J ) = TMP1 23463 IWORK( INDIBL+J-1 ) = ITMP1 23464 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) 23465 IF( INFO.NE.0 ) THEN 23466 ITMP1 = IFAIL( I ) 23467 IFAIL( I ) = IFAIL( J ) 23468 IFAIL( J ) = ITMP1 23469 END IF 23470 END IF 23471 60 CONTINUE 23472 END IF 23473 WORK( 1 ) = LWMIN 23474 RETURN 23475 END 23476! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsygs2.f 23477 SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) 23478 CHARACTER UPLO 23479 INTEGER INFO, ITYPE, LDA, LDB, N 23480 DOUBLE PRECISION A( LDA, * ), B( LDB, * ) 23481 DOUBLE PRECISION ONE, HALF 23482 PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) 23483 LOGICAL UPPER 23484 INTEGER K 23485 DOUBLE PRECISION AKK, BKK, CT 23486 EXTERNAL DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA 23487 INTRINSIC MAX 23488 LOGICAL LSAME 23489 EXTERNAL LSAME 23490 INFO = 0 23491 UPPER = LSAME( UPLO, 'U' ) 23492 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN 23493 INFO = -1 23494 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 23495 INFO = -2 23496 ELSE IF( N.LT.0 ) THEN 23497 INFO = -3 23498 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 23499 INFO = -5 23500 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 23501 INFO = -7 23502 END IF 23503 IF( INFO.NE.0 ) THEN 23504 CALL XERBLA( 'DSYGS2', -INFO ) 23505 RETURN 23506 END IF 23507 IF( ITYPE.EQ.1 ) THEN 23508 IF( UPPER ) THEN 23509 DO 10 K = 1, N 23510 AKK = A( K, K ) 23511 BKK = B( K, K ) 23512 AKK = AKK / BKK**2 23513 A( K, K ) = AKK 23514 IF( K.LT.N ) THEN 23515 CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) 23516 CT = -HALF*AKK 23517 CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), 23518 $ LDA ) 23519 CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA, 23520 $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) 23521 CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), 23522 $ LDA ) 23523 CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K, 23524 $ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA ) 23525 END IF 23526 10 CONTINUE 23527 ELSE 23528 DO 20 K = 1, N 23529 AKK = A( K, K ) 23530 BKK = B( K, K ) 23531 AKK = AKK / BKK**2 23532 A( K, K ) = AKK 23533 IF( K.LT.N ) THEN 23534 CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) 23535 CT = -HALF*AKK 23536 CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) 23537 CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1, 23538 $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) 23539 CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) 23540 CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K, 23541 $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) 23542 END IF 23543 20 CONTINUE 23544 END IF 23545 ELSE 23546 IF( UPPER ) THEN 23547 DO 30 K = 1, N 23548 AKK = A( K, K ) 23549 BKK = B( K, K ) 23550 CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, 23551 $ LDB, A( 1, K ), 1 ) 23552 CT = HALF*AKK 23553 CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) 23554 CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1, 23555 $ A, LDA ) 23556 CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) 23557 CALL DSCAL( K-1, BKK, A( 1, K ), 1 ) 23558 A( K, K ) = AKK*BKK**2 23559 30 CONTINUE 23560 ELSE 23561 DO 40 K = 1, N 23562 AKK = A( K, K ) 23563 BKK = B( K, K ) 23564 CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB, 23565 $ A( K, 1 ), LDA ) 23566 CT = HALF*AKK 23567 CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) 23568 CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ), 23569 $ LDB, A, LDA ) 23570 CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) 23571 CALL DSCAL( K-1, BKK, A( K, 1 ), LDA ) 23572 A( K, K ) = AKK*BKK**2 23573 40 CONTINUE 23574 END IF 23575 END IF 23576 RETURN 23577 END 23578! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsygst.f 23579 SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) 23580 CHARACTER UPLO 23581 INTEGER INFO, ITYPE, LDA, LDB, N 23582 DOUBLE PRECISION A( LDA, * ), B( LDB, * ) 23583 DOUBLE PRECISION ONE, HALF 23584 PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) 23585 LOGICAL UPPER 23586 INTEGER K, KB, NB 23587 EXTERNAL DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA 23588 INTRINSIC MAX, MIN 23589 LOGICAL LSAME 23590 INTEGER ILAENV 23591 EXTERNAL LSAME, ILAENV 23592 INFO = 0 23593 UPPER = LSAME( UPLO, 'U' ) 23594 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN 23595 INFO = -1 23596 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 23597 INFO = -2 23598 ELSE IF( N.LT.0 ) THEN 23599 INFO = -3 23600 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 23601 INFO = -5 23602 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 23603 INFO = -7 23604 END IF 23605 IF( INFO.NE.0 ) THEN 23606 CALL XERBLA( 'DSYGST', -INFO ) 23607 RETURN 23608 END IF 23609 IF( N.EQ.0 ) 23610 $ RETURN 23611 NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 ) 23612 IF( NB.LE.1 .OR. NB.GE.N ) THEN 23613 CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) 23614 ELSE 23615 IF( ITYPE.EQ.1 ) THEN 23616 IF( UPPER ) THEN 23617 DO 10 K = 1, N, NB 23618 KB = MIN( N-K+1, NB ) 23619 CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, 23620 $ B( K, K ), LDB, INFO ) 23621 IF( K+KB.LE.N ) THEN 23622 CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit', 23623 $ KB, N-K-KB+1, ONE, B( K, K ), LDB, 23624 $ A( K, K+KB ), LDA ) 23625 CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, 23626 $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, 23627 $ A( K, K+KB ), LDA ) 23628 CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE, 23629 $ A( K, K+KB ), LDA, B( K, K+KB ), LDB, 23630 $ ONE, A( K+KB, K+KB ), LDA ) 23631 CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, 23632 $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, 23633 $ A( K, K+KB ), LDA ) 23634 CALL DTRSM( 'Right', UPLO, 'No transpose', 23635 $ 'Non-unit', KB, N-K-KB+1, ONE, 23636 $ B( K+KB, K+KB ), LDB, A( K, K+KB ), 23637 $ LDA ) 23638 END IF 23639 10 CONTINUE 23640 ELSE 23641 DO 20 K = 1, N, NB 23642 KB = MIN( N-K+1, NB ) 23643 CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, 23644 $ B( K, K ), LDB, INFO ) 23645 IF( K+KB.LE.N ) THEN 23646 CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit', 23647 $ N-K-KB+1, KB, ONE, B( K, K ), LDB, 23648 $ A( K+KB, K ), LDA ) 23649 CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, 23650 $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, 23651 $ A( K+KB, K ), LDA ) 23652 CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB, 23653 $ -ONE, A( K+KB, K ), LDA, B( K+KB, K ), 23654 $ LDB, ONE, A( K+KB, K+KB ), LDA ) 23655 CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, 23656 $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, 23657 $ A( K+KB, K ), LDA ) 23658 CALL DTRSM( 'Left', UPLO, 'No transpose', 23659 $ 'Non-unit', N-K-KB+1, KB, ONE, 23660 $ B( K+KB, K+KB ), LDB, A( K+KB, K ), 23661 $ LDA ) 23662 END IF 23663 20 CONTINUE 23664 END IF 23665 ELSE 23666 IF( UPPER ) THEN 23667 DO 30 K = 1, N, NB 23668 KB = MIN( N-K+1, NB ) 23669 CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', 23670 $ K-1, KB, ONE, B, LDB, A( 1, K ), LDA ) 23671 CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), 23672 $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) 23673 CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE, 23674 $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, 23675 $ LDA ) 23676 CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), 23677 $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) 23678 CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit', 23679 $ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ), 23680 $ LDA ) 23681 CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, 23682 $ B( K, K ), LDB, INFO ) 23683 30 CONTINUE 23684 ELSE 23685 DO 40 K = 1, N, NB 23686 KB = MIN( N-K+1, NB ) 23687 CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', 23688 $ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA ) 23689 CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), 23690 $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) 23691 CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE, 23692 $ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A, 23693 $ LDA ) 23694 CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), 23695 $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) 23696 CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB, 23697 $ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA ) 23698 CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, 23699 $ B( K, K ), LDB, INFO ) 23700 40 CONTINUE 23701 END IF 23702 END IF 23703 END IF 23704 RETURN 23705 END 23706! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsygv.f 23707 SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, 23708 $ LWORK, INFO ) 23709 CHARACTER JOBZ, UPLO 23710 INTEGER INFO, ITYPE, LDA, LDB, LWORK, N 23711 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) 23712 DOUBLE PRECISION ONE 23713 PARAMETER ( ONE = 1.0D+0 ) 23714 LOGICAL LQUERY, UPPER, WANTZ 23715 CHARACTER TRANS 23716 INTEGER LWKMIN, LWKOPT, NB, NEIG 23717 LOGICAL LSAME 23718 INTEGER ILAENV 23719 EXTERNAL LSAME, ILAENV 23720 EXTERNAL DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA 23721 INTRINSIC MAX 23722 WANTZ = LSAME( JOBZ, 'V' ) 23723 UPPER = LSAME( UPLO, 'U' ) 23724 LQUERY = ( LWORK.EQ.-1 ) 23725 INFO = 0 23726 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN 23727 INFO = -1 23728 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 23729 INFO = -2 23730 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN 23731 INFO = -3 23732 ELSE IF( N.LT.0 ) THEN 23733 INFO = -4 23734 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 23735 INFO = -6 23736 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 23737 INFO = -8 23738 END IF 23739 IF( INFO.EQ.0 ) THEN 23740 LWKMIN = MAX( 1, 3*N - 1 ) 23741 NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) 23742 LWKOPT = MAX( LWKMIN, ( NB + 2 )*N ) 23743 WORK( 1 ) = LWKOPT 23744 IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN 23745 INFO = -11 23746 END IF 23747 END IF 23748 IF( INFO.NE.0 ) THEN 23749 CALL XERBLA( 'DSYGV ', -INFO ) 23750 RETURN 23751 ELSE IF( LQUERY ) THEN 23752 RETURN 23753 END IF 23754 IF( N.EQ.0 ) 23755 $ RETURN 23756 CALL DPOTRF( UPLO, N, B, LDB, INFO ) 23757 IF( INFO.NE.0 ) THEN 23758 INFO = N + INFO 23759 RETURN 23760 END IF 23761 CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) 23762 CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) 23763 IF( WANTZ ) THEN 23764 NEIG = N 23765 IF( INFO.GT.0 ) 23766 $ NEIG = INFO - 1 23767 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN 23768 IF( UPPER ) THEN 23769 TRANS = 'N' 23770 ELSE 23771 TRANS = 'T' 23772 END IF 23773 CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, 23774 $ B, LDB, A, LDA ) 23775 ELSE IF( ITYPE.EQ.3 ) THEN 23776 IF( UPPER ) THEN 23777 TRANS = 'T' 23778 ELSE 23779 TRANS = 'N' 23780 END IF 23781 CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, 23782 $ B, LDB, A, LDA ) 23783 END IF 23784 END IF 23785 WORK( 1 ) = LWKOPT 23786 RETURN 23787 END 23788! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsytd2.f 23789 SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) 23790 CHARACTER UPLO 23791 INTEGER INFO, LDA, N 23792 DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) 23793 DOUBLE PRECISION ONE, ZERO, HALF 23794 PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, 23795 $ HALF = 1.0D0 / 2.0D0 ) 23796 LOGICAL UPPER 23797 INTEGER I 23798 DOUBLE PRECISION ALPHA, TAUI 23799 EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA 23800 LOGICAL LSAME 23801 DOUBLE PRECISION DDOT 23802 EXTERNAL LSAME, DDOT 23803 INTRINSIC MAX, MIN 23804 INFO = 0 23805 UPPER = LSAME( UPLO, 'U' ) 23806 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 23807 INFO = -1 23808 ELSE IF( N.LT.0 ) THEN 23809 INFO = -2 23810 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 23811 INFO = -4 23812 END IF 23813 IF( INFO.NE.0 ) THEN 23814 CALL XERBLA( 'DSYTD2', -INFO ) 23815 RETURN 23816 END IF 23817 IF( N.LE.0 ) 23818 $ RETURN 23819 IF( UPPER ) THEN 23820 DO 10 I = N - 1, 1, -1 23821 CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) 23822 E( I ) = A( I, I+1 ) 23823 IF( TAUI.NE.ZERO ) THEN 23824 A( I, I+1 ) = ONE 23825 CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, 23826 $ TAU, 1 ) 23827 ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) 23828 CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) 23829 CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, 23830 $ LDA ) 23831 A( I, I+1 ) = E( I ) 23832 END IF 23833 D( I+1 ) = A( I+1, I+1 ) 23834 TAU( I ) = TAUI 23835 10 CONTINUE 23836 D( 1 ) = A( 1, 1 ) 23837 ELSE 23838 DO 20 I = 1, N - 1 23839 CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, 23840 $ TAUI ) 23841 E( I ) = A( I+1, I ) 23842 IF( TAUI.NE.ZERO ) THEN 23843 A( I+1, I ) = ONE 23844 CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, 23845 $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) 23846 ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), 23847 $ 1 ) 23848 CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) 23849 CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, 23850 $ A( I+1, I+1 ), LDA ) 23851 A( I+1, I ) = E( I ) 23852 END IF 23853 D( I ) = A( I, I ) 23854 TAU( I ) = TAUI 23855 20 CONTINUE 23856 D( N ) = A( N, N ) 23857 END IF 23858 RETURN 23859 END 23860! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsytf2.f 23861 SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) 23862 CHARACTER UPLO 23863 INTEGER INFO, LDA, N 23864 INTEGER IPIV( * ) 23865 DOUBLE PRECISION A( LDA, * ) 23866 DOUBLE PRECISION ZERO, ONE 23867 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 23868 DOUBLE PRECISION EIGHT, SEVTEN 23869 PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) 23870 LOGICAL UPPER 23871 INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP 23872 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, 23873 $ ROWMAX, T, WK, WKM1, WKP1 23874 LOGICAL LSAME, DISNAN 23875 INTEGER IDAMAX 23876 EXTERNAL LSAME, IDAMAX, DISNAN 23877 EXTERNAL DSCAL, DSWAP, DSYR, XERBLA 23878 INTRINSIC ABS, MAX, SQRT 23879 INFO = 0 23880 UPPER = LSAME( UPLO, 'U' ) 23881 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 23882 INFO = -1 23883 ELSE IF( N.LT.0 ) THEN 23884 INFO = -2 23885 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 23886 INFO = -4 23887 END IF 23888 IF( INFO.NE.0 ) THEN 23889 CALL XERBLA( 'DSYTF2', -INFO ) 23890 RETURN 23891 END IF 23892 ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT 23893 IF( UPPER ) THEN 23894 K = N 23895 10 CONTINUE 23896 IF( K.LT.1 ) 23897 $ GO TO 70 23898 KSTEP = 1 23899 ABSAKK = ABS( A( K, K ) ) 23900 IF( K.GT.1 ) THEN 23901 IMAX = IDAMAX( K-1, A( 1, K ), 1 ) 23902 COLMAX = ABS( A( IMAX, K ) ) 23903 ELSE 23904 COLMAX = ZERO 23905 END IF 23906 IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN 23907 IF( INFO.EQ.0 ) 23908 $ INFO = K 23909 KP = K 23910 ELSE 23911 IF( ABSAKK.GE.ALPHA*COLMAX ) THEN 23912 KP = K 23913 ELSE 23914 JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA ) 23915 ROWMAX = ABS( A( IMAX, JMAX ) ) 23916 IF( IMAX.GT.1 ) THEN 23917 JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) 23918 ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) 23919 END IF 23920 IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN 23921 KP = K 23922 ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN 23923 KP = IMAX 23924 ELSE 23925 KP = IMAX 23926 KSTEP = 2 23927 END IF 23928 END IF 23929 KK = K - KSTEP + 1 23930 IF( KP.NE.KK ) THEN 23931 CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) 23932 CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), 23933 $ LDA ) 23934 T = A( KK, KK ) 23935 A( KK, KK ) = A( KP, KP ) 23936 A( KP, KP ) = T 23937 IF( KSTEP.EQ.2 ) THEN 23938 T = A( K-1, K ) 23939 A( K-1, K ) = A( KP, K ) 23940 A( KP, K ) = T 23941 END IF 23942 END IF 23943 IF( KSTEP.EQ.1 ) THEN 23944 R1 = ONE / A( K, K ) 23945 CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA ) 23946 CALL DSCAL( K-1, R1, A( 1, K ), 1 ) 23947 ELSE 23948 IF( K.GT.2 ) THEN 23949 D12 = A( K-1, K ) 23950 D22 = A( K-1, K-1 ) / D12 23951 D11 = A( K, K ) / D12 23952 T = ONE / ( D11*D22-ONE ) 23953 D12 = T / D12 23954 DO 30 J = K - 2, 1, -1 23955 WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) 23956 WK = D12*( D22*A( J, K )-A( J, K-1 ) ) 23957 DO 20 I = J, 1, -1 23958 A( I, J ) = A( I, J ) - A( I, K )*WK - 23959 $ A( I, K-1 )*WKM1 23960 20 CONTINUE 23961 A( J, K ) = WK 23962 A( J, K-1 ) = WKM1 23963 30 CONTINUE 23964 END IF 23965 END IF 23966 END IF 23967 IF( KSTEP.EQ.1 ) THEN 23968 IPIV( K ) = KP 23969 ELSE 23970 IPIV( K ) = -KP 23971 IPIV( K-1 ) = -KP 23972 END IF 23973 K = K - KSTEP 23974 GO TO 10 23975 ELSE 23976 K = 1 23977 40 CONTINUE 23978 IF( K.GT.N ) 23979 $ GO TO 70 23980 KSTEP = 1 23981 ABSAKK = ABS( A( K, K ) ) 23982 IF( K.LT.N ) THEN 23983 IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) 23984 COLMAX = ABS( A( IMAX, K ) ) 23985 ELSE 23986 COLMAX = ZERO 23987 END IF 23988 IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN 23989 IF( INFO.EQ.0 ) 23990 $ INFO = K 23991 KP = K 23992 ELSE 23993 IF( ABSAKK.GE.ALPHA*COLMAX ) THEN 23994 KP = K 23995 ELSE 23996 JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) 23997 ROWMAX = ABS( A( IMAX, JMAX ) ) 23998 IF( IMAX.LT.N ) THEN 23999 JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) 24000 ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) 24001 END IF 24002 IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN 24003 KP = K 24004 ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN 24005 KP = IMAX 24006 ELSE 24007 KP = IMAX 24008 KSTEP = 2 24009 END IF 24010 END IF 24011 KK = K + KSTEP - 1 24012 IF( KP.NE.KK ) THEN 24013 IF( KP.LT.N ) 24014 $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) 24015 CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), 24016 $ LDA ) 24017 T = A( KK, KK ) 24018 A( KK, KK ) = A( KP, KP ) 24019 A( KP, KP ) = T 24020 IF( KSTEP.EQ.2 ) THEN 24021 T = A( K+1, K ) 24022 A( K+1, K ) = A( KP, K ) 24023 A( KP, K ) = T 24024 END IF 24025 END IF 24026 IF( KSTEP.EQ.1 ) THEN 24027 IF( K.LT.N ) THEN 24028 D11 = ONE / A( K, K ) 24029 CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, 24030 $ A( K+1, K+1 ), LDA ) 24031 CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) 24032 END IF 24033 ELSE 24034 IF( K.LT.N-1 ) THEN 24035 D21 = A( K+1, K ) 24036 D11 = A( K+1, K+1 ) / D21 24037 D22 = A( K, K ) / D21 24038 T = ONE / ( D11*D22-ONE ) 24039 D21 = T / D21 24040 DO 60 J = K + 2, N 24041 WK = D21*( D11*A( J, K )-A( J, K+1 ) ) 24042 WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) 24043 DO 50 I = J, N 24044 A( I, J ) = A( I, J ) - A( I, K )*WK - 24045 $ A( I, K+1 )*WKP1 24046 50 CONTINUE 24047 A( J, K ) = WK 24048 A( J, K+1 ) = WKP1 24049 60 CONTINUE 24050 END IF 24051 END IF 24052 END IF 24053 IF( KSTEP.EQ.1 ) THEN 24054 IPIV( K ) = KP 24055 ELSE 24056 IPIV( K ) = -KP 24057 IPIV( K+1 ) = -KP 24058 END IF 24059 K = K + KSTEP 24060 GO TO 40 24061 END IF 24062 70 CONTINUE 24063 RETURN 24064 END 24065! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsytrd.f 24066 SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) 24067 CHARACTER UPLO 24068 INTEGER INFO, LDA, LWORK, N 24069 DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), 24070 $ WORK( * ) 24071 DOUBLE PRECISION ONE 24072 PARAMETER ( ONE = 1.0D+0 ) 24073 LOGICAL LQUERY, UPPER 24074 INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, 24075 $ NBMIN, NX 24076 EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA 24077 INTRINSIC MAX 24078 LOGICAL LSAME 24079 INTEGER ILAENV 24080 EXTERNAL LSAME, ILAENV 24081 INFO = 0 24082 UPPER = LSAME( UPLO, 'U' ) 24083 LQUERY = ( LWORK.EQ.-1 ) 24084 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 24085 INFO = -1 24086 ELSE IF( N.LT.0 ) THEN 24087 INFO = -2 24088 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 24089 INFO = -4 24090 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN 24091 INFO = -9 24092 END IF 24093 IF( INFO.EQ.0 ) THEN 24094 NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) 24095 LWKOPT = N*NB 24096 WORK( 1 ) = LWKOPT 24097 END IF 24098 IF( INFO.NE.0 ) THEN 24099 CALL XERBLA( 'DSYTRD', -INFO ) 24100 RETURN 24101 ELSE IF( LQUERY ) THEN 24102 RETURN 24103 END IF 24104 IF( N.EQ.0 ) THEN 24105 WORK( 1 ) = 1 24106 RETURN 24107 END IF 24108 NX = N 24109 IWS = 1 24110 IF( NB.GT.1 .AND. NB.LT.N ) THEN 24111 NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) 24112 IF( NX.LT.N ) THEN 24113 LDWORK = N 24114 IWS = LDWORK*NB 24115 IF( LWORK.LT.IWS ) THEN 24116 NB = MAX( LWORK / LDWORK, 1 ) 24117 NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) 24118 IF( NB.LT.NBMIN ) 24119 $ NX = N 24120 END IF 24121 ELSE 24122 NX = N 24123 END IF 24124 ELSE 24125 NB = 1 24126 END IF 24127 IF( UPPER ) THEN 24128 KK = N - ( ( N-NX+NB-1 ) / NB )*NB 24129 DO 20 I = N - NB + 1, KK + 1, -NB 24130 CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, 24131 $ LDWORK ) 24132 CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), 24133 $ LDA, WORK, LDWORK, ONE, A, LDA ) 24134 DO 10 J = I, I + NB - 1 24135 A( J-1, J ) = E( J-1 ) 24136 D( J ) = A( J, J ) 24137 10 CONTINUE 24138 20 CONTINUE 24139 CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) 24140 ELSE 24141 DO 40 I = 1, N - NX, NB 24142 CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), 24143 $ TAU( I ), WORK, LDWORK ) 24144 CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, 24145 $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, 24146 $ A( I+NB, I+NB ), LDA ) 24147 DO 30 J = I, I + NB - 1 24148 A( J+1, J ) = E( J ) 24149 D( J ) = A( J, J ) 24150 30 CONTINUE 24151 40 CONTINUE 24152 CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), 24153 $ TAU( I ), IINFO ) 24154 END IF 24155 WORK( 1 ) = LWKOPT 24156 RETURN 24157 END 24158! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsytrd_2stage.f 24159 SUBROUTINE DSYTRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, 24160 $ HOUS2, LHOUS2, WORK, LWORK, INFO ) 24161 IMPLICIT NONE 24162 CHARACTER VECT, UPLO 24163 INTEGER N, LDA, LWORK, LHOUS2, INFO 24164 DOUBLE PRECISION D( * ), E( * ) 24165 DOUBLE PRECISION A( LDA, * ), TAU( * ), 24166 $ HOUS2( * ), WORK( * ) 24167 LOGICAL LQUERY, UPPER, WANTQ 24168 INTEGER KD, IB, LWMIN, LHMIN, LWRK, LDAB, WPOS, ABPOS 24169 EXTERNAL XERBLA, DSYTRD_SY2SB, DSYTRD_SB2ST 24170 LOGICAL LSAME 24171 INTEGER ILAENV2STAGE 24172 EXTERNAL LSAME, ILAENV2STAGE 24173 INFO = 0 24174 WANTQ = LSAME( VECT, 'V' ) 24175 UPPER = LSAME( UPLO, 'U' ) 24176 LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS2.EQ.-1 ) 24177 KD = ILAENV2STAGE( 1, 'DSYTRD_2STAGE', VECT, N, -1, -1, -1 ) 24178 IB = ILAENV2STAGE( 2, 'DSYTRD_2STAGE', VECT, N, KD, -1, -1 ) 24179 LHMIN = ILAENV2STAGE( 3, 'DSYTRD_2STAGE', VECT, N, KD, IB, -1 ) 24180 LWMIN = ILAENV2STAGE( 4, 'DSYTRD_2STAGE', VECT, N, KD, IB, -1 ) 24181 IF( .NOT.LSAME( VECT, 'N' ) ) THEN 24182 INFO = -1 24183 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 24184 INFO = -2 24185 ELSE IF( N.LT.0 ) THEN 24186 INFO = -3 24187 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 24188 INFO = -5 24189 ELSE IF( LHOUS2.LT.LHMIN .AND. .NOT.LQUERY ) THEN 24190 INFO = -10 24191 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 24192 INFO = -12 24193 END IF 24194 IF( INFO.EQ.0 ) THEN 24195 HOUS2( 1 ) = LHMIN 24196 WORK( 1 ) = LWMIN 24197 END IF 24198 IF( INFO.NE.0 ) THEN 24199 CALL XERBLA( 'DSYTRD_2STAGE', -INFO ) 24200 RETURN 24201 ELSE IF( LQUERY ) THEN 24202 RETURN 24203 END IF 24204 IF( N.EQ.0 ) THEN 24205 WORK( 1 ) = 1 24206 RETURN 24207 END IF 24208 LDAB = KD+1 24209 LWRK = LWORK-LDAB*N 24210 ABPOS = 1 24211 WPOS = ABPOS + LDAB*N 24212 CALL DSYTRD_SY2SB( UPLO, N, KD, A, LDA, WORK( ABPOS ), LDAB, 24213 $ TAU, WORK( WPOS ), LWRK, INFO ) 24214 IF( INFO.NE.0 ) THEN 24215 CALL XERBLA( 'DSYTRD_SY2SB', -INFO ) 24216 RETURN 24217 END IF 24218 CALL DSYTRD_SB2ST( 'Y', VECT, UPLO, N, KD, 24219 $ WORK( ABPOS ), LDAB, D, E, 24220 $ HOUS2, LHOUS2, WORK( WPOS ), LWRK, INFO ) 24221 IF( INFO.NE.0 ) THEN 24222 CALL XERBLA( 'DSYTRD_SB2ST', -INFO ) 24223 RETURN 24224 END IF 24225 HOUS2( 1 ) = LHMIN 24226 WORK( 1 ) = LWMIN 24227 RETURN 24228 END 24229! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsytrd_sb2st.F 24230 SUBROUTINE DSYTRD_SB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, 24231 $ D, E, HOUS, LHOUS, WORK, LWORK, INFO ) 24232#if defined(_OPENMP) 24233 use omp_lib 24234#endif 24235 IMPLICIT NONE 24236 CHARACTER STAGE1, UPLO, VECT 24237 INTEGER N, KD, LDAB, LHOUS, LWORK, INFO 24238 DOUBLE PRECISION D( * ), E( * ) 24239 DOUBLE PRECISION AB( LDAB, * ), HOUS( * ), WORK( * ) 24240 DOUBLE PRECISION RZERO 24241 DOUBLE PRECISION ZERO, ONE 24242 PARAMETER ( RZERO = 0.0D+0, 24243 $ ZERO = 0.0D+0, 24244 $ ONE = 1.0D+0 ) 24245 LOGICAL LQUERY, WANTQ, UPPER, AFTERS1 24246 INTEGER I, M, K, IB, SWEEPID, MYID, SHIFT, STT, ST, 24247 $ ED, STIND, EDIND, BLKLASTIND, COLPT, THED, 24248 $ STEPERCOL, GRSIZ, THGRSIZ, THGRNB, THGRID, 24249 $ NBTILES, TTYPE, TID, NTHREADS, DEBUG, 24250 $ ABDPOS, ABOFDPOS, DPOS, OFDPOS, AWPOS, 24251 $ INDA, INDW, APOS, SIZEA, LDA, INDV, INDTAU, 24252 $ SIDEV, SIZETAU, LDV, LHMIN, LWMIN 24253 EXTERNAL DSB2ST_KERNELS, DLACPY, DLASET, XERBLA 24254 INTRINSIC MIN, MAX, CEILING, REAL 24255 LOGICAL LSAME 24256 INTEGER ILAENV2STAGE 24257 EXTERNAL LSAME, ILAENV2STAGE 24258 DEBUG = 0 24259 INFO = 0 24260 AFTERS1 = LSAME( STAGE1, 'Y' ) 24261 WANTQ = LSAME( VECT, 'V' ) 24262 UPPER = LSAME( UPLO, 'U' ) 24263 LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS.EQ.-1 ) 24264 IB = ILAENV2STAGE( 2, 'DSYTRD_SB2ST', VECT, N, KD, -1, -1 ) 24265 LHMIN = ILAENV2STAGE( 3, 'DSYTRD_SB2ST', VECT, N, KD, IB, -1 ) 24266 LWMIN = ILAENV2STAGE( 4, 'DSYTRD_SB2ST', VECT, N, KD, IB, -1 ) 24267 IF( .NOT.AFTERS1 .AND. .NOT.LSAME( STAGE1, 'N' ) ) THEN 24268 INFO = -1 24269 ELSE IF( .NOT.LSAME( VECT, 'N' ) ) THEN 24270 INFO = -2 24271 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 24272 INFO = -3 24273 ELSE IF( N.LT.0 ) THEN 24274 INFO = -4 24275 ELSE IF( KD.LT.0 ) THEN 24276 INFO = -5 24277 ELSE IF( LDAB.LT.(KD+1) ) THEN 24278 INFO = -7 24279 ELSE IF( LHOUS.LT.LHMIN .AND. .NOT.LQUERY ) THEN 24280 INFO = -11 24281 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 24282 INFO = -13 24283 END IF 24284 IF( INFO.EQ.0 ) THEN 24285 HOUS( 1 ) = LHMIN 24286 WORK( 1 ) = LWMIN 24287 END IF 24288 IF( INFO.NE.0 ) THEN 24289 CALL XERBLA( 'DSYTRD_SB2ST', -INFO ) 24290 RETURN 24291 ELSE IF( LQUERY ) THEN 24292 RETURN 24293 END IF 24294 IF( N.EQ.0 ) THEN 24295 HOUS( 1 ) = 1 24296 WORK( 1 ) = 1 24297 RETURN 24298 END IF 24299 LDV = KD + IB 24300 SIZETAU = 2 * N 24301 SIDEV = 2 * N 24302 INDTAU = 1 24303 INDV = INDTAU + SIZETAU 24304 LDA = 2 * KD + 1 24305 SIZEA = LDA * N 24306 INDA = 1 24307 INDW = INDA + SIZEA 24308 NTHREADS = 1 24309 TID = 0 24310 IF( UPPER ) THEN 24311 APOS = INDA + KD 24312 AWPOS = INDA 24313 DPOS = APOS + KD 24314 OFDPOS = DPOS - 1 24315 ABDPOS = KD + 1 24316 ABOFDPOS = KD 24317 ELSE 24318 APOS = INDA 24319 AWPOS = INDA + KD + 1 24320 DPOS = APOS 24321 OFDPOS = DPOS + 1 24322 ABDPOS = 1 24323 ABOFDPOS = 2 24324 ENDIF 24325 IF( KD.EQ.0 ) THEN 24326 DO 30 I = 1, N 24327 D( I ) = ( AB( ABDPOS, I ) ) 24328 30 CONTINUE 24329 DO 40 I = 1, N-1 24330 E( I ) = RZERO 24331 40 CONTINUE 24332 HOUS( 1 ) = 1 24333 WORK( 1 ) = 1 24334 RETURN 24335 END IF 24336 IF( KD.EQ.1 ) THEN 24337 DO 50 I = 1, N 24338 D( I ) = ( AB( ABDPOS, I ) ) 24339 50 CONTINUE 24340 IF( UPPER ) THEN 24341 DO 60 I = 1, N-1 24342 E( I ) = ( AB( ABOFDPOS, I+1 ) ) 24343 60 CONTINUE 24344 ELSE 24345 DO 70 I = 1, N-1 24346 E( I ) = ( AB( ABOFDPOS, I ) ) 24347 70 CONTINUE 24348 ENDIF 24349 HOUS( 1 ) = 1 24350 WORK( 1 ) = 1 24351 RETURN 24352 END IF 24353 THGRSIZ = N 24354 GRSIZ = 1 24355 SHIFT = 3 24356 NBTILES = CEILING( REAL(N)/REAL(KD) ) 24357 STEPERCOL = CEILING( REAL(SHIFT)/REAL(GRSIZ) ) 24358 THGRNB = CEILING( REAL(N-1)/REAL(THGRSIZ) ) 24359 CALL DLACPY( "A", KD+1, N, AB, LDAB, WORK( APOS ), LDA ) 24360 CALL DLASET( "A", KD, N, ZERO, ZERO, WORK( AWPOS ), LDA ) 24361#if defined(_OPENMP) 24362#endif 24363 DO 100 THGRID = 1, THGRNB 24364 STT = (THGRID-1)*THGRSIZ+1 24365 THED = MIN( (STT + THGRSIZ -1), (N-1)) 24366 DO 110 I = STT, N-1 24367 ED = MIN( I, THED ) 24368 IF( STT.GT.ED ) EXIT 24369 DO 120 M = 1, STEPERCOL 24370 ST = STT 24371 DO 130 SWEEPID = ST, ED 24372 DO 140 K = 1, GRSIZ 24373 MYID = (I-SWEEPID)*(STEPERCOL*GRSIZ) 24374 $ + (M-1)*GRSIZ + K 24375 IF ( MYID.EQ.1 ) THEN 24376 TTYPE = 1 24377 ELSE 24378 TTYPE = MOD( MYID, 2 ) + 2 24379 ENDIF 24380 IF( TTYPE.EQ.2 ) THEN 24381 COLPT = (MYID/2)*KD + SWEEPID 24382 STIND = COLPT-KD+1 24383 EDIND = MIN(COLPT,N) 24384 BLKLASTIND = COLPT 24385 ELSE 24386 COLPT = ((MYID+1)/2)*KD + SWEEPID 24387 STIND = COLPT-KD+1 24388 EDIND = MIN(COLPT,N) 24389 IF( ( STIND.GE.EDIND-1 ).AND. 24390 $ ( EDIND.EQ.N ) ) THEN 24391 BLKLASTIND = N 24392 ELSE 24393 BLKLASTIND = 0 24394 ENDIF 24395 ENDIF 24396#if defined(_OPENMP) 24397 IF( TTYPE.NE.1 ) THEN 24398 TID = OMP_GET_THREAD_NUM() 24399 CALL DSB2ST_KERNELS( UPLO, WANTQ, TTYPE, 24400 $ STIND, EDIND, SWEEPID, N, KD, IB, 24401 $ WORK ( INDA ), LDA, 24402 $ HOUS( INDV ), HOUS( INDTAU ), LDV, 24403 $ WORK( INDW + TID*KD ) ) 24404 ELSE 24405 TID = OMP_GET_THREAD_NUM() 24406 CALL DSB2ST_KERNELS( UPLO, WANTQ, TTYPE, 24407 $ STIND, EDIND, SWEEPID, N, KD, IB, 24408 $ WORK ( INDA ), LDA, 24409 $ HOUS( INDV ), HOUS( INDTAU ), LDV, 24410 $ WORK( INDW + TID*KD ) ) 24411 ENDIF 24412#else 24413 CALL DSB2ST_KERNELS( UPLO, WANTQ, TTYPE, 24414 $ STIND, EDIND, SWEEPID, N, KD, IB, 24415 $ WORK ( INDA ), LDA, 24416 $ HOUS( INDV ), HOUS( INDTAU ), LDV, 24417 $ WORK( INDW + TID*KD ) ) 24418#endif 24419 IF ( BLKLASTIND.GE.(N-1) ) THEN 24420 STT = STT + 1 24421 EXIT 24422 ENDIF 24423 140 CONTINUE 24424 130 CONTINUE 24425 120 CONTINUE 24426 110 CONTINUE 24427 100 CONTINUE 24428#if defined(_OPENMP) 24429#endif 24430 DO 150 I = 1, N 24431 D( I ) = ( WORK( DPOS+(I-1)*LDA ) ) 24432 150 CONTINUE 24433 IF( UPPER ) THEN 24434 DO 160 I = 1, N-1 24435 E( I ) = ( WORK( OFDPOS+I*LDA ) ) 24436 160 CONTINUE 24437 ELSE 24438 DO 170 I = 1, N-1 24439 E( I ) = ( WORK( OFDPOS+(I-1)*LDA ) ) 24440 170 CONTINUE 24441 ENDIF 24442 HOUS( 1 ) = LHMIN 24443 WORK( 1 ) = LWMIN 24444 RETURN 24445 END 24446 24447! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsytrd_sy2sb.f 24448 SUBROUTINE DSYTRD_SY2SB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, 24449 $ WORK, LWORK, INFO ) 24450 IMPLICIT NONE 24451 CHARACTER UPLO 24452 INTEGER INFO, LDA, LDAB, LWORK, N, KD 24453 DOUBLE PRECISION A( LDA, * ), AB( LDAB, * ), 24454 $ TAU( * ), WORK( * ) 24455 DOUBLE PRECISION RONE 24456 DOUBLE PRECISION ZERO, ONE, HALF 24457 PARAMETER ( RONE = 1.0D+0, 24458 $ ZERO = 0.0D+0, 24459 $ ONE = 1.0D+0, 24460 $ HALF = 0.5D+0 ) 24461 LOGICAL LQUERY, UPPER 24462 INTEGER I, J, IINFO, LWMIN, PN, PK, LK, 24463 $ LDT, LDW, LDS2, LDS1, 24464 $ LS2, LS1, LW, LT, 24465 $ TPOS, WPOS, S2POS, S1POS 24466 EXTERNAL XERBLA, DSYR2K, DSYMM, DGEMM, DCOPY, 24467 $ DLARFT, DGELQF, DGEQRF, DLASET 24468 INTRINSIC MIN, MAX 24469 LOGICAL LSAME 24470 INTEGER ILAENV2STAGE 24471 EXTERNAL LSAME, ILAENV2STAGE 24472 INFO = 0 24473 UPPER = LSAME( UPLO, 'U' ) 24474 LQUERY = ( LWORK.EQ.-1 ) 24475 LWMIN = ILAENV2STAGE( 4, 'DSYTRD_SY2SB', '', N, KD, -1, -1 ) 24476 24477 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 24478 INFO = -1 24479 ELSE IF( N.LT.0 ) THEN 24480 INFO = -2 24481 ELSE IF( KD.LT.0 ) THEN 24482 INFO = -3 24483 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 24484 INFO = -5 24485 ELSE IF( LDAB.LT.MAX( 1, KD+1 ) ) THEN 24486 INFO = -7 24487 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 24488 INFO = -10 24489 END IF 24490 IF( INFO.NE.0 ) THEN 24491 CALL XERBLA( 'DSYTRD_SY2SB', -INFO ) 24492 RETURN 24493 ELSE IF( LQUERY ) THEN 24494 WORK( 1 ) = LWMIN 24495 RETURN 24496 END IF 24497 IF( N.LE.KD+1 ) THEN 24498 IF( UPPER ) THEN 24499 DO 100 I = 1, N 24500 LK = MIN( KD+1, I ) 24501 CALL DCOPY( LK, A( I-LK+1, I ), 1, 24502 $ AB( KD+1-LK+1, I ), 1 ) 24503 100 CONTINUE 24504 ELSE 24505 DO 110 I = 1, N 24506 LK = MIN( KD+1, N-I+1 ) 24507 CALL DCOPY( LK, A( I, I ), 1, AB( 1, I ), 1 ) 24508 110 CONTINUE 24509 ENDIF 24510 WORK( 1 ) = 1 24511 RETURN 24512 END IF 24513 LDT = KD 24514 LDS1 = KD 24515 LT = LDT*KD 24516 LW = N*KD 24517 LS1 = LDS1*KD 24518 LS2 = LWMIN - LT - LW - LS1 24519 TPOS = 1 24520 WPOS = TPOS + LT 24521 S1POS = WPOS + LW 24522 S2POS = S1POS + LS1 24523 IF( UPPER ) THEN 24524 LDW = KD 24525 LDS2 = KD 24526 ELSE 24527 LDW = N 24528 LDS2 = N 24529 ENDIF 24530 CALL DLASET( "A", LDT, KD, ZERO, ZERO, WORK( TPOS ), LDT ) 24531 IF( UPPER ) THEN 24532 DO 10 I = 1, N - KD, KD 24533 PN = N-I-KD+1 24534 PK = MIN( N-I-KD+1, KD ) 24535 CALL DGELQF( KD, PN, A( I, I+KD ), LDA, 24536 $ TAU( I ), WORK( S2POS ), LS2, IINFO ) 24537 DO 20 J = I, I+PK-1 24538 LK = MIN( KD, N-J ) + 1 24539 CALL DCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) 24540 20 CONTINUE 24541 CALL DLASET( 'Lower', PK, PK, ZERO, ONE, 24542 $ A( I, I+KD ), LDA ) 24543 CALL DLARFT( 'Forward', 'Rowwise', PN, PK, 24544 $ A( I, I+KD ), LDA, TAU( I ), 24545 $ WORK( TPOS ), LDT ) 24546 CALL DGEMM( 'Conjugate', 'No transpose', PK, PN, PK, 24547 $ ONE, WORK( TPOS ), LDT, 24548 $ A( I, I+KD ), LDA, 24549 $ ZERO, WORK( S2POS ), LDS2 ) 24550 CALL DSYMM( 'Right', UPLO, PK, PN, 24551 $ ONE, A( I+KD, I+KD ), LDA, 24552 $ WORK( S2POS ), LDS2, 24553 $ ZERO, WORK( WPOS ), LDW ) 24554 CALL DGEMM( 'No transpose', 'Conjugate', PK, PK, PN, 24555 $ ONE, WORK( WPOS ), LDW, 24556 $ WORK( S2POS ), LDS2, 24557 $ ZERO, WORK( S1POS ), LDS1 ) 24558 CALL DGEMM( 'No transpose', 'No transpose', PK, PN, PK, 24559 $ -HALF, WORK( S1POS ), LDS1, 24560 $ A( I, I+KD ), LDA, 24561 $ ONE, WORK( WPOS ), LDW ) 24562 CALL DSYR2K( UPLO, 'Conjugate', PN, PK, 24563 $ -ONE, A( I, I+KD ), LDA, 24564 $ WORK( WPOS ), LDW, 24565 $ RONE, A( I+KD, I+KD ), LDA ) 24566 10 CONTINUE 24567 DO 30 J = N-KD+1, N 24568 LK = MIN(KD, N-J) + 1 24569 CALL DCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) 24570 30 CONTINUE 24571 ELSE 24572 DO 40 I = 1, N - KD, KD 24573 PN = N-I-KD+1 24574 PK = MIN( N-I-KD+1, KD ) 24575 CALL DGEQRF( PN, KD, A( I+KD, I ), LDA, 24576 $ TAU( I ), WORK( S2POS ), LS2, IINFO ) 24577 DO 50 J = I, I+PK-1 24578 LK = MIN( KD, N-J ) + 1 24579 CALL DCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) 24580 50 CONTINUE 24581 CALL DLASET( 'Upper', PK, PK, ZERO, ONE, 24582 $ A( I+KD, I ), LDA ) 24583 CALL DLARFT( 'Forward', 'Columnwise', PN, PK, 24584 $ A( I+KD, I ), LDA, TAU( I ), 24585 $ WORK( TPOS ), LDT ) 24586 CALL DGEMM( 'No transpose', 'No transpose', PN, PK, PK, 24587 $ ONE, A( I+KD, I ), LDA, 24588 $ WORK( TPOS ), LDT, 24589 $ ZERO, WORK( S2POS ), LDS2 ) 24590 CALL DSYMM( 'Left', UPLO, PN, PK, 24591 $ ONE, A( I+KD, I+KD ), LDA, 24592 $ WORK( S2POS ), LDS2, 24593 $ ZERO, WORK( WPOS ), LDW ) 24594 CALL DGEMM( 'Conjugate', 'No transpose', PK, PK, PN, 24595 $ ONE, WORK( S2POS ), LDS2, 24596 $ WORK( WPOS ), LDW, 24597 $ ZERO, WORK( S1POS ), LDS1 ) 24598 CALL DGEMM( 'No transpose', 'No transpose', PN, PK, PK, 24599 $ -HALF, A( I+KD, I ), LDA, 24600 $ WORK( S1POS ), LDS1, 24601 $ ONE, WORK( WPOS ), LDW ) 24602 CALL DSYR2K( UPLO, 'No transpose', PN, PK, 24603 $ -ONE, A( I+KD, I ), LDA, 24604 $ WORK( WPOS ), LDW, 24605 $ RONE, A( I+KD, I+KD ), LDA ) 24606 40 CONTINUE 24607 DO 60 J = N-KD+1, N 24608 LK = MIN(KD, N-J) + 1 24609 CALL DCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) 24610 60 CONTINUE 24611 END IF 24612 WORK( 1 ) = LWMIN 24613 RETURN 24614 END 24615! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsytrf.f 24616 SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) 24617 CHARACTER UPLO 24618 INTEGER INFO, LDA, LWORK, N 24619 INTEGER IPIV( * ) 24620 DOUBLE PRECISION A( LDA, * ), WORK( * ) 24621 LOGICAL LQUERY, UPPER 24622 INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN 24623 LOGICAL LSAME 24624 INTEGER ILAENV 24625 EXTERNAL LSAME, ILAENV 24626 EXTERNAL DLASYF, DSYTF2, XERBLA 24627 INTRINSIC MAX 24628 INFO = 0 24629 UPPER = LSAME( UPLO, 'U' ) 24630 LQUERY = ( LWORK.EQ.-1 ) 24631 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 24632 INFO = -1 24633 ELSE IF( N.LT.0 ) THEN 24634 INFO = -2 24635 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 24636 INFO = -4 24637 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN 24638 INFO = -7 24639 END IF 24640 IF( INFO.EQ.0 ) THEN 24641 NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) 24642 LWKOPT = N*NB 24643 WORK( 1 ) = LWKOPT 24644 END IF 24645 IF( INFO.NE.0 ) THEN 24646 CALL XERBLA( 'DSYTRF', -INFO ) 24647 RETURN 24648 ELSE IF( LQUERY ) THEN 24649 RETURN 24650 END IF 24651 NBMIN = 2 24652 LDWORK = N 24653 IF( NB.GT.1 .AND. NB.LT.N ) THEN 24654 IWS = LDWORK*NB 24655 IF( LWORK.LT.IWS ) THEN 24656 NB = MAX( LWORK / LDWORK, 1 ) 24657 NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) ) 24658 END IF 24659 ELSE 24660 IWS = 1 24661 END IF 24662 IF( NB.LT.NBMIN ) 24663 $ NB = N 24664 IF( UPPER ) THEN 24665 K = N 24666 10 CONTINUE 24667 IF( K.LT.1 ) 24668 $ GO TO 40 24669 IF( K.GT.NB ) THEN 24670 CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK, 24671 $ IINFO ) 24672 ELSE 24673 CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO ) 24674 KB = K 24675 END IF 24676 IF( INFO.EQ.0 .AND. IINFO.GT.0 ) 24677 $ INFO = IINFO 24678 K = K - KB 24679 GO TO 10 24680 ELSE 24681 K = 1 24682 20 CONTINUE 24683 IF( K.GT.N ) 24684 $ GO TO 40 24685 IF( K.LE.N-NB ) THEN 24686 CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ), 24687 $ WORK, LDWORK, IINFO ) 24688 ELSE 24689 CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO ) 24690 KB = N - K + 1 24691 END IF 24692 IF( INFO.EQ.0 .AND. IINFO.GT.0 ) 24693 $ INFO = IINFO + K - 1 24694 DO 30 J = K, K + KB - 1 24695 IF( IPIV( J ).GT.0 ) THEN 24696 IPIV( J ) = IPIV( J ) + K - 1 24697 ELSE 24698 IPIV( J ) = IPIV( J ) - K + 1 24699 END IF 24700 30 CONTINUE 24701 K = K + KB 24702 GO TO 20 24703 END IF 24704 40 CONTINUE 24705 WORK( 1 ) = LWKOPT 24706 RETURN 24707 END 24708! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsytri.f 24709 SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) 24710 CHARACTER UPLO 24711 INTEGER INFO, LDA, N 24712 INTEGER IPIV( * ) 24713 DOUBLE PRECISION A( LDA, * ), WORK( * ) 24714 DOUBLE PRECISION ONE, ZERO 24715 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 24716 LOGICAL UPPER 24717 INTEGER K, KP, KSTEP 24718 DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP 24719 LOGICAL LSAME 24720 DOUBLE PRECISION DDOT 24721 EXTERNAL LSAME, DDOT 24722 EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA 24723 INTRINSIC ABS, MAX 24724 INFO = 0 24725 UPPER = LSAME( UPLO, 'U' ) 24726 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 24727 INFO = -1 24728 ELSE IF( N.LT.0 ) THEN 24729 INFO = -2 24730 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 24731 INFO = -4 24732 END IF 24733 IF( INFO.NE.0 ) THEN 24734 CALL XERBLA( 'DSYTRI', -INFO ) 24735 RETURN 24736 END IF 24737 IF( N.EQ.0 ) 24738 $ RETURN 24739 IF( UPPER ) THEN 24740 DO 10 INFO = N, 1, -1 24741 IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) 24742 $ RETURN 24743 10 CONTINUE 24744 ELSE 24745 DO 20 INFO = 1, N 24746 IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) 24747 $ RETURN 24748 20 CONTINUE 24749 END IF 24750 INFO = 0 24751 IF( UPPER ) THEN 24752 K = 1 24753 30 CONTINUE 24754 IF( K.GT.N ) 24755 $ GO TO 40 24756 IF( IPIV( K ).GT.0 ) THEN 24757 A( K, K ) = ONE / A( K, K ) 24758 IF( K.GT.1 ) THEN 24759 CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) 24760 CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, 24761 $ A( 1, K ), 1 ) 24762 A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), 24763 $ 1 ) 24764 END IF 24765 KSTEP = 1 24766 ELSE 24767 T = ABS( A( K, K+1 ) ) 24768 AK = A( K, K ) / T 24769 AKP1 = A( K+1, K+1 ) / T 24770 AKKP1 = A( K, K+1 ) / T 24771 D = T*( AK*AKP1-ONE ) 24772 A( K, K ) = AKP1 / D 24773 A( K+1, K+1 ) = AK / D 24774 A( K, K+1 ) = -AKKP1 / D 24775 IF( K.GT.1 ) THEN 24776 CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) 24777 CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, 24778 $ A( 1, K ), 1 ) 24779 A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), 24780 $ 1 ) 24781 A( K, K+1 ) = A( K, K+1 ) - 24782 $ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) 24783 CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) 24784 CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, 24785 $ A( 1, K+1 ), 1 ) 24786 A( K+1, K+1 ) = A( K+1, K+1 ) - 24787 $ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 ) 24788 END IF 24789 KSTEP = 2 24790 END IF 24791 KP = ABS( IPIV( K ) ) 24792 IF( KP.NE.K ) THEN 24793 CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) 24794 CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) 24795 TEMP = A( K, K ) 24796 A( K, K ) = A( KP, KP ) 24797 A( KP, KP ) = TEMP 24798 IF( KSTEP.EQ.2 ) THEN 24799 TEMP = A( K, K+1 ) 24800 A( K, K+1 ) = A( KP, K+1 ) 24801 A( KP, K+1 ) = TEMP 24802 END IF 24803 END IF 24804 K = K + KSTEP 24805 GO TO 30 24806 40 CONTINUE 24807 ELSE 24808 K = N 24809 50 CONTINUE 24810 IF( K.LT.1 ) 24811 $ GO TO 60 24812 IF( IPIV( K ).GT.0 ) THEN 24813 A( K, K ) = ONE / A( K, K ) 24814 IF( K.LT.N ) THEN 24815 CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) 24816 CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, 24817 $ ZERO, A( K+1, K ), 1 ) 24818 A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), 24819 $ 1 ) 24820 END IF 24821 KSTEP = 1 24822 ELSE 24823 T = ABS( A( K, K-1 ) ) 24824 AK = A( K-1, K-1 ) / T 24825 AKP1 = A( K, K ) / T 24826 AKKP1 = A( K, K-1 ) / T 24827 D = T*( AK*AKP1-ONE ) 24828 A( K-1, K-1 ) = AKP1 / D 24829 A( K, K ) = AK / D 24830 A( K, K-1 ) = -AKKP1 / D 24831 IF( K.LT.N ) THEN 24832 CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) 24833 CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, 24834 $ ZERO, A( K+1, K ), 1 ) 24835 A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), 24836 $ 1 ) 24837 A( K, K-1 ) = A( K, K-1 ) - 24838 $ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), 24839 $ 1 ) 24840 CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) 24841 CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, 24842 $ ZERO, A( K+1, K-1 ), 1 ) 24843 A( K-1, K-1 ) = A( K-1, K-1 ) - 24844 $ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 ) 24845 END IF 24846 KSTEP = 2 24847 END IF 24848 KP = ABS( IPIV( K ) ) 24849 IF( KP.NE.K ) THEN 24850 IF( KP.LT.N ) 24851 $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) 24852 CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) 24853 TEMP = A( K, K ) 24854 A( K, K ) = A( KP, KP ) 24855 A( KP, KP ) = TEMP 24856 IF( KSTEP.EQ.2 ) THEN 24857 TEMP = A( K, K-1 ) 24858 A( K, K-1 ) = A( KP, K-1 ) 24859 A( KP, K-1 ) = TEMP 24860 END IF 24861 END IF 24862 K = K - KSTEP 24863 GO TO 50 24864 60 CONTINUE 24865 END IF 24866 RETURN 24867 END 24868! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dsytrs.f 24869 SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 24870 CHARACTER UPLO 24871 INTEGER INFO, LDA, LDB, N, NRHS 24872 INTEGER IPIV( * ) 24873 DOUBLE PRECISION A( LDA, * ), B( LDB, * ) 24874 DOUBLE PRECISION ONE 24875 PARAMETER ( ONE = 1.0D+0 ) 24876 LOGICAL UPPER 24877 INTEGER J, K, KP 24878 DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM 24879 LOGICAL LSAME 24880 EXTERNAL LSAME 24881 EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA 24882 INTRINSIC MAX 24883 INFO = 0 24884 UPPER = LSAME( UPLO, 'U' ) 24885 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 24886 INFO = -1 24887 ELSE IF( N.LT.0 ) THEN 24888 INFO = -2 24889 ELSE IF( NRHS.LT.0 ) THEN 24890 INFO = -3 24891 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 24892 INFO = -5 24893 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 24894 INFO = -8 24895 END IF 24896 IF( INFO.NE.0 ) THEN 24897 CALL XERBLA( 'DSYTRS', -INFO ) 24898 RETURN 24899 END IF 24900 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 24901 $ RETURN 24902 IF( UPPER ) THEN 24903 K = N 24904 10 CONTINUE 24905 IF( K.LT.1 ) 24906 $ GO TO 30 24907 IF( IPIV( K ).GT.0 ) THEN 24908 KP = IPIV( K ) 24909 IF( KP.NE.K ) 24910 $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 24911 CALL DGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 24912 $ B( 1, 1 ), LDB ) 24913 CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) 24914 K = K - 1 24915 ELSE 24916 KP = -IPIV( K ) 24917 IF( KP.NE.K-1 ) 24918 $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) 24919 CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 24920 $ B( 1, 1 ), LDB ) 24921 CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), 24922 $ LDB, B( 1, 1 ), LDB ) 24923 AKM1K = A( K-1, K ) 24924 AKM1 = A( K-1, K-1 ) / AKM1K 24925 AK = A( K, K ) / AKM1K 24926 DENOM = AKM1*AK - ONE 24927 DO 20 J = 1, NRHS 24928 BKM1 = B( K-1, J ) / AKM1K 24929 BK = B( K, J ) / AKM1K 24930 B( K-1, J ) = ( AK*BKM1-BK ) / DENOM 24931 B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM 24932 20 CONTINUE 24933 K = K - 2 24934 END IF 24935 GO TO 10 24936 30 CONTINUE 24937 K = 1 24938 40 CONTINUE 24939 IF( K.GT.N ) 24940 $ GO TO 50 24941 IF( IPIV( K ).GT.0 ) THEN 24942 CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), 24943 $ 1, ONE, B( K, 1 ), LDB ) 24944 KP = IPIV( K ) 24945 IF( KP.NE.K ) 24946 $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 24947 K = K + 1 24948 ELSE 24949 CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), 24950 $ 1, ONE, B( K, 1 ), LDB ) 24951 CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, 24952 $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) 24953 KP = -IPIV( K ) 24954 IF( KP.NE.K ) 24955 $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 24956 K = K + 2 24957 END IF 24958 GO TO 40 24959 50 CONTINUE 24960 ELSE 24961 K = 1 24962 60 CONTINUE 24963 IF( K.GT.N ) 24964 $ GO TO 80 24965 IF( IPIV( K ).GT.0 ) THEN 24966 KP = IPIV( K ) 24967 IF( KP.NE.K ) 24968 $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 24969 IF( K.LT.N ) 24970 $ CALL DGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), 24971 $ LDB, B( K+1, 1 ), LDB ) 24972 CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) 24973 K = K + 1 24974 ELSE 24975 KP = -IPIV( K ) 24976 IF( KP.NE.K+1 ) 24977 $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) 24978 IF( K.LT.N-1 ) THEN 24979 CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), 24980 $ LDB, B( K+2, 1 ), LDB ) 24981 CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, 24982 $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) 24983 END IF 24984 AKM1K = A( K+1, K ) 24985 AKM1 = A( K, K ) / AKM1K 24986 AK = A( K+1, K+1 ) / AKM1K 24987 DENOM = AKM1*AK - ONE 24988 DO 70 J = 1, NRHS 24989 BKM1 = B( K, J ) / AKM1K 24990 BK = B( K+1, J ) / AKM1K 24991 B( K, J ) = ( AK*BKM1-BK ) / DENOM 24992 B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM 24993 70 CONTINUE 24994 K = K + 2 24995 END IF 24996 GO TO 60 24997 80 CONTINUE 24998 K = N 24999 90 CONTINUE 25000 IF( K.LT.1 ) 25001 $ GO TO 100 25002 IF( IPIV( K ).GT.0 ) THEN 25003 IF( K.LT.N ) 25004 $ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 25005 $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) 25006 KP = IPIV( K ) 25007 IF( KP.NE.K ) 25008 $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 25009 K = K - 1 25010 ELSE 25011 IF( K.LT.N ) THEN 25012 CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 25013 $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) 25014 CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 25015 $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), 25016 $ LDB ) 25017 END IF 25018 KP = -IPIV( K ) 25019 IF( KP.NE.K ) 25020 $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 25021 K = K - 2 25022 END IF 25023 GO TO 90 25024 100 CONTINUE 25025 END IF 25026 RETURN 25027 END 25028! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dtrti2.f 25029 SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) 25030 CHARACTER DIAG, UPLO 25031 INTEGER INFO, LDA, N 25032 DOUBLE PRECISION A( LDA, * ) 25033 DOUBLE PRECISION ONE 25034 PARAMETER ( ONE = 1.0D+0 ) 25035 LOGICAL NOUNIT, UPPER 25036 INTEGER J 25037 DOUBLE PRECISION AJJ 25038 LOGICAL LSAME 25039 EXTERNAL LSAME 25040 EXTERNAL DSCAL, DTRMV, XERBLA 25041 INTRINSIC MAX 25042 INFO = 0 25043 UPPER = LSAME( UPLO, 'U' ) 25044 NOUNIT = LSAME( DIAG, 'N' ) 25045 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 25046 INFO = -1 25047 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN 25048 INFO = -2 25049 ELSE IF( N.LT.0 ) THEN 25050 INFO = -3 25051 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 25052 INFO = -5 25053 END IF 25054 IF( INFO.NE.0 ) THEN 25055 CALL XERBLA( 'DTRTI2', -INFO ) 25056 RETURN 25057 END IF 25058 IF( UPPER ) THEN 25059 DO 10 J = 1, N 25060 IF( NOUNIT ) THEN 25061 A( J, J ) = ONE / A( J, J ) 25062 AJJ = -A( J, J ) 25063 ELSE 25064 AJJ = -ONE 25065 END IF 25066 CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, 25067 $ A( 1, J ), 1 ) 25068 CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) 25069 10 CONTINUE 25070 ELSE 25071 DO 20 J = N, 1, -1 25072 IF( NOUNIT ) THEN 25073 A( J, J ) = ONE / A( J, J ) 25074 AJJ = -A( J, J ) 25075 ELSE 25076 AJJ = -ONE 25077 END IF 25078 IF( J.LT.N ) THEN 25079 CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, 25080 $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) 25081 CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) 25082 END IF 25083 20 CONTINUE 25084 END IF 25085 RETURN 25086 END 25087! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dtrtri.f 25088 SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) 25089 CHARACTER DIAG, UPLO 25090 INTEGER INFO, LDA, N 25091 DOUBLE PRECISION A( LDA, * ) 25092 DOUBLE PRECISION ONE, ZERO 25093 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 25094 LOGICAL NOUNIT, UPPER 25095 INTEGER J, JB, NB, NN 25096 LOGICAL LSAME 25097 INTEGER ILAENV 25098 EXTERNAL LSAME, ILAENV 25099 EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA 25100 INTRINSIC MAX, MIN 25101 INFO = 0 25102 UPPER = LSAME( UPLO, 'U' ) 25103 NOUNIT = LSAME( DIAG, 'N' ) 25104 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 25105 INFO = -1 25106 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN 25107 INFO = -2 25108 ELSE IF( N.LT.0 ) THEN 25109 INFO = -3 25110 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 25111 INFO = -5 25112 END IF 25113 IF( INFO.NE.0 ) THEN 25114 CALL XERBLA( 'DTRTRI', -INFO ) 25115 RETURN 25116 END IF 25117 IF( N.EQ.0 ) 25118 $ RETURN 25119 IF( NOUNIT ) THEN 25120 DO 10 INFO = 1, N 25121 IF( A( INFO, INFO ).EQ.ZERO ) 25122 $ RETURN 25123 10 CONTINUE 25124 INFO = 0 25125 END IF 25126 NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) 25127 IF( NB.LE.1 .OR. NB.GE.N ) THEN 25128 CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) 25129 ELSE 25130 IF( UPPER ) THEN 25131 DO 20 J = 1, N, NB 25132 JB = MIN( NB, N-J+1 ) 25133 CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, 25134 $ JB, ONE, A, LDA, A( 1, J ), LDA ) 25135 CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, 25136 $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) 25137 CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) 25138 20 CONTINUE 25139 ELSE 25140 NN = ( ( N-1 ) / NB )*NB + 1 25141 DO 30 J = NN, 1, -NB 25142 JB = MIN( NB, N-J+1 ) 25143 IF( J+JB.LE.N ) THEN 25144 CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, 25145 $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, 25146 $ A( J+JB, J ), LDA ) 25147 CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, 25148 $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, 25149 $ A( J+JB, J ), LDA ) 25150 END IF 25151 CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) 25152 30 CONTINUE 25153 END IF 25154 END IF 25155 RETURN 25156 END 25157! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dtrtrs.f 25158 SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, 25159 $ INFO ) 25160 CHARACTER DIAG, TRANS, UPLO 25161 INTEGER INFO, LDA, LDB, N, NRHS 25162 DOUBLE PRECISION A( LDA, * ), B( LDB, * ) 25163 DOUBLE PRECISION ZERO, ONE 25164 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 25165 LOGICAL NOUNIT 25166 LOGICAL LSAME 25167 EXTERNAL LSAME 25168 EXTERNAL DTRSM, XERBLA 25169 INTRINSIC MAX 25170 INFO = 0 25171 NOUNIT = LSAME( DIAG, 'N' ) 25172 IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 25173 INFO = -1 25174 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. 25175 $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN 25176 INFO = -2 25177 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN 25178 INFO = -3 25179 ELSE IF( N.LT.0 ) THEN 25180 INFO = -4 25181 ELSE IF( NRHS.LT.0 ) THEN 25182 INFO = -5 25183 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 25184 INFO = -7 25185 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 25186 INFO = -9 25187 END IF 25188 IF( INFO.NE.0 ) THEN 25189 CALL XERBLA( 'DTRTRS', -INFO ) 25190 RETURN 25191 END IF 25192 IF( N.EQ.0 ) 25193 $ RETURN 25194 IF( NOUNIT ) THEN 25195 DO 10 INFO = 1, N 25196 IF( A( INFO, INFO ).EQ.ZERO ) 25197 $ RETURN 25198 10 CONTINUE 25199 END IF 25200 INFO = 0 25201 CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B, 25202 $ LDB ) 25203 RETURN 25204 END 25205! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/dzsum1.f 25206 DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) 25207 INTEGER INCX, N 25208 COMPLEX*16 CX( * ) 25209 INTEGER I, NINCX 25210 DOUBLE PRECISION STEMP 25211 INTRINSIC ABS 25212 DZSUM1 = 0.0D0 25213 STEMP = 0.0D0 25214 IF( N.LE.0 ) 25215 $ RETURN 25216 IF( INCX.EQ.1 ) 25217 $ GO TO 20 25218 NINCX = N*INCX 25219 DO 10 I = 1, NINCX, INCX 25220 STEMP = STEMP + ABS( CX( I ) ) 25221 10 CONTINUE 25222 DZSUM1 = STEMP 25223 RETURN 25224 20 CONTINUE 25225 DO 30 I = 1, N 25226 STEMP = STEMP + ABS( CX( I ) ) 25227 30 CONTINUE 25228 DZSUM1 = STEMP 25229 RETURN 25230 END 25231! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/icmax1.f 25232 INTEGER FUNCTION ICMAX1( N, CX, INCX ) 25233 INTEGER INCX, N 25234 COMPLEX CX(*) 25235 REAL SMAX 25236 INTEGER I, IX 25237 INTRINSIC ABS 25238 ICMAX1 = 0 25239 IF (N.LT.1 .OR. INCX.LE.0) RETURN 25240 ICMAX1 = 1 25241 IF (N.EQ.1) RETURN 25242 IF (INCX.EQ.1) THEN 25243 SMAX = ABS(CX(1)) 25244 DO I = 2,N 25245 IF (ABS(CX(I)).GT.SMAX) THEN 25246 ICMAX1 = I 25247 SMAX = ABS(CX(I)) 25248 END IF 25249 END DO 25250 ELSE 25251 IX = 1 25252 SMAX = ABS(CX(1)) 25253 IX = IX + INCX 25254 DO I = 2,N 25255 IF (ABS(CX(IX)).GT.SMAX) THEN 25256 ICMAX1 = I 25257 SMAX = ABS(CX(IX)) 25258 END IF 25259 IX = IX + INCX 25260 END DO 25261 END IF 25262 RETURN 25263 END 25264! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ieeeck.f 25265 INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) 25266 INTEGER ISPEC 25267 REAL ONE, ZERO 25268 REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, 25269 $ NEGZRO, NEWZRO, POSINF 25270 IEEECK = 1 25271 POSINF = ONE / ZERO 25272 IF( POSINF.LE.ONE ) THEN 25273 IEEECK = 0 25274 RETURN 25275 END IF 25276 NEGINF = -ONE / ZERO 25277 IF( NEGINF.GE.ZERO ) THEN 25278 IEEECK = 0 25279 RETURN 25280 END IF 25281 NEGZRO = ONE / ( NEGINF+ONE ) 25282 IF( NEGZRO.NE.ZERO ) THEN 25283 IEEECK = 0 25284 RETURN 25285 END IF 25286 NEGINF = ONE / NEGZRO 25287 IF( NEGINF.GE.ZERO ) THEN 25288 IEEECK = 0 25289 RETURN 25290 END IF 25291 NEWZRO = NEGZRO + ZERO 25292 IF( NEWZRO.NE.ZERO ) THEN 25293 IEEECK = 0 25294 RETURN 25295 END IF 25296 POSINF = ONE / NEWZRO 25297 IF( POSINF.LE.ONE ) THEN 25298 IEEECK = 0 25299 RETURN 25300 END IF 25301 NEGINF = NEGINF*POSINF 25302 IF( NEGINF.GE.ZERO ) THEN 25303 IEEECK = 0 25304 RETURN 25305 END IF 25306 POSINF = POSINF*POSINF 25307 IF( POSINF.LE.ONE ) THEN 25308 IEEECK = 0 25309 RETURN 25310 END IF 25311 IF( ISPEC.EQ.0 ) 25312 $ RETURN 25313 NAN1 = POSINF + NEGINF 25314 NAN2 = POSINF / NEGINF 25315 NAN3 = POSINF / POSINF 25316 NAN4 = POSINF*ZERO 25317 NAN5 = NEGINF*NEGZRO 25318 NAN6 = NAN5*ZERO 25319 IF( NAN1.EQ.NAN1 ) THEN 25320 IEEECK = 0 25321 RETURN 25322 END IF 25323 IF( NAN2.EQ.NAN2 ) THEN 25324 IEEECK = 0 25325 RETURN 25326 END IF 25327 IF( NAN3.EQ.NAN3 ) THEN 25328 IEEECK = 0 25329 RETURN 25330 END IF 25331 IF( NAN4.EQ.NAN4 ) THEN 25332 IEEECK = 0 25333 RETURN 25334 END IF 25335 IF( NAN5.EQ.NAN5 ) THEN 25336 IEEECK = 0 25337 RETURN 25338 END IF 25339 IF( NAN6.EQ.NAN6 ) THEN 25340 IEEECK = 0 25341 RETURN 25342 END IF 25343 RETURN 25344 END 25345! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ilaclc.f 25346 INTEGER FUNCTION ILACLC( M, N, A, LDA ) 25347 INTEGER M, N, LDA 25348 COMPLEX A( LDA, * ) 25349 COMPLEX ZERO 25350 PARAMETER ( ZERO = (0.0E+0, 0.0E+0) ) 25351 INTEGER I 25352 IF( N.EQ.0 ) THEN 25353 ILACLC = N 25354 ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN 25355 ILACLC = N 25356 ELSE 25357 DO ILACLC = N, 1, -1 25358 DO I = 1, M 25359 IF( A(I, ILACLC).NE.ZERO ) RETURN 25360 END DO 25361 END DO 25362 END IF 25363 RETURN 25364 END 25365! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ilaclr.f 25366 INTEGER FUNCTION ILACLR( M, N, A, LDA ) 25367 INTEGER M, N, LDA 25368 COMPLEX A( LDA, * ) 25369 COMPLEX ZERO 25370 PARAMETER ( ZERO = (0.0E+0, 0.0E+0) ) 25371 INTEGER I, J 25372 IF( M.EQ.0 ) THEN 25373 ILACLR = M 25374 ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN 25375 ILACLR = M 25376 ELSE 25377 ILACLR = 0 25378 DO J = 1, N 25379 I=M 25380 DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) 25381 I=I-1 25382 ENDDO 25383 ILACLR = MAX( ILACLR, I ) 25384 END DO 25385 END IF 25386 RETURN 25387 END 25388! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/iladiag.f 25389 INTEGER FUNCTION ILADIAG( DIAG ) 25390 CHARACTER DIAG 25391 INTEGER BLAS_NON_UNIT_DIAG, BLAS_UNIT_DIAG 25392 PARAMETER ( BLAS_NON_UNIT_DIAG = 131, BLAS_UNIT_DIAG = 132 ) 25393 LOGICAL LSAME 25394 EXTERNAL LSAME 25395 IF( LSAME( DIAG, 'N' ) ) THEN 25396 ILADIAG = BLAS_NON_UNIT_DIAG 25397 ELSE IF( LSAME( DIAG, 'U' ) ) THEN 25398 ILADIAG = BLAS_UNIT_DIAG 25399 ELSE 25400 ILADIAG = -1 25401 END IF 25402 RETURN 25403 END 25404! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/iladlc.f 25405 INTEGER FUNCTION ILADLC( M, N, A, LDA ) 25406 INTEGER M, N, LDA 25407 DOUBLE PRECISION A( LDA, * ) 25408 DOUBLE PRECISION ZERO 25409 PARAMETER ( ZERO = 0.0D+0 ) 25410 INTEGER I 25411 IF( N.EQ.0 ) THEN 25412 ILADLC = N 25413 ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN 25414 ILADLC = N 25415 ELSE 25416 DO ILADLC = N, 1, -1 25417 DO I = 1, M 25418 IF( A(I, ILADLC).NE.ZERO ) RETURN 25419 END DO 25420 END DO 25421 END IF 25422 RETURN 25423 END 25424! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/iladlr.f 25425 INTEGER FUNCTION ILADLR( M, N, A, LDA ) 25426 INTEGER M, N, LDA 25427 DOUBLE PRECISION A( LDA, * ) 25428 DOUBLE PRECISION ZERO 25429 PARAMETER ( ZERO = 0.0D+0 ) 25430 INTEGER I, J 25431 IF( M.EQ.0 ) THEN 25432 ILADLR = M 25433 ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN 25434 ILADLR = M 25435 ELSE 25436 ILADLR = 0 25437 DO J = 1, N 25438 I=M 25439 DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) 25440 I=I-1 25441 ENDDO 25442 ILADLR = MAX( ILADLR, I ) 25443 END DO 25444 END IF 25445 RETURN 25446 END 25447! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ilaenv.f 25448 INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) 25449 CHARACTER*( * ) NAME, OPTS 25450 INTEGER ISPEC, N1, N2, N3, N4 25451 INTEGER I, IC, IZ, NB, NBMIN, NX 25452 LOGICAL CNAME, SNAME, TWOSTAGE 25453 CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*16 25454 INTRINSIC CHAR, ICHAR, INT, MIN, REAL 25455 INTEGER IEEECK, IPARMQ, IPARAM2STAGE 25456 EXTERNAL IEEECK, IPARMQ, IPARAM2STAGE 25457 GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, 25458 $ 130, 140, 150, 160, 160, 160, 160, 160)ISPEC 25459 ILAENV = -1 25460 RETURN 25461 10 CONTINUE 25462 ILAENV = 1 25463 SUBNAM = NAME 25464 IC = ICHAR( SUBNAM( 1: 1 ) ) 25465 IZ = ICHAR( 'Z' ) 25466 IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN 25467 IF( IC.GE.97 .AND. IC.LE.122 ) THEN 25468 SUBNAM( 1: 1 ) = CHAR( IC-32 ) 25469 DO 20 I = 2, 6 25470 IC = ICHAR( SUBNAM( I: I ) ) 25471 IF( IC.GE.97 .AND. IC.LE.122 ) 25472 $ SUBNAM( I: I ) = CHAR( IC-32 ) 25473 20 CONTINUE 25474 END IF 25475 ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN 25476 IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. 25477 $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. 25478 $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN 25479 SUBNAM( 1: 1 ) = CHAR( IC+64 ) 25480 DO 30 I = 2, 6 25481 IC = ICHAR( SUBNAM( I: I ) ) 25482 IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. 25483 $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. 25484 $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: 25485 $ I ) = CHAR( IC+64 ) 25486 30 CONTINUE 25487 END IF 25488 ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN 25489 IF( IC.GE.225 .AND. IC.LE.250 ) THEN 25490 SUBNAM( 1: 1 ) = CHAR( IC-32 ) 25491 DO 40 I = 2, 6 25492 IC = ICHAR( SUBNAM( I: I ) ) 25493 IF( IC.GE.225 .AND. IC.LE.250 ) 25494 $ SUBNAM( I: I ) = CHAR( IC-32 ) 25495 40 CONTINUE 25496 END IF 25497 END IF 25498 C1 = SUBNAM( 1: 1 ) 25499 SNAME = C1.EQ.'S' .OR. C1.EQ.'D' 25500 CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' 25501 IF( .NOT.( CNAME .OR. SNAME ) ) 25502 $ RETURN 25503 C2 = SUBNAM( 2: 3 ) 25504 C3 = SUBNAM( 4: 6 ) 25505 C4 = C3( 2: 3 ) 25506 TWOSTAGE = LEN( SUBNAM ).GE.11 25507 $ .AND. SUBNAM( 11: 11 ).EQ.'2' 25508 GO TO ( 50, 60, 70 )ISPEC 25509 50 CONTINUE 25510 NB = 1 25511 IF( SUBNAM(2:6).EQ.'LAORH' ) THEN 25512 IF( SNAME ) THEN 25513 NB = 32 25514 ELSE 25515 NB = 32 25516 END IF 25517 ELSE IF( C2.EQ.'GE' ) THEN 25518 IF( C3.EQ.'TRF' ) THEN 25519 IF( SNAME ) THEN 25520 NB = 64 25521 ELSE 25522 NB = 64 25523 END IF 25524 ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. 25525 $ C3.EQ.'QLF' ) THEN 25526 IF( SNAME ) THEN 25527 NB = 32 25528 ELSE 25529 NB = 32 25530 END IF 25531 ELSE IF( C3.EQ.'QR ') THEN 25532 IF( N3 .EQ. 1) THEN 25533 IF( SNAME ) THEN 25534 IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN 25535 NB = N1 25536 ELSE 25537 NB = 32768/N2 25538 END IF 25539 ELSE 25540 IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN 25541 NB = N1 25542 ELSE 25543 NB = 32768/N2 25544 END IF 25545 END IF 25546 ELSE 25547 IF( SNAME ) THEN 25548 NB = 1 25549 ELSE 25550 NB = 1 25551 END IF 25552 END IF 25553 ELSE IF( C3.EQ.'LQ ') THEN 25554 IF( N3 .EQ. 2) THEN 25555 IF( SNAME ) THEN 25556 IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN 25557 NB = N1 25558 ELSE 25559 NB = 32768/N2 25560 END IF 25561 ELSE 25562 IF ((N1*N2.LE.131072).OR.(N1.LE.8192)) THEN 25563 NB = N1 25564 ELSE 25565 NB = 32768/N2 25566 END IF 25567 END IF 25568 ELSE 25569 IF( SNAME ) THEN 25570 NB = 1 25571 ELSE 25572 NB = 1 25573 END IF 25574 END IF 25575 ELSE IF( C3.EQ.'HRD' ) THEN 25576 IF( SNAME ) THEN 25577 NB = 32 25578 ELSE 25579 NB = 32 25580 END IF 25581 ELSE IF( C3.EQ.'BRD' ) THEN 25582 IF( SNAME ) THEN 25583 NB = 32 25584 ELSE 25585 NB = 32 25586 END IF 25587 ELSE IF( C3.EQ.'TRI' ) THEN 25588 IF( SNAME ) THEN 25589 NB = 64 25590 ELSE 25591 NB = 64 25592 END IF 25593 END IF 25594 ELSE IF( C2.EQ.'PO' ) THEN 25595 IF( C3.EQ.'TRF' ) THEN 25596 IF( SNAME ) THEN 25597 NB = 64 25598 ELSE 25599 NB = 64 25600 END IF 25601 END IF 25602 ELSE IF( C2.EQ.'SY' ) THEN 25603 IF( C3.EQ.'TRF' ) THEN 25604 IF( SNAME ) THEN 25605 IF( TWOSTAGE ) THEN 25606 NB = 192 25607 ELSE 25608 NB = 64 25609 END IF 25610 ELSE 25611 IF( TWOSTAGE ) THEN 25612 NB = 192 25613 ELSE 25614 NB = 64 25615 END IF 25616 END IF 25617 ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN 25618 NB = 32 25619 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN 25620 NB = 64 25621 END IF 25622 ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN 25623 IF( C3.EQ.'TRF' ) THEN 25624 IF( TWOSTAGE ) THEN 25625 NB = 192 25626 ELSE 25627 NB = 64 25628 END IF 25629 ELSE IF( C3.EQ.'TRD' ) THEN 25630 NB = 32 25631 ELSE IF( C3.EQ.'GST' ) THEN 25632 NB = 64 25633 END IF 25634 ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN 25635 IF( C3( 1: 1 ).EQ.'G' ) THEN 25636 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. 25637 $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) 25638 $ THEN 25639 NB = 32 25640 END IF 25641 ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN 25642 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. 25643 $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) 25644 $ THEN 25645 NB = 32 25646 END IF 25647 END IF 25648 ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN 25649 IF( C3( 1: 1 ).EQ.'G' ) THEN 25650 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. 25651 $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) 25652 $ THEN 25653 NB = 32 25654 END IF 25655 ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN 25656 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. 25657 $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) 25658 $ THEN 25659 NB = 32 25660 END IF 25661 END IF 25662 ELSE IF( C2.EQ.'GB' ) THEN 25663 IF( C3.EQ.'TRF' ) THEN 25664 IF( SNAME ) THEN 25665 IF( N4.LE.64 ) THEN 25666 NB = 1 25667 ELSE 25668 NB = 32 25669 END IF 25670 ELSE 25671 IF( N4.LE.64 ) THEN 25672 NB = 1 25673 ELSE 25674 NB = 32 25675 END IF 25676 END IF 25677 END IF 25678 ELSE IF( C2.EQ.'PB' ) THEN 25679 IF( C3.EQ.'TRF' ) THEN 25680 IF( SNAME ) THEN 25681 IF( N2.LE.64 ) THEN 25682 NB = 1 25683 ELSE 25684 NB = 32 25685 END IF 25686 ELSE 25687 IF( N2.LE.64 ) THEN 25688 NB = 1 25689 ELSE 25690 NB = 32 25691 END IF 25692 END IF 25693 END IF 25694 ELSE IF( C2.EQ.'TR' ) THEN 25695 IF( C3.EQ.'TRI' ) THEN 25696 IF( SNAME ) THEN 25697 NB = 64 25698 ELSE 25699 NB = 64 25700 END IF 25701 ELSE IF ( C3.EQ.'EVC' ) THEN 25702 IF( SNAME ) THEN 25703 NB = 64 25704 ELSE 25705 NB = 64 25706 END IF 25707 END IF 25708 ELSE IF( C2.EQ.'LA' ) THEN 25709 IF( C3.EQ.'UUM' ) THEN 25710 IF( SNAME ) THEN 25711 NB = 64 25712 ELSE 25713 NB = 64 25714 END IF 25715 END IF 25716 ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN 25717 IF( C3.EQ.'EBZ' ) THEN 25718 NB = 1 25719 END IF 25720 ELSE IF( C2.EQ.'GG' ) THEN 25721 NB = 32 25722 IF( C3.EQ.'HD3' ) THEN 25723 IF( SNAME ) THEN 25724 NB = 32 25725 ELSE 25726 NB = 32 25727 END IF 25728 END IF 25729 END IF 25730 ILAENV = NB 25731 RETURN 25732 60 CONTINUE 25733 NBMIN = 2 25734 IF( C2.EQ.'GE' ) THEN 25735 IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. 25736 $ 'QLF' ) THEN 25737 IF( SNAME ) THEN 25738 NBMIN = 2 25739 ELSE 25740 NBMIN = 2 25741 END IF 25742 ELSE IF( C3.EQ.'HRD' ) THEN 25743 IF( SNAME ) THEN 25744 NBMIN = 2 25745 ELSE 25746 NBMIN = 2 25747 END IF 25748 ELSE IF( C3.EQ.'BRD' ) THEN 25749 IF( SNAME ) THEN 25750 NBMIN = 2 25751 ELSE 25752 NBMIN = 2 25753 END IF 25754 ELSE IF( C3.EQ.'TRI' ) THEN 25755 IF( SNAME ) THEN 25756 NBMIN = 2 25757 ELSE 25758 NBMIN = 2 25759 END IF 25760 END IF 25761 ELSE IF( C2.EQ.'SY' ) THEN 25762 IF( C3.EQ.'TRF' ) THEN 25763 IF( SNAME ) THEN 25764 NBMIN = 8 25765 ELSE 25766 NBMIN = 8 25767 END IF 25768 ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN 25769 NBMIN = 2 25770 END IF 25771 ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN 25772 IF( C3.EQ.'TRD' ) THEN 25773 NBMIN = 2 25774 END IF 25775 ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN 25776 IF( C3( 1: 1 ).EQ.'G' ) THEN 25777 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. 25778 $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) 25779 $ THEN 25780 NBMIN = 2 25781 END IF 25782 ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN 25783 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. 25784 $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) 25785 $ THEN 25786 NBMIN = 2 25787 END IF 25788 END IF 25789 ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN 25790 IF( C3( 1: 1 ).EQ.'G' ) THEN 25791 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. 25792 $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) 25793 $ THEN 25794 NBMIN = 2 25795 END IF 25796 ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN 25797 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. 25798 $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) 25799 $ THEN 25800 NBMIN = 2 25801 END IF 25802 END IF 25803 ELSE IF( C2.EQ.'GG' ) THEN 25804 NBMIN = 2 25805 IF( C3.EQ.'HD3' ) THEN 25806 NBMIN = 2 25807 END IF 25808 END IF 25809 ILAENV = NBMIN 25810 RETURN 25811 70 CONTINUE 25812 NX = 0 25813 IF( C2.EQ.'GE' ) THEN 25814 IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. 25815 $ 'QLF' ) THEN 25816 IF( SNAME ) THEN 25817 NX = 128 25818 ELSE 25819 NX = 128 25820 END IF 25821 ELSE IF( C3.EQ.'HRD' ) THEN 25822 IF( SNAME ) THEN 25823 NX = 128 25824 ELSE 25825 NX = 128 25826 END IF 25827 ELSE IF( C3.EQ.'BRD' ) THEN 25828 IF( SNAME ) THEN 25829 NX = 128 25830 ELSE 25831 NX = 128 25832 END IF 25833 END IF 25834 ELSE IF( C2.EQ.'SY' ) THEN 25835 IF( SNAME .AND. C3.EQ.'TRD' ) THEN 25836 NX = 32 25837 END IF 25838 ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN 25839 IF( C3.EQ.'TRD' ) THEN 25840 NX = 32 25841 END IF 25842 ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN 25843 IF( C3( 1: 1 ).EQ.'G' ) THEN 25844 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. 25845 $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) 25846 $ THEN 25847 NX = 128 25848 END IF 25849 END IF 25850 ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN 25851 IF( C3( 1: 1 ).EQ.'G' ) THEN 25852 IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. 25853 $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) 25854 $ THEN 25855 NX = 128 25856 END IF 25857 END IF 25858 ELSE IF( C2.EQ.'GG' ) THEN 25859 NX = 128 25860 IF( C3.EQ.'HD3' ) THEN 25861 NX = 128 25862 END IF 25863 END IF 25864 ILAENV = NX 25865 RETURN 25866 80 CONTINUE 25867 ILAENV = 6 25868 RETURN 25869 90 CONTINUE 25870 ILAENV = 2 25871 RETURN 25872 100 CONTINUE 25873 ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) 25874 RETURN 25875 110 CONTINUE 25876 ILAENV = 1 25877 RETURN 25878 120 CONTINUE 25879 ILAENV = 50 25880 RETURN 25881 130 CONTINUE 25882 ILAENV = 25 25883 RETURN 25884 140 CONTINUE 25885 ILAENV = 1 25886 IF( ILAENV.EQ.1 ) THEN 25887 ILAENV = IEEECK( 1, 0.0, 1.0 ) 25888 END IF 25889 RETURN 25890 150 CONTINUE 25891 ILAENV = 1 25892 IF( ILAENV.EQ.1 ) THEN 25893 ILAENV = IEEECK( 0, 0.0, 1.0 ) 25894 END IF 25895 RETURN 25896 160 CONTINUE 25897 ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) 25898 RETURN 25899 END 25900! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ilaenv2stage.f 25901 INTEGER FUNCTION ILAENV2STAGE( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) 25902 CHARACTER*( * ) NAME, OPTS 25903 INTEGER ISPEC, N1, N2, N3, N4 25904 INTEGER IISPEC 25905 INTEGER IPARAM2STAGE 25906 EXTERNAL IPARAM2STAGE 25907 GO TO ( 10, 10, 10, 10, 10 )ISPEC 25908 ILAENV2STAGE = -1 25909 RETURN 25910 10 CONTINUE 25911 IISPEC = 16 + ISPEC 25912 ILAENV2STAGE = IPARAM2STAGE( IISPEC, NAME, OPTS, 25913 $ N1, N2, N3, N4 ) 25914 RETURN 25915 END 25916! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ilaprec.f 25917 INTEGER FUNCTION ILAPREC( PREC ) 25918 CHARACTER PREC 25919 INTEGER BLAS_PREC_SINGLE, BLAS_PREC_DOUBLE, BLAS_PREC_INDIGENOUS, 25920 $ BLAS_PREC_EXTRA 25921 PARAMETER ( BLAS_PREC_SINGLE = 211, BLAS_PREC_DOUBLE = 212, 25922 $ BLAS_PREC_INDIGENOUS = 213, BLAS_PREC_EXTRA = 214 ) 25923 LOGICAL LSAME 25924 EXTERNAL LSAME 25925 IF( LSAME( PREC, 'S' ) ) THEN 25926 ILAPREC = BLAS_PREC_SINGLE 25927 ELSE IF( LSAME( PREC, 'D' ) ) THEN 25928 ILAPREC = BLAS_PREC_DOUBLE 25929 ELSE IF( LSAME( PREC, 'I' ) ) THEN 25930 ILAPREC = BLAS_PREC_INDIGENOUS 25931 ELSE IF( LSAME( PREC, 'X' ) .OR. LSAME( PREC, 'E' ) ) THEN 25932 ILAPREC = BLAS_PREC_EXTRA 25933 ELSE 25934 ILAPREC = -1 25935 END IF 25936 RETURN 25937 END 25938! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ilaslc.f 25939 INTEGER FUNCTION ILASLC( M, N, A, LDA ) 25940 INTEGER M, N, LDA 25941 REAL A( LDA, * ) 25942 REAL ZERO 25943 PARAMETER ( ZERO = 0.0E+0 ) 25944 INTEGER I 25945 IF( N.EQ.0 ) THEN 25946 ILASLC = N 25947 ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN 25948 ILASLC = N 25949 ELSE 25950 DO ILASLC = N, 1, -1 25951 DO I = 1, M 25952 IF( A(I, ILASLC).NE.ZERO ) RETURN 25953 END DO 25954 END DO 25955 END IF 25956 RETURN 25957 END 25958! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ilaslr.f 25959 INTEGER FUNCTION ILASLR( M, N, A, LDA ) 25960 INTEGER M, N, LDA 25961 REAL A( LDA, * ) 25962 REAL ZERO 25963 PARAMETER ( ZERO = 0.0E+0 ) 25964 INTEGER I, J 25965 IF( M.EQ.0 ) THEN 25966 ILASLR = M 25967 ELSEIF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN 25968 ILASLR = M 25969 ELSE 25970 ILASLR = 0 25971 DO J = 1, N 25972 I=M 25973 DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) 25974 I=I-1 25975 ENDDO 25976 ILASLR = MAX( ILASLR, I ) 25977 END DO 25978 END IF 25979 RETURN 25980 END 25981! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ilatrans.f 25982 INTEGER FUNCTION ILATRANS( TRANS ) 25983 CHARACTER TRANS 25984 INTEGER BLAS_NO_TRANS, BLAS_TRANS, BLAS_CONJ_TRANS 25985 PARAMETER ( BLAS_NO_TRANS = 111, BLAS_TRANS = 112, 25986 $ BLAS_CONJ_TRANS = 113 ) 25987 LOGICAL LSAME 25988 EXTERNAL LSAME 25989 IF( LSAME( TRANS, 'N' ) ) THEN 25990 ILATRANS = BLAS_NO_TRANS 25991 ELSE IF( LSAME( TRANS, 'T' ) ) THEN 25992 ILATRANS = BLAS_TRANS 25993 ELSE IF( LSAME( TRANS, 'C' ) ) THEN 25994 ILATRANS = BLAS_CONJ_TRANS 25995 ELSE 25996 ILATRANS = -1 25997 END IF 25998 RETURN 25999 END 26000! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ilauplo.f 26001 INTEGER FUNCTION ILAUPLO( UPLO ) 26002 CHARACTER UPLO 26003 INTEGER BLAS_UPPER, BLAS_LOWER 26004 PARAMETER ( BLAS_UPPER = 121, BLAS_LOWER = 122 ) 26005 LOGICAL LSAME 26006 EXTERNAL LSAME 26007 IF( LSAME( UPLO, 'U' ) ) THEN 26008 ILAUPLO = BLAS_UPPER 26009 ELSE IF( LSAME( UPLO, 'L' ) ) THEN 26010 ILAUPLO = BLAS_LOWER 26011 ELSE 26012 ILAUPLO = -1 26013 END IF 26014 RETURN 26015 END 26016! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ilazlc.f 26017 INTEGER FUNCTION ILAZLC( M, N, A, LDA ) 26018 INTEGER M, N, LDA 26019 COMPLEX*16 A( LDA, * ) 26020 COMPLEX*16 ZERO 26021 PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) 26022 INTEGER I 26023 IF( N.EQ.0 ) THEN 26024 ILAZLC = N 26025 ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN 26026 ILAZLC = N 26027 ELSE 26028 DO ILAZLC = N, 1, -1 26029 DO I = 1, M 26030 IF( A(I, ILAZLC).NE.ZERO ) RETURN 26031 END DO 26032 END DO 26033 END IF 26034 RETURN 26035 END 26036! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ilazlr.f 26037 INTEGER FUNCTION ILAZLR( M, N, A, LDA ) 26038 INTEGER M, N, LDA 26039 COMPLEX*16 A( LDA, * ) 26040 COMPLEX*16 ZERO 26041 PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) 26042 INTEGER I, J 26043 IF( M.EQ.0 ) THEN 26044 ILAZLR = M 26045 ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN 26046 ILAZLR = M 26047 ELSE 26048 ILAZLR = 0 26049 DO J = 1, N 26050 I=M 26051 DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1)) 26052 I=I-1 26053 ENDDO 26054 ILAZLR = MAX( ILAZLR, I ) 26055 END DO 26056 END IF 26057 RETURN 26058 END 26059! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/iparam2stage.F 26060 INTEGER FUNCTION IPARAM2STAGE( ISPEC, NAME, OPTS, 26061 $ NI, NBI, IBI, NXI ) 26062#if defined(_OPENMP) 26063 use omp_lib 26064#endif 26065 IMPLICIT NONE 26066 CHARACTER*( * ) NAME, OPTS 26067 INTEGER ISPEC, NI, NBI, IBI, NXI 26068 INTEGER I, IC, IZ, KD, IB, LHOUS, LWORK, NTHREADS, 26069 $ FACTOPTNB, QROPTNB, LQOPTNB 26070 LOGICAL RPREC, CPREC 26071 CHARACTER PREC*1, ALGO*3, STAG*5, SUBNAM*12, VECT*1 26072 INTRINSIC CHAR, ICHAR, MAX 26073 INTEGER ILAENV 26074 EXTERNAL ILAENV 26075 IF( (ISPEC.LT.17).OR.(ISPEC.GT.21) ) THEN 26076 IPARAM2STAGE = -1 26077 RETURN 26078 ENDIF 26079 NTHREADS = 1 26080#if defined(_OPENMP) 26081 NTHREADS = OMP_GET_NUM_THREADS() 26082#endif 26083 IF( ISPEC .NE. 19 ) THEN 26084 IPARAM2STAGE = -1 26085 SUBNAM = NAME 26086 IC = ICHAR( SUBNAM( 1: 1 ) ) 26087 IZ = ICHAR( 'Z' ) 26088 IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN 26089 IF( IC.GE.97 .AND. IC.LE.122 ) THEN 26090 SUBNAM( 1: 1 ) = CHAR( IC-32 ) 26091 DO 100 I = 2, 12 26092 IC = ICHAR( SUBNAM( I: I ) ) 26093 IF( IC.GE.97 .AND. IC.LE.122 ) 26094 $ SUBNAM( I: I ) = CHAR( IC-32 ) 26095 100 CONTINUE 26096 END IF 26097 ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN 26098 IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. 26099 $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. 26100 $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN 26101 SUBNAM( 1: 1 ) = CHAR( IC+64 ) 26102 DO 110 I = 2, 12 26103 IC = ICHAR( SUBNAM( I: I ) ) 26104 IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. 26105 $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. 26106 $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: 26107 $ I ) = CHAR( IC+64 ) 26108 110 CONTINUE 26109 END IF 26110 ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN 26111 IF( IC.GE.225 .AND. IC.LE.250 ) THEN 26112 SUBNAM( 1: 1 ) = CHAR( IC-32 ) 26113 DO 120 I = 2, 12 26114 IC = ICHAR( SUBNAM( I: I ) ) 26115 IF( IC.GE.225 .AND. IC.LE.250 ) 26116 $ SUBNAM( I: I ) = CHAR( IC-32 ) 26117 120 CONTINUE 26118 END IF 26119 END IF 26120 PREC = SUBNAM( 1: 1 ) 26121 ALGO = SUBNAM( 4: 6 ) 26122 STAG = SUBNAM( 8:12 ) 26123 RPREC = PREC.EQ.'S' .OR. PREC.EQ.'D' 26124 CPREC = PREC.EQ.'C' .OR. PREC.EQ.'Z' 26125 IF( .NOT.( RPREC .OR. CPREC ) ) THEN 26126 IPARAM2STAGE = -1 26127 RETURN 26128 ENDIF 26129 ENDIF 26130 IF (( ISPEC .EQ. 17 ) .OR. ( ISPEC .EQ. 18 )) THEN 26131 IF( NTHREADS.GT.4 ) THEN 26132 IF( CPREC ) THEN 26133 KD = 128 26134 IB = 32 26135 ELSE 26136 KD = 160 26137 IB = 40 26138 ENDIF 26139 ELSE IF( NTHREADS.GT.1 ) THEN 26140 IF( CPREC ) THEN 26141 KD = 64 26142 IB = 32 26143 ELSE 26144 KD = 64 26145 IB = 32 26146 ENDIF 26147 ELSE 26148 IF( CPREC ) THEN 26149 KD = 16 26150 IB = 16 26151 ELSE 26152 KD = 32 26153 IB = 16 26154 ENDIF 26155 ENDIF 26156 IF( ISPEC.EQ.17 ) IPARAM2STAGE = KD 26157 IF( ISPEC.EQ.18 ) IPARAM2STAGE = IB 26158 ELSE IF ( ISPEC .EQ. 19 ) THEN 26159 VECT = OPTS(1:1) 26160 IF( VECT.EQ.'N' ) THEN 26161 LHOUS = MAX( 1, 4*NI ) 26162 ELSE 26163 LHOUS = MAX( 1, 4*NI ) + IBI 26164 ENDIF 26165 IF( LHOUS.GE.0 ) THEN 26166 IPARAM2STAGE = LHOUS 26167 ELSE 26168 IPARAM2STAGE = -1 26169 ENDIF 26170 ELSE IF ( ISPEC .EQ. 20 ) THEN 26171 LWORK = -1 26172 SUBNAM(1:1) = PREC 26173 SUBNAM(2:6) = 'GEQRF' 26174 QROPTNB = ILAENV( 1, SUBNAM, ' ', NI, NBI, -1, -1 ) 26175 SUBNAM(2:6) = 'GELQF' 26176 LQOPTNB = ILAENV( 1, SUBNAM, ' ', NBI, NI, -1, -1 ) 26177 FACTOPTNB = MAX(QROPTNB, LQOPTNB) 26178 IF( ALGO.EQ.'TRD' ) THEN 26179 IF( STAG.EQ.'2STAG' ) THEN 26180 LWORK = NI*NBI + NI*MAX(NBI+1,FACTOPTNB) 26181 $ + MAX(2*NBI*NBI, NBI*NTHREADS) 26182 $ + (NBI+1)*NI 26183 ELSE IF( (STAG.EQ.'HE2HB').OR.(STAG.EQ.'SY2SB') ) THEN 26184 LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI 26185 ELSE IF( (STAG.EQ.'HB2ST').OR.(STAG.EQ.'SB2ST') ) THEN 26186 LWORK = (2*NBI+1)*NI + NBI*NTHREADS 26187 ENDIF 26188 ELSE IF( ALGO.EQ.'BRD' ) THEN 26189 IF( STAG.EQ.'2STAG' ) THEN 26190 LWORK = 2*NI*NBI + NI*MAX(NBI+1,FACTOPTNB) 26191 $ + MAX(2*NBI*NBI, NBI*NTHREADS) 26192 $ + (NBI+1)*NI 26193 ELSE IF( STAG.EQ.'GE2GB' ) THEN 26194 LWORK = NI*NBI + NI*MAX(NBI,FACTOPTNB) + 2*NBI*NBI 26195 ELSE IF( STAG.EQ.'GB2BD' ) THEN 26196 LWORK = (3*NBI+1)*NI + NBI*NTHREADS 26197 ENDIF 26198 ENDIF 26199 LWORK = MAX ( 1, LWORK ) 26200 IF( LWORK.GT.0 ) THEN 26201 IPARAM2STAGE = LWORK 26202 ELSE 26203 IPARAM2STAGE = -1 26204 ENDIF 26205 ELSE IF ( ISPEC .EQ. 21 ) THEN 26206 IPARAM2STAGE = NXI 26207 ENDIF 26208 END 26209! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/iparmq.f 26210 INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) 26211 INTEGER IHI, ILO, ISPEC, LWORK, N 26212 CHARACTER NAME*( * ), OPTS*( * ) 26213 INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 26214 PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, 26215 $ ISHFTS = 15, IACC22 = 16 ) 26216 INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP 26217 PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, 26218 $ NIBBLE = 14, KNWSWP = 500 ) 26219 REAL TWO 26220 PARAMETER ( TWO = 2.0 ) 26221 INTEGER NH, NS 26222 INTEGER I, IC, IZ 26223 CHARACTER SUBNAM*6 26224 INTRINSIC LOG, MAX, MOD, NINT, REAL 26225 IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. 26226 $ ( ISPEC.EQ.IACC22 ) ) THEN 26227 NH = IHI - ILO + 1 26228 NS = 2 26229 IF( NH.GE.30 ) 26230 $ NS = 4 26231 IF( NH.GE.60 ) 26232 $ NS = 10 26233 IF( NH.GE.150 ) 26234 $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) 26235 IF( NH.GE.590 ) 26236 $ NS = 64 26237 IF( NH.GE.3000 ) 26238 $ NS = 128 26239 IF( NH.GE.6000 ) 26240 $ NS = 256 26241 NS = MAX( 2, NS-MOD( NS, 2 ) ) 26242 END IF 26243 IF( ISPEC.EQ.INMIN ) THEN 26244 IPARMQ = NMIN 26245 ELSE IF( ISPEC.EQ.INIBL ) THEN 26246 IPARMQ = NIBBLE 26247 ELSE IF( ISPEC.EQ.ISHFTS ) THEN 26248 IPARMQ = NS 26249 ELSE IF( ISPEC.EQ.INWIN ) THEN 26250 IF( NH.LE.KNWSWP ) THEN 26251 IPARMQ = NS 26252 ELSE 26253 IPARMQ = 3*NS / 2 26254 END IF 26255 ELSE IF( ISPEC.EQ.IACC22 ) THEN 26256 IPARMQ = 0 26257 SUBNAM = NAME 26258 IC = ICHAR( SUBNAM( 1: 1 ) ) 26259 IZ = ICHAR( 'Z' ) 26260 IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN 26261 IF( IC.GE.97 .AND. IC.LE.122 ) THEN 26262 SUBNAM( 1: 1 ) = CHAR( IC-32 ) 26263 DO I = 2, 6 26264 IC = ICHAR( SUBNAM( I: I ) ) 26265 IF( IC.GE.97 .AND. IC.LE.122 ) 26266 $ SUBNAM( I: I ) = CHAR( IC-32 ) 26267 END DO 26268 END IF 26269 ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN 26270 IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. 26271 $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. 26272 $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN 26273 SUBNAM( 1: 1 ) = CHAR( IC+64 ) 26274 DO I = 2, 6 26275 IC = ICHAR( SUBNAM( I: I ) ) 26276 IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. 26277 $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. 26278 $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: 26279 $ I ) = CHAR( IC+64 ) 26280 END DO 26281 END IF 26282 ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN 26283 IF( IC.GE.225 .AND. IC.LE.250 ) THEN 26284 SUBNAM( 1: 1 ) = CHAR( IC-32 ) 26285 DO I = 2, 6 26286 IC = ICHAR( SUBNAM( I: I ) ) 26287 IF( IC.GE.225 .AND. IC.LE.250 ) 26288 $ SUBNAM( I: I ) = CHAR( IC-32 ) 26289 END DO 26290 END IF 26291 END IF 26292 IF( SUBNAM( 2:6 ).EQ.'GGHRD' .OR. 26293 $ SUBNAM( 2:6 ).EQ.'GGHD3' ) THEN 26294 IPARMQ = 1 26295 IF( NH.GE.K22MIN ) 26296 $ IPARMQ = 2 26297 ELSE IF ( SUBNAM( 4:6 ).EQ.'EXC' ) THEN 26298 IF( NH.GE.KACMIN ) 26299 $ IPARMQ = 1 26300 IF( NH.GE.K22MIN ) 26301 $ IPARMQ = 2 26302 ELSE IF ( SUBNAM( 2:6 ).EQ.'HSEQR' .OR. 26303 $ SUBNAM( 2:5 ).EQ.'LAQR' ) THEN 26304 IF( NS.GE.KACMIN ) 26305 $ IPARMQ = 1 26306 IF( NS.GE.K22MIN ) 26307 $ IPARMQ = 2 26308 END IF 26309 ELSE 26310 IPARMQ = -1 26311 END IF 26312 END 26313! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/izmax1.f 26314 INTEGER FUNCTION IZMAX1( N, ZX, INCX ) 26315 INTEGER INCX, N 26316 COMPLEX*16 ZX(*) 26317 DOUBLE PRECISION DMAX 26318 INTEGER I, IX 26319 INTRINSIC ABS 26320 IZMAX1 = 0 26321 IF (N.LT.1 .OR. INCX.LE.0) RETURN 26322 IZMAX1 = 1 26323 IF (N.EQ.1) RETURN 26324 IF (INCX.EQ.1) THEN 26325 DMAX = ABS(ZX(1)) 26326 DO I = 2,N 26327 IF (ABS(ZX(I)).GT.DMAX) THEN 26328 IZMAX1 = I 26329 DMAX = ABS(ZX(I)) 26330 END IF 26331 END DO 26332 ELSE 26333 IX = 1 26334 DMAX = ABS(ZX(1)) 26335 IX = IX + INCX 26336 DO I = 2,N 26337 IF (ABS(ZX(IX)).GT.DMAX) THEN 26338 IZMAX1 = I 26339 DMAX = ABS(ZX(IX)) 26340 END IF 26341 IX = IX + INCX 26342 END DO 26343 END IF 26344 RETURN 26345 END 26346! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/lsamen.f 26347 LOGICAL FUNCTION LSAMEN( N, CA, CB ) 26348 CHARACTER*( * ) CA, CB 26349 INTEGER N 26350 INTEGER I 26351 LOGICAL LSAME 26352 EXTERNAL LSAME 26353 INTRINSIC LEN 26354 LSAMEN = .FALSE. 26355 IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N ) 26356 $ GO TO 20 26357 DO 10 I = 1, N 26358 IF( .NOT.LSAME( CA( I: I ), CB( I: I ) ) ) 26359 $ GO TO 20 26360 10 CONTINUE 26361 LSAMEN = .TRUE. 26362 20 CONTINUE 26363 RETURN 26364 END 26365! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/scombssq.f 26366 SUBROUTINE SCOMBSSQ( V1, V2 ) 26367 REAL V1( 2 ), V2( 2 ) 26368 REAL ZERO 26369 PARAMETER ( ZERO = 0.0D+0 ) 26370 IF( V1( 1 ).GE.V2( 1 ) ) THEN 26371 IF( V1( 1 ).NE.ZERO ) THEN 26372 V1( 2 ) = V1( 2 ) + ( V2( 1 ) / V1( 1 ) )**2 * V2( 2 ) 26373 ELSE 26374 V1( 2 ) = V1( 2 ) + V2( 2 ) 26375 END IF 26376 ELSE 26377 V1( 2 ) = V2( 2 ) + ( V1( 1 ) / V2( 1 ) )**2 * V1( 2 ) 26378 V1( 1 ) = V2( 1 ) 26379 END IF 26380 RETURN 26381 END 26382! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/scsum1.f 26383 REAL FUNCTION SCSUM1( N, CX, INCX ) 26384 INTEGER INCX, N 26385 COMPLEX CX( * ) 26386 INTEGER I, NINCX 26387 REAL STEMP 26388 INTRINSIC ABS 26389 SCSUM1 = 0.0E0 26390 STEMP = 0.0E0 26391 IF( N.LE.0 ) 26392 $ RETURN 26393 IF( INCX.EQ.1 ) 26394 $ GO TO 20 26395 NINCX = N*INCX 26396 DO 10 I = 1, NINCX, INCX 26397 STEMP = STEMP + ABS( CX( I ) ) 26398 10 CONTINUE 26399 SCSUM1 = STEMP 26400 RETURN 26401 20 CONTINUE 26402 DO 30 I = 1, N 26403 STEMP = STEMP + ABS( CX( I ) ) 26404 30 CONTINUE 26405 SCSUM1 = STEMP 26406 RETURN 26407 END 26408! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sgbtrs.f 26409 SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, 26410 $ INFO ) 26411 CHARACTER TRANS 26412 INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS 26413 INTEGER IPIV( * ) 26414 REAL AB( LDAB, * ), B( LDB, * ) 26415 REAL ONE 26416 PARAMETER ( ONE = 1.0E+0 ) 26417 LOGICAL LNOTI, NOTRAN 26418 INTEGER I, J, KD, L, LM 26419 LOGICAL LSAME 26420 EXTERNAL LSAME 26421 EXTERNAL SGEMV, SGER, SSWAP, STBSV, XERBLA 26422 INTRINSIC MAX, MIN 26423 INFO = 0 26424 NOTRAN = LSAME( TRANS, 'N' ) 26425 IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. 26426 $ LSAME( TRANS, 'C' ) ) THEN 26427 INFO = -1 26428 ELSE IF( N.LT.0 ) THEN 26429 INFO = -2 26430 ELSE IF( KL.LT.0 ) THEN 26431 INFO = -3 26432 ELSE IF( KU.LT.0 ) THEN 26433 INFO = -4 26434 ELSE IF( NRHS.LT.0 ) THEN 26435 INFO = -5 26436 ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN 26437 INFO = -7 26438 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 26439 INFO = -10 26440 END IF 26441 IF( INFO.NE.0 ) THEN 26442 CALL XERBLA( 'SGBTRS', -INFO ) 26443 RETURN 26444 END IF 26445 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 26446 $ RETURN 26447 KD = KU + KL + 1 26448 LNOTI = KL.GT.0 26449 IF( NOTRAN ) THEN 26450 IF( LNOTI ) THEN 26451 DO 10 J = 1, N - 1 26452 LM = MIN( KL, N-J ) 26453 L = IPIV( J ) 26454 IF( L.NE.J ) 26455 $ CALL SSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 26456 CALL SGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), 26457 $ LDB, B( J+1, 1 ), LDB ) 26458 10 CONTINUE 26459 END IF 26460 DO 20 I = 1, NRHS 26461 CALL STBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, 26462 $ AB, LDAB, B( 1, I ), 1 ) 26463 20 CONTINUE 26464 ELSE 26465 DO 30 I = 1, NRHS 26466 CALL STBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, 26467 $ LDAB, B( 1, I ), 1 ) 26468 30 CONTINUE 26469 IF( LNOTI ) THEN 26470 DO 40 J = N - 1, 1, -1 26471 LM = MIN( KL, N-J ) 26472 CALL SGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), 26473 $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) 26474 L = IPIV( J ) 26475 IF( L.NE.J ) 26476 $ CALL SSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 26477 40 CONTINUE 26478 END IF 26479 END IF 26480 RETURN 26481 END 26482! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sgetrs.f 26483 SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 26484 CHARACTER TRANS 26485 INTEGER INFO, LDA, LDB, N, NRHS 26486 INTEGER IPIV( * ) 26487 REAL A( LDA, * ), B( LDB, * ) 26488 REAL ONE 26489 PARAMETER ( ONE = 1.0E+0 ) 26490 LOGICAL NOTRAN 26491 LOGICAL LSAME 26492 EXTERNAL LSAME 26493 EXTERNAL SLASWP, STRSM, XERBLA 26494 INTRINSIC MAX 26495 INFO = 0 26496 NOTRAN = LSAME( TRANS, 'N' ) 26497 IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. 26498 $ LSAME( TRANS, 'C' ) ) THEN 26499 INFO = -1 26500 ELSE IF( N.LT.0 ) THEN 26501 INFO = -2 26502 ELSE IF( NRHS.LT.0 ) THEN 26503 INFO = -3 26504 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 26505 INFO = -5 26506 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 26507 INFO = -8 26508 END IF 26509 IF( INFO.NE.0 ) THEN 26510 CALL XERBLA( 'SGETRS', -INFO ) 26511 RETURN 26512 END IF 26513 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 26514 $ RETURN 26515 IF( NOTRAN ) THEN 26516 CALL SLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) 26517 CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, 26518 $ ONE, A, LDA, B, LDB ) 26519 CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, 26520 $ NRHS, ONE, A, LDA, B, LDB ) 26521 ELSE 26522 CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, 26523 $ ONE, A, LDA, B, LDB ) 26524 CALL STRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, 26525 $ A, LDA, B, LDB ) 26526 CALL SLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) 26527 END IF 26528 RETURN 26529 END 26530! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sisnan.f 26531 LOGICAL FUNCTION SISNAN( SIN ) 26532 REAL, INTENT(IN) :: SIN 26533 LOGICAL SLAISNAN 26534 EXTERNAL SLAISNAN 26535 SISNAN = SLAISNAN(SIN,SIN) 26536 RETURN 26537 END 26538! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sla_gbrcond.f 26539 REAL FUNCTION SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, 26540 $ IPIV, CMODE, C, INFO, WORK, IWORK ) 26541 CHARACTER TRANS 26542 INTEGER N, LDAB, LDAFB, INFO, KL, KU, CMODE 26543 INTEGER IWORK( * ), IPIV( * ) 26544 REAL AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), 26545 $ C( * ) 26546 LOGICAL NOTRANS 26547 INTEGER KASE, I, J, KD, KE 26548 REAL AINVNM, TMP 26549 INTEGER ISAVE( 3 ) 26550 LOGICAL LSAME 26551 EXTERNAL LSAME 26552 EXTERNAL SLACN2, SGBTRS, XERBLA 26553 INTRINSIC ABS, MAX 26554 SLA_GBRCOND = 0.0 26555 INFO = 0 26556 NOTRANS = LSAME( TRANS, 'N' ) 26557 IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') 26558 $ .AND. .NOT. LSAME(TRANS, 'C') ) THEN 26559 INFO = -1 26560 ELSE IF( N.LT.0 ) THEN 26561 INFO = -2 26562 ELSE IF( KL.LT.0 .OR. KL.GT.N-1 ) THEN 26563 INFO = -3 26564 ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN 26565 INFO = -4 26566 ELSE IF( LDAB.LT.KL+KU+1 ) THEN 26567 INFO = -6 26568 ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN 26569 INFO = -8 26570 END IF 26571 IF( INFO.NE.0 ) THEN 26572 CALL XERBLA( 'SLA_GBRCOND', -INFO ) 26573 RETURN 26574 END IF 26575 IF( N.EQ.0 ) THEN 26576 SLA_GBRCOND = 1.0 26577 RETURN 26578 END IF 26579 KD = KU + 1 26580 KE = KL + 1 26581 IF ( NOTRANS ) THEN 26582 DO I = 1, N 26583 TMP = 0.0 26584 IF ( CMODE .EQ. 1 ) THEN 26585 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 26586 TMP = TMP + ABS( AB( KD+I-J, J ) * C( J ) ) 26587 END DO 26588 ELSE IF ( CMODE .EQ. 0 ) THEN 26589 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 26590 TMP = TMP + ABS( AB( KD+I-J, J ) ) 26591 END DO 26592 ELSE 26593 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 26594 TMP = TMP + ABS( AB( KD+I-J, J ) / C( J ) ) 26595 END DO 26596 END IF 26597 WORK( 2*N+I ) = TMP 26598 END DO 26599 ELSE 26600 DO I = 1, N 26601 TMP = 0.0 26602 IF ( CMODE .EQ. 1 ) THEN 26603 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 26604 TMP = TMP + ABS( AB( KE-I+J, I ) * C( J ) ) 26605 END DO 26606 ELSE IF ( CMODE .EQ. 0 ) THEN 26607 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 26608 TMP = TMP + ABS( AB( KE-I+J, I ) ) 26609 END DO 26610 ELSE 26611 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 26612 TMP = TMP + ABS( AB( KE-I+J, I ) / C( J ) ) 26613 END DO 26614 END IF 26615 WORK( 2*N+I ) = TMP 26616 END DO 26617 END IF 26618 AINVNM = 0.0 26619 KASE = 0 26620 10 CONTINUE 26621 CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) 26622 IF( KASE.NE.0 ) THEN 26623 IF( KASE.EQ.2 ) THEN 26624 DO I = 1, N 26625 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 26626 END DO 26627 IF ( NOTRANS ) THEN 26628 CALL SGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 26629 $ IPIV, WORK, N, INFO ) 26630 ELSE 26631 CALL SGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV, 26632 $ WORK, N, INFO ) 26633 END IF 26634 IF ( CMODE .EQ. 1 ) THEN 26635 DO I = 1, N 26636 WORK( I ) = WORK( I ) / C( I ) 26637 END DO 26638 ELSE IF ( CMODE .EQ. -1 ) THEN 26639 DO I = 1, N 26640 WORK( I ) = WORK( I ) * C( I ) 26641 END DO 26642 END IF 26643 ELSE 26644 IF ( CMODE .EQ. 1 ) THEN 26645 DO I = 1, N 26646 WORK( I ) = WORK( I ) / C( I ) 26647 END DO 26648 ELSE IF ( CMODE .EQ. -1 ) THEN 26649 DO I = 1, N 26650 WORK( I ) = WORK( I ) * C( I ) 26651 END DO 26652 END IF 26653 IF ( NOTRANS ) THEN 26654 CALL SGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV, 26655 $ WORK, N, INFO ) 26656 ELSE 26657 CALL SGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 26658 $ IPIV, WORK, N, INFO ) 26659 END IF 26660 DO I = 1, N 26661 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 26662 END DO 26663 END IF 26664 GO TO 10 26665 END IF 26666 IF( AINVNM .NE. 0.0 ) 26667 $ SLA_GBRCOND = ( 1.0 / AINVNM ) 26668 RETURN 26669 END 26670! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sla_gbrpvgrw.f 26671 REAL FUNCTION SLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, 26672 $ LDAFB ) 26673 INTEGER N, KL, KU, NCOLS, LDAB, LDAFB 26674 REAL AB( LDAB, * ), AFB( LDAFB, * ) 26675 INTEGER I, J, KD 26676 REAL AMAX, UMAX, RPVGRW 26677 INTRINSIC ABS, MAX, MIN 26678 RPVGRW = 1.0 26679 KD = KU + 1 26680 DO J = 1, NCOLS 26681 AMAX = 0.0 26682 UMAX = 0.0 26683 DO I = MAX( J-KU, 1 ), MIN( J+KL, N ) 26684 AMAX = MAX( ABS( AB( KD+I-J, J)), AMAX ) 26685 END DO 26686 DO I = MAX( J-KU, 1 ), J 26687 UMAX = MAX( ABS( AFB( KD+I-J, J ) ), UMAX ) 26688 END DO 26689 IF ( UMAX /= 0.0 ) THEN 26690 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 26691 END IF 26692 END DO 26693 SLA_GBRPVGRW = RPVGRW 26694 END 26695! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sla_gercond.f 26696 REAL FUNCTION SLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, 26697 $ CMODE, C, INFO, WORK, IWORK ) 26698 CHARACTER TRANS 26699 INTEGER N, LDA, LDAF, INFO, CMODE 26700 INTEGER IPIV( * ), IWORK( * ) 26701 REAL A( LDA, * ), AF( LDAF, * ), WORK( * ), 26702 $ C( * ) 26703 LOGICAL NOTRANS 26704 INTEGER KASE, I, J 26705 REAL AINVNM, TMP 26706 INTEGER ISAVE( 3 ) 26707 LOGICAL LSAME 26708 EXTERNAL LSAME 26709 EXTERNAL SLACN2, SGETRS, XERBLA 26710 INTRINSIC ABS, MAX 26711 SLA_GERCOND = 0.0 26712 INFO = 0 26713 NOTRANS = LSAME( TRANS, 'N' ) 26714 IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') 26715 $ .AND. .NOT. LSAME(TRANS, 'C') ) THEN 26716 INFO = -1 26717 ELSE IF( N.LT.0 ) THEN 26718 INFO = -2 26719 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 26720 INFO = -4 26721 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 26722 INFO = -6 26723 END IF 26724 IF( INFO.NE.0 ) THEN 26725 CALL XERBLA( 'SLA_GERCOND', -INFO ) 26726 RETURN 26727 END IF 26728 IF( N.EQ.0 ) THEN 26729 SLA_GERCOND = 1.0 26730 RETURN 26731 END IF 26732 IF (NOTRANS) THEN 26733 DO I = 1, N 26734 TMP = 0.0 26735 IF ( CMODE .EQ. 1 ) THEN 26736 DO J = 1, N 26737 TMP = TMP + ABS( A( I, J ) * C( J ) ) 26738 END DO 26739 ELSE IF ( CMODE .EQ. 0 ) THEN 26740 DO J = 1, N 26741 TMP = TMP + ABS( A( I, J ) ) 26742 END DO 26743 ELSE 26744 DO J = 1, N 26745 TMP = TMP + ABS( A( I, J ) / C( J ) ) 26746 END DO 26747 END IF 26748 WORK( 2*N+I ) = TMP 26749 END DO 26750 ELSE 26751 DO I = 1, N 26752 TMP = 0.0 26753 IF ( CMODE .EQ. 1 ) THEN 26754 DO J = 1, N 26755 TMP = TMP + ABS( A( J, I ) * C( J ) ) 26756 END DO 26757 ELSE IF ( CMODE .EQ. 0 ) THEN 26758 DO J = 1, N 26759 TMP = TMP + ABS( A( J, I ) ) 26760 END DO 26761 ELSE 26762 DO J = 1, N 26763 TMP = TMP + ABS( A( J, I ) / C( J ) ) 26764 END DO 26765 END IF 26766 WORK( 2*N+I ) = TMP 26767 END DO 26768 END IF 26769 AINVNM = 0.0 26770 KASE = 0 26771 10 CONTINUE 26772 CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) 26773 IF( KASE.NE.0 ) THEN 26774 IF( KASE.EQ.2 ) THEN 26775 DO I = 1, N 26776 WORK(I) = WORK(I) * WORK(2*N+I) 26777 END DO 26778 IF (NOTRANS) THEN 26779 CALL SGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 26780 $ WORK, N, INFO ) 26781 ELSE 26782 CALL SGETRS( 'Transpose', N, 1, AF, LDAF, IPIV, 26783 $ WORK, N, INFO ) 26784 END IF 26785 IF ( CMODE .EQ. 1 ) THEN 26786 DO I = 1, N 26787 WORK( I ) = WORK( I ) / C( I ) 26788 END DO 26789 ELSE IF ( CMODE .EQ. -1 ) THEN 26790 DO I = 1, N 26791 WORK( I ) = WORK( I ) * C( I ) 26792 END DO 26793 END IF 26794 ELSE 26795 IF ( CMODE .EQ. 1 ) THEN 26796 DO I = 1, N 26797 WORK( I ) = WORK( I ) / C( I ) 26798 END DO 26799 ELSE IF ( CMODE .EQ. -1 ) THEN 26800 DO I = 1, N 26801 WORK( I ) = WORK( I ) * C( I ) 26802 END DO 26803 END IF 26804 IF (NOTRANS) THEN 26805 CALL SGETRS( 'Transpose', N, 1, AF, LDAF, IPIV, 26806 $ WORK, N, INFO ) 26807 ELSE 26808 CALL SGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 26809 $ WORK, N, INFO ) 26810 END IF 26811 DO I = 1, N 26812 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 26813 END DO 26814 END IF 26815 GO TO 10 26816 END IF 26817 IF( AINVNM .NE. 0.0 ) 26818 $ SLA_GERCOND = ( 1.0 / AINVNM ) 26819 RETURN 26820 END 26821! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sla_gerpvgrw.f 26822 REAL FUNCTION SLA_GERPVGRW( N, NCOLS, A, LDA, AF, LDAF ) 26823 INTEGER N, NCOLS, LDA, LDAF 26824 REAL A( LDA, * ), AF( LDAF, * ) 26825 INTEGER I, J 26826 REAL AMAX, UMAX, RPVGRW 26827 INTRINSIC ABS, MAX, MIN 26828 RPVGRW = 1.0 26829 DO J = 1, NCOLS 26830 AMAX = 0.0 26831 UMAX = 0.0 26832 DO I = 1, N 26833 AMAX = MAX( ABS( A( I, J ) ), AMAX ) 26834 END DO 26835 DO I = 1, J 26836 UMAX = MAX( ABS( AF( I, J ) ), UMAX ) 26837 END DO 26838 IF ( UMAX /= 0.0 ) THEN 26839 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 26840 END IF 26841 END DO 26842 SLA_GERPVGRW = RPVGRW 26843 END 26844! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sla_porcond.f 26845 REAL FUNCTION SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, 26846 $ INFO, WORK, IWORK ) 26847 CHARACTER UPLO 26848 INTEGER N, LDA, LDAF, INFO, CMODE 26849 REAL A( LDA, * ), AF( LDAF, * ), WORK( * ), 26850 $ C( * ) 26851 INTEGER IWORK( * ) 26852 INTEGER KASE, I, J 26853 REAL AINVNM, TMP 26854 LOGICAL UP 26855 INTEGER ISAVE( 3 ) 26856 LOGICAL LSAME 26857 EXTERNAL LSAME 26858 EXTERNAL SLACN2, SPOTRS, XERBLA 26859 INTRINSIC ABS, MAX 26860 SLA_PORCOND = 0.0 26861 INFO = 0 26862 IF( N.LT.0 ) THEN 26863 INFO = -2 26864 END IF 26865 IF( INFO.NE.0 ) THEN 26866 CALL XERBLA( 'SLA_PORCOND', -INFO ) 26867 RETURN 26868 END IF 26869 IF( N.EQ.0 ) THEN 26870 SLA_PORCOND = 1.0 26871 RETURN 26872 END IF 26873 UP = .FALSE. 26874 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 26875 IF ( UP ) THEN 26876 DO I = 1, N 26877 TMP = 0.0 26878 IF ( CMODE .EQ. 1 ) THEN 26879 DO J = 1, I 26880 TMP = TMP + ABS( A( J, I ) * C( J ) ) 26881 END DO 26882 DO J = I+1, N 26883 TMP = TMP + ABS( A( I, J ) * C( J ) ) 26884 END DO 26885 ELSE IF ( CMODE .EQ. 0 ) THEN 26886 DO J = 1, I 26887 TMP = TMP + ABS( A( J, I ) ) 26888 END DO 26889 DO J = I+1, N 26890 TMP = TMP + ABS( A( I, J ) ) 26891 END DO 26892 ELSE 26893 DO J = 1, I 26894 TMP = TMP + ABS( A( J ,I ) / C( J ) ) 26895 END DO 26896 DO J = I+1, N 26897 TMP = TMP + ABS( A( I, J ) / C( J ) ) 26898 END DO 26899 END IF 26900 WORK( 2*N+I ) = TMP 26901 END DO 26902 ELSE 26903 DO I = 1, N 26904 TMP = 0.0 26905 IF ( CMODE .EQ. 1 ) THEN 26906 DO J = 1, I 26907 TMP = TMP + ABS( A( I, J ) * C( J ) ) 26908 END DO 26909 DO J = I+1, N 26910 TMP = TMP + ABS( A( J, I ) * C( J ) ) 26911 END DO 26912 ELSE IF ( CMODE .EQ. 0 ) THEN 26913 DO J = 1, I 26914 TMP = TMP + ABS( A( I, J ) ) 26915 END DO 26916 DO J = I+1, N 26917 TMP = TMP + ABS( A( J, I ) ) 26918 END DO 26919 ELSE 26920 DO J = 1, I 26921 TMP = TMP + ABS( A( I, J ) / C( J ) ) 26922 END DO 26923 DO J = I+1, N 26924 TMP = TMP + ABS( A( J, I ) / C( J ) ) 26925 END DO 26926 END IF 26927 WORK( 2*N+I ) = TMP 26928 END DO 26929 ENDIF 26930 AINVNM = 0.0 26931 KASE = 0 26932 10 CONTINUE 26933 CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) 26934 IF( KASE.NE.0 ) THEN 26935 IF( KASE.EQ.2 ) THEN 26936 DO I = 1, N 26937 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 26938 END DO 26939 IF (UP) THEN 26940 CALL SPOTRS( 'Upper', N, 1, AF, LDAF, WORK, N, INFO ) 26941 ELSE 26942 CALL SPOTRS( 'Lower', N, 1, AF, LDAF, WORK, N, INFO ) 26943 ENDIF 26944 IF ( CMODE .EQ. 1 ) THEN 26945 DO I = 1, N 26946 WORK( I ) = WORK( I ) / C( I ) 26947 END DO 26948 ELSE IF ( CMODE .EQ. -1 ) THEN 26949 DO I = 1, N 26950 WORK( I ) = WORK( I ) * C( I ) 26951 END DO 26952 END IF 26953 ELSE 26954 IF ( CMODE .EQ. 1 ) THEN 26955 DO I = 1, N 26956 WORK( I ) = WORK( I ) / C( I ) 26957 END DO 26958 ELSE IF ( CMODE .EQ. -1 ) THEN 26959 DO I = 1, N 26960 WORK( I ) = WORK( I ) * C( I ) 26961 END DO 26962 END IF 26963 IF ( UP ) THEN 26964 CALL SPOTRS( 'Upper', N, 1, AF, LDAF, WORK, N, INFO ) 26965 ELSE 26966 CALL SPOTRS( 'Lower', N, 1, AF, LDAF, WORK, N, INFO ) 26967 ENDIF 26968 DO I = 1, N 26969 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 26970 END DO 26971 END IF 26972 GO TO 10 26973 END IF 26974 IF( AINVNM .NE. 0.0 ) 26975 $ SLA_PORCOND = ( 1.0 / AINVNM ) 26976 RETURN 26977 END 26978! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sla_porpvgrw.f 26979 REAL FUNCTION SLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK ) 26980 CHARACTER*1 UPLO 26981 INTEGER NCOLS, LDA, LDAF 26982 REAL A( LDA, * ), AF( LDAF, * ), WORK( * ) 26983 INTEGER I, J 26984 REAL AMAX, UMAX, RPVGRW 26985 LOGICAL UPPER 26986 INTRINSIC ABS, MAX, MIN 26987 EXTERNAL LSAME 26988 LOGICAL LSAME 26989 UPPER = LSAME( 'Upper', UPLO ) 26990 RPVGRW = 1.0 26991 DO I = 1, 2*NCOLS 26992 WORK( I ) = 0.0 26993 END DO 26994 IF ( UPPER ) THEN 26995 DO J = 1, NCOLS 26996 DO I = 1, J 26997 WORK( NCOLS+J ) = 26998 $ MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) ) 26999 END DO 27000 END DO 27001 ELSE 27002 DO J = 1, NCOLS 27003 DO I = J, NCOLS 27004 WORK( NCOLS+J ) = 27005 $ MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) ) 27006 END DO 27007 END DO 27008 END IF 27009 IF ( LSAME( 'Upper', UPLO ) ) THEN 27010 DO J = 1, NCOLS 27011 DO I = 1, J 27012 WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) ) 27013 END DO 27014 END DO 27015 ELSE 27016 DO J = 1, NCOLS 27017 DO I = J, NCOLS 27018 WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) ) 27019 END DO 27020 END DO 27021 END IF 27022 IF ( LSAME( 'Upper', UPLO ) ) THEN 27023 DO I = 1, NCOLS 27024 UMAX = WORK( I ) 27025 AMAX = WORK( NCOLS+I ) 27026 IF ( UMAX /= 0.0 ) THEN 27027 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 27028 END IF 27029 END DO 27030 ELSE 27031 DO I = 1, NCOLS 27032 UMAX = WORK( I ) 27033 AMAX = WORK( NCOLS+I ) 27034 IF ( UMAX /= 0.0 ) THEN 27035 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 27036 END IF 27037 END DO 27038 END IF 27039 SLA_PORPVGRW = RPVGRW 27040 END 27041! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sla_syrcond.f 27042 REAL FUNCTION SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, 27043 $ C, INFO, WORK, IWORK ) 27044 CHARACTER UPLO 27045 INTEGER N, LDA, LDAF, INFO, CMODE 27046 INTEGER IWORK( * ), IPIV( * ) 27047 REAL A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * ) 27048 CHARACTER NORMIN 27049 INTEGER KASE, I, J 27050 REAL AINVNM, SMLNUM, TMP 27051 LOGICAL UP 27052 INTEGER ISAVE( 3 ) 27053 LOGICAL LSAME 27054 REAL SLAMCH 27055 EXTERNAL LSAME, SLAMCH 27056 EXTERNAL SLACN2, XERBLA, SSYTRS 27057 INTRINSIC ABS, MAX 27058 SLA_SYRCOND = 0.0 27059 INFO = 0 27060 IF( N.LT.0 ) THEN 27061 INFO = -2 27062 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 27063 INFO = -4 27064 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 27065 INFO = -6 27066 END IF 27067 IF( INFO.NE.0 ) THEN 27068 CALL XERBLA( 'SLA_SYRCOND', -INFO ) 27069 RETURN 27070 END IF 27071 IF( N.EQ.0 ) THEN 27072 SLA_SYRCOND = 1.0 27073 RETURN 27074 END IF 27075 UP = .FALSE. 27076 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 27077 IF ( UP ) THEN 27078 DO I = 1, N 27079 TMP = 0.0 27080 IF ( CMODE .EQ. 1 ) THEN 27081 DO J = 1, I 27082 TMP = TMP + ABS( A( J, I ) * C( J ) ) 27083 END DO 27084 DO J = I+1, N 27085 TMP = TMP + ABS( A( I, J ) * C( J ) ) 27086 END DO 27087 ELSE IF ( CMODE .EQ. 0 ) THEN 27088 DO J = 1, I 27089 TMP = TMP + ABS( A( J, I ) ) 27090 END DO 27091 DO J = I+1, N 27092 TMP = TMP + ABS( A( I, J ) ) 27093 END DO 27094 ELSE 27095 DO J = 1, I 27096 TMP = TMP + ABS( A( J, I ) / C( J ) ) 27097 END DO 27098 DO J = I+1, N 27099 TMP = TMP + ABS( A( I, J ) / C( J ) ) 27100 END DO 27101 END IF 27102 WORK( 2*N+I ) = TMP 27103 END DO 27104 ELSE 27105 DO I = 1, N 27106 TMP = 0.0 27107 IF ( CMODE .EQ. 1 ) THEN 27108 DO J = 1, I 27109 TMP = TMP + ABS( A( I, J ) * C( J ) ) 27110 END DO 27111 DO J = I+1, N 27112 TMP = TMP + ABS( A( J, I ) * C( J ) ) 27113 END DO 27114 ELSE IF ( CMODE .EQ. 0 ) THEN 27115 DO J = 1, I 27116 TMP = TMP + ABS( A( I, J ) ) 27117 END DO 27118 DO J = I+1, N 27119 TMP = TMP + ABS( A( J, I ) ) 27120 END DO 27121 ELSE 27122 DO J = 1, I 27123 TMP = TMP + ABS( A( I, J) / C( J ) ) 27124 END DO 27125 DO J = I+1, N 27126 TMP = TMP + ABS( A( J, I) / C( J ) ) 27127 END DO 27128 END IF 27129 WORK( 2*N+I ) = TMP 27130 END DO 27131 ENDIF 27132 SMLNUM = SLAMCH( 'Safe minimum' ) 27133 AINVNM = 0.0 27134 NORMIN = 'N' 27135 KASE = 0 27136 10 CONTINUE 27137 CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) 27138 IF( KASE.NE.0 ) THEN 27139 IF( KASE.EQ.2 ) THEN 27140 DO I = 1, N 27141 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 27142 END DO 27143 IF ( UP ) THEN 27144 CALL SSYTRS( 'U', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) 27145 ELSE 27146 CALL SSYTRS( 'L', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) 27147 ENDIF 27148 IF ( CMODE .EQ. 1 ) THEN 27149 DO I = 1, N 27150 WORK( I ) = WORK( I ) / C( I ) 27151 END DO 27152 ELSE IF ( CMODE .EQ. -1 ) THEN 27153 DO I = 1, N 27154 WORK( I ) = WORK( I ) * C( I ) 27155 END DO 27156 END IF 27157 ELSE 27158 IF ( CMODE .EQ. 1 ) THEN 27159 DO I = 1, N 27160 WORK( I ) = WORK( I ) / C( I ) 27161 END DO 27162 ELSE IF ( CMODE .EQ. -1 ) THEN 27163 DO I = 1, N 27164 WORK( I ) = WORK( I ) * C( I ) 27165 END DO 27166 END IF 27167 IF ( UP ) THEN 27168 CALL SSYTRS( 'U', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) 27169 ELSE 27170 CALL SSYTRS( 'L', N, 1, AF, LDAF, IPIV, WORK, N, INFO ) 27171 ENDIF 27172 DO I = 1, N 27173 WORK( I ) = WORK( I ) * WORK( 2*N+I ) 27174 END DO 27175 END IF 27176 GO TO 10 27177 END IF 27178 IF( AINVNM .NE. 0.0 ) 27179 $ SLA_SYRCOND = ( 1.0 / AINVNM ) 27180 RETURN 27181 END 27182! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sla_syrpvgrw.f 27183 REAL FUNCTION SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, 27184 $ WORK ) 27185 CHARACTER*1 UPLO 27186 INTEGER N, INFO, LDA, LDAF 27187 INTEGER IPIV( * ) 27188 REAL A( LDA, * ), AF( LDAF, * ), WORK( * ) 27189 INTEGER NCOLS, I, J, K, KP 27190 REAL AMAX, UMAX, RPVGRW, TMP 27191 LOGICAL UPPER 27192 INTRINSIC ABS, MAX, MIN 27193 EXTERNAL LSAME 27194 LOGICAL LSAME 27195 UPPER = LSAME( 'Upper', UPLO ) 27196 IF ( INFO.EQ.0 ) THEN 27197 IF ( UPPER ) THEN 27198 NCOLS = 1 27199 ELSE 27200 NCOLS = N 27201 END IF 27202 ELSE 27203 NCOLS = INFO 27204 END IF 27205 RPVGRW = 1.0 27206 DO I = 1, 2*N 27207 WORK( I ) = 0.0 27208 END DO 27209 IF ( UPPER ) THEN 27210 DO J = 1, N 27211 DO I = 1, J 27212 WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) ) 27213 WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) ) 27214 END DO 27215 END DO 27216 ELSE 27217 DO J = 1, N 27218 DO I = J, N 27219 WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) ) 27220 WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) ) 27221 END DO 27222 END DO 27223 END IF 27224 IF ( UPPER ) THEN 27225 K = N 27226 DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) 27227 IF ( IPIV( K ).GT.0 ) THEN 27228 KP = IPIV( K ) 27229 IF ( KP .NE. K ) THEN 27230 TMP = WORK( N+K ) 27231 WORK( N+K ) = WORK( N+KP ) 27232 WORK( N+KP ) = TMP 27233 END IF 27234 DO I = 1, K 27235 WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) 27236 END DO 27237 K = K - 1 27238 ELSE 27239 KP = -IPIV( K ) 27240 TMP = WORK( N+K-1 ) 27241 WORK( N+K-1 ) = WORK( N+KP ) 27242 WORK( N+KP ) = TMP 27243 DO I = 1, K-1 27244 WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) 27245 WORK( K-1 ) = MAX( ABS( AF( I, K-1 ) ), WORK( K-1 ) ) 27246 END DO 27247 WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) ) 27248 K = K - 2 27249 END IF 27250 END DO 27251 K = NCOLS 27252 DO WHILE ( K .LE. N ) 27253 IF ( IPIV( K ).GT.0 ) THEN 27254 KP = IPIV( K ) 27255 IF ( KP .NE. K ) THEN 27256 TMP = WORK( N+K ) 27257 WORK( N+K ) = WORK( N+KP ) 27258 WORK( N+KP ) = TMP 27259 END IF 27260 K = K + 1 27261 ELSE 27262 KP = -IPIV( K ) 27263 TMP = WORK( N+K ) 27264 WORK( N+K ) = WORK( N+KP ) 27265 WORK( N+KP ) = TMP 27266 K = K + 2 27267 END IF 27268 END DO 27269 ELSE 27270 K = 1 27271 DO WHILE ( K .LE. NCOLS ) 27272 IF ( IPIV( K ).GT.0 ) THEN 27273 KP = IPIV( K ) 27274 IF ( KP .NE. K ) THEN 27275 TMP = WORK( N+K ) 27276 WORK( N+K ) = WORK( N+KP ) 27277 WORK( N+KP ) = TMP 27278 END IF 27279 DO I = K, N 27280 WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) 27281 END DO 27282 K = K + 1 27283 ELSE 27284 KP = -IPIV( K ) 27285 TMP = WORK( N+K+1 ) 27286 WORK( N+K+1 ) = WORK( N+KP ) 27287 WORK( N+KP ) = TMP 27288 DO I = K+1, N 27289 WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) 27290 WORK( K+1 ) = MAX( ABS( AF(I, K+1 ) ), WORK( K+1 ) ) 27291 END DO 27292 WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) ) 27293 K = K + 2 27294 END IF 27295 END DO 27296 K = NCOLS 27297 DO WHILE ( K .GE. 1 ) 27298 IF ( IPIV( K ).GT.0 ) THEN 27299 KP = IPIV( K ) 27300 IF ( KP .NE. K ) THEN 27301 TMP = WORK( N+K ) 27302 WORK( N+K ) = WORK( N+KP ) 27303 WORK( N+KP ) = TMP 27304 END IF 27305 K = K - 1 27306 ELSE 27307 KP = -IPIV( K ) 27308 TMP = WORK( N+K ) 27309 WORK( N+K ) = WORK( N+KP ) 27310 WORK( N+KP ) = TMP 27311 K = K - 2 27312 ENDIF 27313 END DO 27314 END IF 27315 IF ( UPPER ) THEN 27316 DO I = NCOLS, N 27317 UMAX = WORK( I ) 27318 AMAX = WORK( N+I ) 27319 IF ( UMAX /= 0.0 ) THEN 27320 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 27321 END IF 27322 END DO 27323 ELSE 27324 DO I = 1, NCOLS 27325 UMAX = WORK( I ) 27326 AMAX = WORK( N+I ) 27327 IF ( UMAX /= 0.0 ) THEN 27328 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 27329 END IF 27330 END DO 27331 END IF 27332 SLA_SYRPVGRW = RPVGRW 27333 END 27334! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slacn2.f 27335 SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) 27336 INTEGER KASE, N 27337 REAL EST 27338 INTEGER ISGN( * ), ISAVE( 3 ) 27339 REAL V( * ), X( * ) 27340 INTEGER ITMAX 27341 PARAMETER ( ITMAX = 5 ) 27342 REAL ZERO, ONE, TWO 27343 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) 27344 INTEGER I, JLAST 27345 REAL ALTSGN, ESTOLD, TEMP, XS 27346 INTEGER ISAMAX 27347 REAL SASUM 27348 EXTERNAL ISAMAX, SASUM 27349 EXTERNAL SCOPY 27350 INTRINSIC ABS, NINT, REAL 27351 IF( KASE.EQ.0 ) THEN 27352 DO 10 I = 1, N 27353 X( I ) = ONE / REAL( N ) 27354 10 CONTINUE 27355 KASE = 1 27356 ISAVE( 1 ) = 1 27357 RETURN 27358 END IF 27359 GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 ) 27360 20 CONTINUE 27361 IF( N.EQ.1 ) THEN 27362 V( 1 ) = X( 1 ) 27363 EST = ABS( V( 1 ) ) 27364 GO TO 150 27365 END IF 27366 EST = SASUM( N, X, 1 ) 27367 DO 30 I = 1, N 27368 IF( X(I).GE.ZERO ) THEN 27369 X(I) = ONE 27370 ELSE 27371 X(I) = -ONE 27372 END IF 27373 ISGN( I ) = NINT( X( I ) ) 27374 30 CONTINUE 27375 KASE = 2 27376 ISAVE( 1 ) = 2 27377 RETURN 27378 40 CONTINUE 27379 ISAVE( 2 ) = ISAMAX( N, X, 1 ) 27380 ISAVE( 3 ) = 2 27381 50 CONTINUE 27382 DO 60 I = 1, N 27383 X( I ) = ZERO 27384 60 CONTINUE 27385 X( ISAVE( 2 ) ) = ONE 27386 KASE = 1 27387 ISAVE( 1 ) = 3 27388 RETURN 27389 70 CONTINUE 27390 CALL SCOPY( N, X, 1, V, 1 ) 27391 ESTOLD = EST 27392 EST = SASUM( N, V, 1 ) 27393 DO 80 I = 1, N 27394 IF( X(I).GE.ZERO ) THEN 27395 XS = ONE 27396 ELSE 27397 XS = -ONE 27398 END IF 27399 IF( NINT( XS ).NE.ISGN( I ) ) 27400 $ GO TO 90 27401 80 CONTINUE 27402 GO TO 120 27403 90 CONTINUE 27404 IF( EST.LE.ESTOLD ) 27405 $ GO TO 120 27406 DO 100 I = 1, N 27407 IF( X(I).GE.ZERO ) THEN 27408 X(I) = ONE 27409 ELSE 27410 X(I) = -ONE 27411 END IF 27412 ISGN( I ) = NINT( X( I ) ) 27413 100 CONTINUE 27414 KASE = 2 27415 ISAVE( 1 ) = 4 27416 RETURN 27417 110 CONTINUE 27418 JLAST = ISAVE( 2 ) 27419 ISAVE( 2 ) = ISAMAX( N, X, 1 ) 27420 IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. 27421 $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN 27422 ISAVE( 3 ) = ISAVE( 3 ) + 1 27423 GO TO 50 27424 END IF 27425 120 CONTINUE 27426 ALTSGN = ONE 27427 DO 130 I = 1, N 27428 X( I ) = ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) ) 27429 ALTSGN = -ALTSGN 27430 130 CONTINUE 27431 KASE = 1 27432 ISAVE( 1 ) = 5 27433 RETURN 27434 140 CONTINUE 27435 TEMP = TWO*( SASUM( N, X, 1 ) / REAL( 3*N ) ) 27436 IF( TEMP.GT.EST ) THEN 27437 CALL SCOPY( N, X, 1, V, 1 ) 27438 EST = TEMP 27439 END IF 27440 150 CONTINUE 27441 KASE = 0 27442 RETURN 27443 END 27444! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/sladiv.f 27445 SUBROUTINE SLADIV( A, B, C, D, P, Q ) 27446 REAL A, B, C, D, P, Q 27447 REAL BS 27448 PARAMETER ( BS = 2.0E0 ) 27449 REAL HALF 27450 PARAMETER ( HALF = 0.5E0 ) 27451 REAL TWO 27452 PARAMETER ( TWO = 2.0E0 ) 27453 REAL AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS 27454 REAL SLAMCH 27455 EXTERNAL SLAMCH 27456 EXTERNAL SLADIV1 27457 INTRINSIC ABS, MAX 27458 AA = A 27459 BB = B 27460 CC = C 27461 DD = D 27462 AB = MAX( ABS(A), ABS(B) ) 27463 CD = MAX( ABS(C), ABS(D) ) 27464 S = 1.0E0 27465 OV = SLAMCH( 'Overflow threshold' ) 27466 UN = SLAMCH( 'Safe minimum' ) 27467 EPS = SLAMCH( 'Epsilon' ) 27468 BE = BS / (EPS*EPS) 27469 IF( AB >= HALF*OV ) THEN 27470 AA = HALF * AA 27471 BB = HALF * BB 27472 S = TWO * S 27473 END IF 27474 IF( CD >= HALF*OV ) THEN 27475 CC = HALF * CC 27476 DD = HALF * DD 27477 S = HALF * S 27478 END IF 27479 IF( AB <= UN*BS/EPS ) THEN 27480 AA = AA * BE 27481 BB = BB * BE 27482 S = S / BE 27483 END IF 27484 IF( CD <= UN*BS/EPS ) THEN 27485 CC = CC * BE 27486 DD = DD * BE 27487 S = S * BE 27488 END IF 27489 IF( ABS( D ).LE.ABS( C ) ) THEN 27490 CALL SLADIV1(AA, BB, CC, DD, P, Q) 27491 ELSE 27492 CALL SLADIV1(BB, AA, DD, CC, P, Q) 27493 Q = -Q 27494 END IF 27495 P = P * S 27496 Q = Q * S 27497 RETURN 27498 END 27499 SUBROUTINE SLADIV1( A, B, C, D, P, Q ) 27500 REAL A, B, C, D, P, Q 27501 REAL ONE 27502 PARAMETER ( ONE = 1.0E0 ) 27503 REAL R, T 27504 REAL SLADIV2 27505 EXTERNAL SLADIV2 27506 R = D / C 27507 T = ONE / (C + D * R) 27508 P = SLADIV2(A, B, C, D, R, T) 27509 A = -A 27510 Q = SLADIV2(B, A, C, D, R, T) 27511 RETURN 27512 END 27513 REAL FUNCTION SLADIV2( A, B, C, D, R, T ) 27514 REAL A, B, C, D, R, T 27515 REAL ZERO 27516 PARAMETER ( ZERO = 0.0E0 ) 27517 REAL BR 27518 IF( R.NE.ZERO ) THEN 27519 BR = B * R 27520 if( BR.NE.ZERO ) THEN 27521 SLADIV2 = (A + BR) * T 27522 ELSE 27523 SLADIV2 = A * T + (B * T) * R 27524 END IF 27525 ELSE 27526 SLADIV2 = (A + D * (B / C)) * T 27527 END IF 27528 RETURN 27529 END 27530! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slaisnan.f 27531 LOGICAL FUNCTION SLAISNAN( SIN1, SIN2 ) 27532 REAL, INTENT(IN) :: SIN1, SIN2 27533 SLAISNAN = (SIN1.NE.SIN2) 27534 RETURN 27535 END 27536! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slaneg.f 27537 INTEGER FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R ) 27538 INTEGER N, R 27539 REAL PIVMIN, SIGMA 27540 REAL D( * ), LLD( * ) 27541 REAL ZERO, ONE 27542 PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) 27543 INTEGER BLKLEN 27544 PARAMETER ( BLKLEN = 128 ) 27545 INTEGER BJ, J, NEG1, NEG2, NEGCNT 27546 REAL BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP 27547 LOGICAL SAWNAN 27548 INTRINSIC MIN, MAX 27549 LOGICAL SISNAN 27550 EXTERNAL SISNAN 27551 NEGCNT = 0 27552 T = -SIGMA 27553 DO 210 BJ = 1, R-1, BLKLEN 27554 NEG1 = 0 27555 BSAV = T 27556 DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1) 27557 DPLUS = D( J ) + T 27558 IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1 27559 TMP = T / DPLUS 27560 T = TMP * LLD( J ) - SIGMA 27561 21 CONTINUE 27562 SAWNAN = SISNAN( T ) 27563 IF( SAWNAN ) THEN 27564 NEG1 = 0 27565 T = BSAV 27566 DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1) 27567 DPLUS = D( J ) + T 27568 IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1 27569 TMP = T / DPLUS 27570 IF (SISNAN(TMP)) TMP = ONE 27571 T = TMP * LLD(J) - SIGMA 27572 22 CONTINUE 27573 END IF 27574 NEGCNT = NEGCNT + NEG1 27575 210 CONTINUE 27576 P = D( N ) - SIGMA 27577 DO 230 BJ = N-1, R, -BLKLEN 27578 NEG2 = 0 27579 BSAV = P 27580 DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1 27581 DMINUS = LLD( J ) + P 27582 IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1 27583 TMP = P / DMINUS 27584 P = TMP * D( J ) - SIGMA 27585 23 CONTINUE 27586 SAWNAN = SISNAN( P ) 27587 IF( SAWNAN ) THEN 27588 NEG2 = 0 27589 P = BSAV 27590 DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1 27591 DMINUS = LLD( J ) + P 27592 IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1 27593 TMP = P / DMINUS 27594 IF (SISNAN(TMP)) TMP = ONE 27595 P = TMP * D(J) - SIGMA 27596 24 CONTINUE 27597 END IF 27598 NEGCNT = NEGCNT + NEG2 27599 230 CONTINUE 27600 GAMMA = (T + SIGMA) + P 27601 IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1 27602 SLANEG = NEGCNT 27603 END 27604! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slangb.f 27605 REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, 27606 $ WORK ) 27607 IMPLICIT NONE 27608 CHARACTER NORM 27609 INTEGER KL, KU, LDAB, N 27610 REAL AB( LDAB, * ), WORK( * ) 27611 REAL ONE, ZERO 27612 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 27613 INTEGER I, J, K, L 27614 REAL SUM, VALUE, TEMP 27615 REAL SSQ( 2 ), COLSSQ( 2 ) 27616 LOGICAL LSAME, SISNAN 27617 EXTERNAL LSAME, SISNAN 27618 EXTERNAL SLASSQ, SCOMBSSQ 27619 INTRINSIC ABS, MAX, MIN, SQRT 27620 IF( N.EQ.0 ) THEN 27621 VALUE = ZERO 27622 ELSE IF( LSAME( NORM, 'M' ) ) THEN 27623 VALUE = ZERO 27624 DO 20 J = 1, N 27625 DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) 27626 TEMP = ABS( AB( I, J ) ) 27627 IF( VALUE.LT.TEMP .OR. SISNAN( TEMP ) ) VALUE = TEMP 27628 10 CONTINUE 27629 20 CONTINUE 27630 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 27631 VALUE = ZERO 27632 DO 40 J = 1, N 27633 SUM = ZERO 27634 DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) 27635 SUM = SUM + ABS( AB( I, J ) ) 27636 30 CONTINUE 27637 IF( VALUE.LT.SUM .OR. SISNAN( SUM ) ) VALUE = SUM 27638 40 CONTINUE 27639 ELSE IF( LSAME( NORM, 'I' ) ) THEN 27640 DO 50 I = 1, N 27641 WORK( I ) = ZERO 27642 50 CONTINUE 27643 DO 70 J = 1, N 27644 K = KU + 1 - J 27645 DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL ) 27646 WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) ) 27647 60 CONTINUE 27648 70 CONTINUE 27649 VALUE = ZERO 27650 DO 80 I = 1, N 27651 TEMP = WORK( I ) 27652 IF( VALUE.LT.TEMP .OR. SISNAN( TEMP ) ) VALUE = TEMP 27653 80 CONTINUE 27654 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 27655 SSQ( 1 ) = ZERO 27656 SSQ( 2 ) = ONE 27657 DO 90 J = 1, N 27658 L = MAX( 1, J-KU ) 27659 K = KU + 1 - J + L 27660 COLSSQ( 1 ) = ZERO 27661 COLSSQ( 2 ) = ONE 27662 CALL SLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, 27663 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 27664 CALL SCOMBSSQ( SSQ, COLSSQ ) 27665 90 CONTINUE 27666 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 27667 END IF 27668 SLANGB = VALUE 27669 RETURN 27670 END 27671! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slange.f 27672 REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) 27673 IMPLICIT NONE 27674 CHARACTER NORM 27675 INTEGER LDA, M, N 27676 REAL A( LDA, * ), WORK( * ) 27677 REAL ONE, ZERO 27678 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 27679 INTEGER I, J 27680 REAL SUM, VALUE, TEMP 27681 REAL SSQ( 2 ), COLSSQ( 2 ) 27682 EXTERNAL SLASSQ, SCOMBSSQ 27683 LOGICAL LSAME, SISNAN 27684 EXTERNAL LSAME, SISNAN 27685 INTRINSIC ABS, MIN, SQRT 27686 IF( MIN( M, N ).EQ.0 ) THEN 27687 VALUE = ZERO 27688 ELSE IF( LSAME( NORM, 'M' ) ) THEN 27689 VALUE = ZERO 27690 DO 20 J = 1, N 27691 DO 10 I = 1, M 27692 TEMP = ABS( A( I, J ) ) 27693 IF( VALUE.LT.TEMP .OR. SISNAN( TEMP ) ) VALUE = TEMP 27694 10 CONTINUE 27695 20 CONTINUE 27696 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 27697 VALUE = ZERO 27698 DO 40 J = 1, N 27699 SUM = ZERO 27700 DO 30 I = 1, M 27701 SUM = SUM + ABS( A( I, J ) ) 27702 30 CONTINUE 27703 IF( VALUE.LT.SUM .OR. SISNAN( SUM ) ) VALUE = SUM 27704 40 CONTINUE 27705 ELSE IF( LSAME( NORM, 'I' ) ) THEN 27706 DO 50 I = 1, M 27707 WORK( I ) = ZERO 27708 50 CONTINUE 27709 DO 70 J = 1, N 27710 DO 60 I = 1, M 27711 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 27712 60 CONTINUE 27713 70 CONTINUE 27714 VALUE = ZERO 27715 DO 80 I = 1, M 27716 TEMP = WORK( I ) 27717 IF( VALUE.LT.TEMP .OR. SISNAN( TEMP ) ) VALUE = TEMP 27718 80 CONTINUE 27719 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 27720 SSQ( 1 ) = ZERO 27721 SSQ( 2 ) = ONE 27722 DO 90 J = 1, N 27723 COLSSQ( 1 ) = ZERO 27724 COLSSQ( 2 ) = ONE 27725 CALL SLASSQ( M, A( 1, J ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 27726 CALL SCOMBSSQ( SSQ, COLSSQ ) 27727 90 CONTINUE 27728 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 27729 END IF 27730 SLANGE = VALUE 27731 RETURN 27732 END 27733! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slangt.f 27734 REAL FUNCTION SLANGT( NORM, N, DL, D, DU ) 27735 CHARACTER NORM 27736 INTEGER N 27737 REAL D( * ), DL( * ), DU( * ) 27738 REAL ONE, ZERO 27739 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 27740 INTEGER I 27741 REAL ANORM, SCALE, SUM, TEMP 27742 LOGICAL LSAME, SISNAN 27743 EXTERNAL LSAME, SISNAN 27744 EXTERNAL SLASSQ 27745 INTRINSIC ABS, SQRT 27746 IF( N.LE.0 ) THEN 27747 ANORM = ZERO 27748 ELSE IF( LSAME( NORM, 'M' ) ) THEN 27749 ANORM = ABS( D( N ) ) 27750 DO 10 I = 1, N - 1 27751 IF( ANORM.LT.ABS( DL( I ) ) .OR. SISNAN( ABS( DL( I ) ) ) ) 27752 $ ANORM = ABS(DL(I)) 27753 IF( ANORM.LT.ABS( D( I ) ) .OR. SISNAN( ABS( D( I ) ) ) ) 27754 $ ANORM = ABS(D(I)) 27755 IF( ANORM.LT.ABS( DU( I ) ) .OR. SISNAN (ABS( DU( I ) ) ) ) 27756 $ ANORM = ABS(DU(I)) 27757 10 CONTINUE 27758 ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN 27759 IF( N.EQ.1 ) THEN 27760 ANORM = ABS( D( 1 ) ) 27761 ELSE 27762 ANORM = ABS( D( 1 ) )+ABS( DL( 1 ) ) 27763 TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) 27764 IF( ANORM .LT. TEMP .OR. SISNAN( TEMP ) ) ANORM = TEMP 27765 DO 20 I = 2, N - 1 27766 TEMP = ABS( D( I ) )+ABS( DL( I ) )+ABS( DU( I-1 ) ) 27767 IF( ANORM .LT. TEMP .OR. SISNAN( TEMP ) ) ANORM = TEMP 27768 20 CONTINUE 27769 END IF 27770 ELSE IF( LSAME( NORM, 'I' ) ) THEN 27771 IF( N.EQ.1 ) THEN 27772 ANORM = ABS( D( 1 ) ) 27773 ELSE 27774 ANORM = ABS( D( 1 ) )+ABS( DU( 1 ) ) 27775 TEMP = ABS( D( N ) )+ABS( DL( N-1 ) ) 27776 IF( ANORM .LT. TEMP .OR. SISNAN( TEMP ) ) ANORM = TEMP 27777 DO 30 I = 2, N - 1 27778 TEMP = ABS( D( I ) )+ABS( DU( I ) )+ABS( DL( I-1 ) ) 27779 IF( ANORM .LT. TEMP .OR. SISNAN( TEMP ) ) ANORM = TEMP 27780 30 CONTINUE 27781 END IF 27782 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 27783 SCALE = ZERO 27784 SUM = ONE 27785 CALL SLASSQ( N, D, 1, SCALE, SUM ) 27786 IF( N.GT.1 ) THEN 27787 CALL SLASSQ( N-1, DL, 1, SCALE, SUM ) 27788 CALL SLASSQ( N-1, DU, 1, SCALE, SUM ) 27789 END IF 27790 ANORM = SCALE*SQRT( SUM ) 27791 END IF 27792 SLANGT = ANORM 27793 RETURN 27794 END 27795! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slanhs.f 27796 REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK ) 27797 IMPLICIT NONE 27798 CHARACTER NORM 27799 INTEGER LDA, N 27800 REAL A( LDA, * ), WORK( * ) 27801 REAL ONE, ZERO 27802 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 27803 INTEGER I, J 27804 REAL SUM, VALUE 27805 REAL SSQ( 2 ), COLSSQ( 2 ) 27806 LOGICAL LSAME, SISNAN 27807 EXTERNAL LSAME, SISNAN 27808 EXTERNAL SLASSQ, SCOMBSSQ 27809 INTRINSIC ABS, MIN, SQRT 27810 IF( N.EQ.0 ) THEN 27811 VALUE = ZERO 27812 ELSE IF( LSAME( NORM, 'M' ) ) THEN 27813 VALUE = ZERO 27814 DO 20 J = 1, N 27815 DO 10 I = 1, MIN( N, J+1 ) 27816 SUM = ABS( A( I, J ) ) 27817 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 27818 10 CONTINUE 27819 20 CONTINUE 27820 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 27821 VALUE = ZERO 27822 DO 40 J = 1, N 27823 SUM = ZERO 27824 DO 30 I = 1, MIN( N, J+1 ) 27825 SUM = SUM + ABS( A( I, J ) ) 27826 30 CONTINUE 27827 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 27828 40 CONTINUE 27829 ELSE IF( LSAME( NORM, 'I' ) ) THEN 27830 DO 50 I = 1, N 27831 WORK( I ) = ZERO 27832 50 CONTINUE 27833 DO 70 J = 1, N 27834 DO 60 I = 1, MIN( N, J+1 ) 27835 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 27836 60 CONTINUE 27837 70 CONTINUE 27838 VALUE = ZERO 27839 DO 80 I = 1, N 27840 SUM = WORK( I ) 27841 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 27842 80 CONTINUE 27843 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 27844 SSQ( 1 ) = ZERO 27845 SSQ( 2 ) = ONE 27846 DO 90 J = 1, N 27847 COLSSQ( 1 ) = ZERO 27848 COLSSQ( 2 ) = ONE 27849 CALL SLASSQ( MIN( N, J+1 ), A( 1, J ), 1, 27850 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 27851 CALL SCOMBSSQ( SSQ, COLSSQ ) 27852 90 CONTINUE 27853 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 27854 END IF 27855 SLANHS = VALUE 27856 RETURN 27857 END 27858! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slansb.f 27859 REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, 27860 $ WORK ) 27861 IMPLICIT NONE 27862 CHARACTER NORM, UPLO 27863 INTEGER K, LDAB, N 27864 REAL AB( LDAB, * ), WORK( * ) 27865 REAL ONE, ZERO 27866 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 27867 INTEGER I, J, L 27868 REAL ABSA, SUM, VALUE 27869 REAL SSQ( 2 ), COLSSQ( 2 ) 27870 LOGICAL LSAME, SISNAN 27871 EXTERNAL LSAME, SISNAN 27872 EXTERNAL SLASSQ, SCOMBSSQ 27873 INTRINSIC ABS, MAX, MIN, SQRT 27874 IF( N.EQ.0 ) THEN 27875 VALUE = ZERO 27876 ELSE IF( LSAME( NORM, 'M' ) ) THEN 27877 VALUE = ZERO 27878 IF( LSAME( UPLO, 'U' ) ) THEN 27879 DO 20 J = 1, N 27880 DO 10 I = MAX( K+2-J, 1 ), K + 1 27881 SUM = ABS( AB( I, J ) ) 27882 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 27883 10 CONTINUE 27884 20 CONTINUE 27885 ELSE 27886 DO 40 J = 1, N 27887 DO 30 I = 1, MIN( N+1-J, K+1 ) 27888 SUM = ABS( AB( I, J ) ) 27889 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 27890 30 CONTINUE 27891 40 CONTINUE 27892 END IF 27893 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 27894 $ ( NORM.EQ.'1' ) ) THEN 27895 VALUE = ZERO 27896 IF( LSAME( UPLO, 'U' ) ) THEN 27897 DO 60 J = 1, N 27898 SUM = ZERO 27899 L = K + 1 - J 27900 DO 50 I = MAX( 1, J-K ), J - 1 27901 ABSA = ABS( AB( L+I, J ) ) 27902 SUM = SUM + ABSA 27903 WORK( I ) = WORK( I ) + ABSA 27904 50 CONTINUE 27905 WORK( J ) = SUM + ABS( AB( K+1, J ) ) 27906 60 CONTINUE 27907 DO 70 I = 1, N 27908 SUM = WORK( I ) 27909 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 27910 70 CONTINUE 27911 ELSE 27912 DO 80 I = 1, N 27913 WORK( I ) = ZERO 27914 80 CONTINUE 27915 DO 100 J = 1, N 27916 SUM = WORK( J ) + ABS( AB( 1, J ) ) 27917 L = 1 - J 27918 DO 90 I = J + 1, MIN( N, J+K ) 27919 ABSA = ABS( AB( L+I, J ) ) 27920 SUM = SUM + ABSA 27921 WORK( I ) = WORK( I ) + ABSA 27922 90 CONTINUE 27923 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 27924 100 CONTINUE 27925 END IF 27926 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 27927 SSQ( 1 ) = ZERO 27928 SSQ( 2 ) = ONE 27929 IF( K.GT.0 ) THEN 27930 IF( LSAME( UPLO, 'U' ) ) THEN 27931 DO 110 J = 2, N 27932 COLSSQ( 1 ) = ZERO 27933 COLSSQ( 2 ) = ONE 27934 CALL SLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), 27935 $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 27936 CALL SCOMBSSQ( SSQ, COLSSQ ) 27937 110 CONTINUE 27938 L = K + 1 27939 ELSE 27940 DO 120 J = 1, N - 1 27941 COLSSQ( 1 ) = ZERO 27942 COLSSQ( 2 ) = ONE 27943 CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, 27944 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 27945 CALL SCOMBSSQ( SSQ, COLSSQ ) 27946 120 CONTINUE 27947 L = 1 27948 END IF 27949 SSQ( 2 ) = 2*SSQ( 2 ) 27950 ELSE 27951 L = 1 27952 END IF 27953 COLSSQ( 1 ) = ZERO 27954 COLSSQ( 2 ) = ONE 27955 CALL SLASSQ( N, AB( L, 1 ), LDAB, COLSSQ( 1 ), COLSSQ( 2 ) ) 27956 CALL SCOMBSSQ( SSQ, COLSSQ ) 27957 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 27958 END IF 27959 SLANSB = VALUE 27960 RETURN 27961 END 27962! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slansf.f 27963 REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) 27964 CHARACTER NORM, TRANSR, UPLO 27965 INTEGER N 27966 REAL A( 0: * ), WORK( 0: * ) 27967 REAL ONE, ZERO 27968 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 27969 INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA 27970 REAL SCALE, S, VALUE, AA, TEMP 27971 LOGICAL LSAME, SISNAN 27972 EXTERNAL LSAME, SISNAN 27973 EXTERNAL SLASSQ 27974 INTRINSIC ABS, SQRT 27975 IF( N.EQ.0 ) THEN 27976 SLANSF = ZERO 27977 RETURN 27978 ELSE IF( N.EQ.1 ) THEN 27979 SLANSF = ABS( A(0) ) 27980 RETURN 27981 END IF 27982 NOE = 1 27983 IF( MOD( N, 2 ).EQ.0 ) 27984 $ NOE = 0 27985 IFM = 1 27986 IF( LSAME( TRANSR, 'T' ) ) 27987 $ IFM = 0 27988 ILU = 1 27989 IF( LSAME( UPLO, 'U' ) ) 27990 $ ILU = 0 27991 IF( IFM.EQ.1 ) THEN 27992 IF( NOE.EQ.1 ) THEN 27993 LDA = N 27994 ELSE 27995 LDA = N + 1 27996 END IF 27997 ELSE 27998 LDA = ( N+1 ) / 2 27999 END IF 28000 IF( LSAME( NORM, 'M' ) ) THEN 28001 K = ( N+1 ) / 2 28002 VALUE = ZERO 28003 IF( NOE.EQ.1 ) THEN 28004 IF( IFM.EQ.1 ) THEN 28005 DO J = 0, K - 1 28006 DO I = 0, N - 1 28007 TEMP = ABS( A( I+J*LDA ) ) 28008 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28009 $ VALUE = TEMP 28010 END DO 28011 END DO 28012 ELSE 28013 DO J = 0, N - 1 28014 DO I = 0, K - 1 28015 TEMP = ABS( A( I+J*LDA ) ) 28016 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28017 $ VALUE = TEMP 28018 END DO 28019 END DO 28020 END IF 28021 ELSE 28022 IF( IFM.EQ.1 ) THEN 28023 DO J = 0, K - 1 28024 DO I = 0, N 28025 TEMP = ABS( A( I+J*LDA ) ) 28026 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28027 $ VALUE = TEMP 28028 END DO 28029 END DO 28030 ELSE 28031 DO J = 0, N 28032 DO I = 0, K - 1 28033 TEMP = ABS( A( I+J*LDA ) ) 28034 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28035 $ VALUE = TEMP 28036 END DO 28037 END DO 28038 END IF 28039 END IF 28040 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 28041 $ ( NORM.EQ.'1' ) ) THEN 28042 IF( IFM.EQ.1 ) THEN 28043 K = N / 2 28044 IF( NOE.EQ.1 ) THEN 28045 IF( ILU.EQ.0 ) THEN 28046 DO I = 0, K - 1 28047 WORK( I ) = ZERO 28048 END DO 28049 DO J = 0, K 28050 S = ZERO 28051 DO I = 0, K + J - 1 28052 AA = ABS( A( I+J*LDA ) ) 28053 S = S + AA 28054 WORK( I ) = WORK( I ) + AA 28055 END DO 28056 AA = ABS( A( I+J*LDA ) ) 28057 WORK( J+K ) = S + AA 28058 IF( I.EQ.K+K ) 28059 $ GO TO 10 28060 I = I + 1 28061 AA = ABS( A( I+J*LDA ) ) 28062 WORK( J ) = WORK( J ) + AA 28063 S = ZERO 28064 DO L = J + 1, K - 1 28065 I = I + 1 28066 AA = ABS( A( I+J*LDA ) ) 28067 S = S + AA 28068 WORK( L ) = WORK( L ) + AA 28069 END DO 28070 WORK( J ) = WORK( J ) + S 28071 END DO 28072 10 CONTINUE 28073 VALUE = WORK( 0 ) 28074 DO I = 1, N-1 28075 TEMP = WORK( I ) 28076 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28077 $ VALUE = TEMP 28078 END DO 28079 ELSE 28080 K = K + 1 28081 DO I = K, N - 1 28082 WORK( I ) = ZERO 28083 END DO 28084 DO J = K - 1, 0, -1 28085 S = ZERO 28086 DO I = 0, J - 2 28087 AA = ABS( A( I+J*LDA ) ) 28088 S = S + AA 28089 WORK( I+K ) = WORK( I+K ) + AA 28090 END DO 28091 IF( J.GT.0 ) THEN 28092 AA = ABS( A( I+J*LDA ) ) 28093 S = S + AA 28094 WORK( I+K ) = WORK( I+K ) + S 28095 I = I + 1 28096 END IF 28097 AA = ABS( A( I+J*LDA ) ) 28098 WORK( J ) = AA 28099 S = ZERO 28100 DO L = J + 1, N - 1 28101 I = I + 1 28102 AA = ABS( A( I+J*LDA ) ) 28103 S = S + AA 28104 WORK( L ) = WORK( L ) + AA 28105 END DO 28106 WORK( J ) = WORK( J ) + S 28107 END DO 28108 VALUE = WORK( 0 ) 28109 DO I = 1, N-1 28110 TEMP = WORK( I ) 28111 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28112 $ VALUE = TEMP 28113 END DO 28114 END IF 28115 ELSE 28116 IF( ILU.EQ.0 ) THEN 28117 DO I = 0, K - 1 28118 WORK( I ) = ZERO 28119 END DO 28120 DO J = 0, K - 1 28121 S = ZERO 28122 DO I = 0, K + J - 1 28123 AA = ABS( A( I+J*LDA ) ) 28124 S = S + AA 28125 WORK( I ) = WORK( I ) + AA 28126 END DO 28127 AA = ABS( A( I+J*LDA ) ) 28128 WORK( J+K ) = S + AA 28129 I = I + 1 28130 AA = ABS( A( I+J*LDA ) ) 28131 WORK( J ) = WORK( J ) + AA 28132 S = ZERO 28133 DO L = J + 1, K - 1 28134 I = I + 1 28135 AA = ABS( A( I+J*LDA ) ) 28136 S = S + AA 28137 WORK( L ) = WORK( L ) + AA 28138 END DO 28139 WORK( J ) = WORK( J ) + S 28140 END DO 28141 VALUE = WORK( 0 ) 28142 DO I = 1, N-1 28143 TEMP = WORK( I ) 28144 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28145 $ VALUE = TEMP 28146 END DO 28147 ELSE 28148 DO I = K, N - 1 28149 WORK( I ) = ZERO 28150 END DO 28151 DO J = K - 1, 0, -1 28152 S = ZERO 28153 DO I = 0, J - 1 28154 AA = ABS( A( I+J*LDA ) ) 28155 S = S + AA 28156 WORK( I+K ) = WORK( I+K ) + AA 28157 END DO 28158 AA = ABS( A( I+J*LDA ) ) 28159 S = S + AA 28160 WORK( I+K ) = WORK( I+K ) + S 28161 I = I + 1 28162 AA = ABS( A( I+J*LDA ) ) 28163 WORK( J ) = AA 28164 S = ZERO 28165 DO L = J + 1, N - 1 28166 I = I + 1 28167 AA = ABS( A( I+J*LDA ) ) 28168 S = S + AA 28169 WORK( L ) = WORK( L ) + AA 28170 END DO 28171 WORK( J ) = WORK( J ) + S 28172 END DO 28173 VALUE = WORK( 0 ) 28174 DO I = 1, N-1 28175 TEMP = WORK( I ) 28176 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28177 $ VALUE = TEMP 28178 END DO 28179 END IF 28180 END IF 28181 ELSE 28182 K = N / 2 28183 IF( NOE.EQ.1 ) THEN 28184 IF( ILU.EQ.0 ) THEN 28185 N1 = K 28186 K = K + 1 28187 DO I = N1, N - 1 28188 WORK( I ) = ZERO 28189 END DO 28190 DO J = 0, N1 - 1 28191 S = ZERO 28192 DO I = 0, K - 1 28193 AA = ABS( A( I+J*LDA ) ) 28194 WORK( I+N1 ) = WORK( I+N1 ) + AA 28195 S = S + AA 28196 END DO 28197 WORK( J ) = S 28198 END DO 28199 S = ABS( A( 0+J*LDA ) ) 28200 DO I = 1, K - 1 28201 AA = ABS( A( I+J*LDA ) ) 28202 WORK( I+N1 ) = WORK( I+N1 ) + AA 28203 S = S + AA 28204 END DO 28205 WORK( J ) = WORK( J ) + S 28206 DO J = K, N - 1 28207 S = ZERO 28208 DO I = 0, J - K - 1 28209 AA = ABS( A( I+J*LDA ) ) 28210 WORK( I ) = WORK( I ) + AA 28211 S = S + AA 28212 END DO 28213 AA = ABS( A( I+J*LDA ) ) 28214 S = S + AA 28215 WORK( J-K ) = WORK( J-K ) + S 28216 I = I + 1 28217 S = ABS( A( I+J*LDA ) ) 28218 DO L = J + 1, N - 1 28219 I = I + 1 28220 AA = ABS( A( I+J*LDA ) ) 28221 WORK( L ) = WORK( L ) + AA 28222 S = S + AA 28223 END DO 28224 WORK( J ) = WORK( J ) + S 28225 END DO 28226 VALUE = WORK( 0 ) 28227 DO I = 1, N-1 28228 TEMP = WORK( I ) 28229 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28230 $ VALUE = TEMP 28231 END DO 28232 ELSE 28233 K = K + 1 28234 DO I = K, N - 1 28235 WORK( I ) = ZERO 28236 END DO 28237 DO J = 0, K - 2 28238 S = ZERO 28239 DO I = 0, J - 1 28240 AA = ABS( A( I+J*LDA ) ) 28241 WORK( I ) = WORK( I ) + AA 28242 S = S + AA 28243 END DO 28244 AA = ABS( A( I+J*LDA ) ) 28245 S = S + AA 28246 WORK( J ) = S 28247 I = I + 1 28248 AA = ABS( A( I+J*LDA ) ) 28249 S = AA 28250 DO L = K + J + 1, N - 1 28251 I = I + 1 28252 AA = ABS( A( I+J*LDA ) ) 28253 S = S + AA 28254 WORK( L ) = WORK( L ) + AA 28255 END DO 28256 WORK( K+J ) = WORK( K+J ) + S 28257 END DO 28258 S = ZERO 28259 DO I = 0, K - 2 28260 AA = ABS( A( I+J*LDA ) ) 28261 WORK( I ) = WORK( I ) + AA 28262 S = S + AA 28263 END DO 28264 AA = ABS( A( I+J*LDA ) ) 28265 S = S + AA 28266 WORK( I ) = S 28267 DO J = K, N - 1 28268 S = ZERO 28269 DO I = 0, K - 1 28270 AA = ABS( A( I+J*LDA ) ) 28271 WORK( I ) = WORK( I ) + AA 28272 S = S + AA 28273 END DO 28274 WORK( J ) = WORK( J ) + S 28275 END DO 28276 VALUE = WORK( 0 ) 28277 DO I = 1, N-1 28278 TEMP = WORK( I ) 28279 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28280 $ VALUE = TEMP 28281 END DO 28282 END IF 28283 ELSE 28284 IF( ILU.EQ.0 ) THEN 28285 DO I = K, N - 1 28286 WORK( I ) = ZERO 28287 END DO 28288 DO J = 0, K - 1 28289 S = ZERO 28290 DO I = 0, K - 1 28291 AA = ABS( A( I+J*LDA ) ) 28292 WORK( I+K ) = WORK( I+K ) + AA 28293 S = S + AA 28294 END DO 28295 WORK( J ) = S 28296 END DO 28297 AA = ABS( A( 0+J*LDA ) ) 28298 S = AA 28299 DO I = 1, K - 1 28300 AA = ABS( A( I+J*LDA ) ) 28301 WORK( I+K ) = WORK( I+K ) + AA 28302 S = S + AA 28303 END DO 28304 WORK( J ) = WORK( J ) + S 28305 DO J = K + 1, N - 1 28306 S = ZERO 28307 DO I = 0, J - 2 - K 28308 AA = ABS( A( I+J*LDA ) ) 28309 WORK( I ) = WORK( I ) + AA 28310 S = S + AA 28311 END DO 28312 AA = ABS( A( I+J*LDA ) ) 28313 S = S + AA 28314 WORK( J-K-1 ) = WORK( J-K-1 ) + S 28315 I = I + 1 28316 AA = ABS( A( I+J*LDA ) ) 28317 S = AA 28318 DO L = J + 1, N - 1 28319 I = I + 1 28320 AA = ABS( A( I+J*LDA ) ) 28321 WORK( L ) = WORK( L ) + AA 28322 S = S + AA 28323 END DO 28324 WORK( J ) = WORK( J ) + S 28325 END DO 28326 S = ZERO 28327 DO I = 0, K - 2 28328 AA = ABS( A( I+J*LDA ) ) 28329 WORK( I ) = WORK( I ) + AA 28330 S = S + AA 28331 END DO 28332 AA = ABS( A( I+J*LDA ) ) 28333 S = S + AA 28334 WORK( I ) = WORK( I ) + S 28335 VALUE = WORK ( 0 ) 28336 DO I = 1, N-1 28337 TEMP = WORK( I ) 28338 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28339 $ VALUE = TEMP 28340 END DO 28341 ELSE 28342 DO I = K, N - 1 28343 WORK( I ) = ZERO 28344 END DO 28345 S = ABS( A( 0 ) ) 28346 DO I = 1, K - 1 28347 AA = ABS( A( I ) ) 28348 WORK( I+K ) = WORK( I+K ) + AA 28349 S = S + AA 28350 END DO 28351 WORK( K ) = WORK( K ) + S 28352 DO J = 1, K - 1 28353 S = ZERO 28354 DO I = 0, J - 2 28355 AA = ABS( A( I+J*LDA ) ) 28356 WORK( I ) = WORK( I ) + AA 28357 S = S + AA 28358 END DO 28359 AA = ABS( A( I+J*LDA ) ) 28360 S = S + AA 28361 WORK( J-1 ) = S 28362 I = I + 1 28363 AA = ABS( A( I+J*LDA ) ) 28364 S = AA 28365 DO L = K + J + 1, N - 1 28366 I = I + 1 28367 AA = ABS( A( I+J*LDA ) ) 28368 S = S + AA 28369 WORK( L ) = WORK( L ) + AA 28370 END DO 28371 WORK( K+J ) = WORK( K+J ) + S 28372 END DO 28373 S = ZERO 28374 DO I = 0, K - 2 28375 AA = ABS( A( I+J*LDA ) ) 28376 WORK( I ) = WORK( I ) + AA 28377 S = S + AA 28378 END DO 28379 AA = ABS( A( I+J*LDA ) ) 28380 S = S + AA 28381 WORK( I ) = S 28382 DO J = K + 1, N 28383 S = ZERO 28384 DO I = 0, K - 1 28385 AA = ABS( A( I+J*LDA ) ) 28386 WORK( I ) = WORK( I ) + AA 28387 S = S + AA 28388 END DO 28389 WORK( J-1 ) = WORK( J-1 ) + S 28390 END DO 28391 VALUE = WORK( 0 ) 28392 DO I = 1, N-1 28393 TEMP = WORK( I ) 28394 IF( VALUE .LT. TEMP .OR. SISNAN( TEMP ) ) 28395 $ VALUE = TEMP 28396 END DO 28397 END IF 28398 END IF 28399 END IF 28400 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 28401 K = ( N+1 ) / 2 28402 SCALE = ZERO 28403 S = ONE 28404 IF( NOE.EQ.1 ) THEN 28405 IF( IFM.EQ.1 ) THEN 28406 IF( ILU.EQ.0 ) THEN 28407 DO J = 0, K - 3 28408 CALL SLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S ) 28409 END DO 28410 DO J = 0, K - 1 28411 CALL SLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S ) 28412 END DO 28413 S = S + S 28414 CALL SLASSQ( K-1, A( K ), LDA+1, SCALE, S ) 28415 CALL SLASSQ( K, A( K-1 ), LDA+1, SCALE, S ) 28416 ELSE 28417 DO J = 0, K - 1 28418 CALL SLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S ) 28419 END DO 28420 DO J = 0, K - 2 28421 CALL SLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S ) 28422 END DO 28423 S = S + S 28424 CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S ) 28425 CALL SLASSQ( K-1, A( 0+LDA ), LDA+1, SCALE, S ) 28426 END IF 28427 ELSE 28428 IF( ILU.EQ.0 ) THEN 28429 DO J = 1, K - 2 28430 CALL SLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S ) 28431 END DO 28432 DO J = 0, K - 2 28433 CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 28434 END DO 28435 DO J = 0, K - 2 28436 CALL SLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1, 28437 $ SCALE, S ) 28438 END DO 28439 S = S + S 28440 CALL SLASSQ( K-1, A( 0+K*LDA ), LDA+1, SCALE, S ) 28441 CALL SLASSQ( K, A( 0+( K-1 )*LDA ), LDA+1, SCALE, S ) 28442 ELSE 28443 DO J = 1, K - 1 28444 CALL SLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) 28445 END DO 28446 DO J = K, N - 1 28447 CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 28448 END DO 28449 DO J = 0, K - 3 28450 CALL SLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S ) 28451 END DO 28452 S = S + S 28453 CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S ) 28454 CALL SLASSQ( K-1, A( 1 ), LDA+1, SCALE, S ) 28455 END IF 28456 END IF 28457 ELSE 28458 IF( IFM.EQ.1 ) THEN 28459 IF( ILU.EQ.0 ) THEN 28460 DO J = 0, K - 2 28461 CALL SLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S ) 28462 END DO 28463 DO J = 0, K - 1 28464 CALL SLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S ) 28465 END DO 28466 S = S + S 28467 CALL SLASSQ( K, A( K+1 ), LDA+1, SCALE, S ) 28468 CALL SLASSQ( K, A( K ), LDA+1, SCALE, S ) 28469 ELSE 28470 DO J = 0, K - 1 28471 CALL SLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S ) 28472 END DO 28473 DO J = 1, K - 1 28474 CALL SLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) 28475 END DO 28476 S = S + S 28477 CALL SLASSQ( K, A( 1 ), LDA+1, SCALE, S ) 28478 CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S ) 28479 END IF 28480 ELSE 28481 IF( ILU.EQ.0 ) THEN 28482 DO J = 1, K - 1 28483 CALL SLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S ) 28484 END DO 28485 DO J = 0, K - 1 28486 CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 28487 END DO 28488 DO J = 0, K - 2 28489 CALL SLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE, 28490 $ S ) 28491 END DO 28492 S = S + S 28493 CALL SLASSQ( K, A( 0+( K+1 )*LDA ), LDA+1, SCALE, S ) 28494 CALL SLASSQ( K, A( 0+K*LDA ), LDA+1, SCALE, S ) 28495 ELSE 28496 DO J = 1, K - 1 28497 CALL SLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S ) 28498 END DO 28499 DO J = K + 1, N 28500 CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 28501 END DO 28502 DO J = 0, K - 2 28503 CALL SLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S ) 28504 END DO 28505 S = S + S 28506 CALL SLASSQ( K, A( LDA ), LDA+1, SCALE, S ) 28507 CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S ) 28508 END IF 28509 END IF 28510 END IF 28511 VALUE = SCALE*SQRT( S ) 28512 END IF 28513 SLANSF = VALUE 28514 RETURN 28515 END 28516! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slansp.f 28517 REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK ) 28518 IMPLICIT NONE 28519 CHARACTER NORM, UPLO 28520 INTEGER N 28521 REAL AP( * ), WORK( * ) 28522 REAL ONE, ZERO 28523 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 28524 INTEGER I, J, K 28525 REAL ABSA, SUM, VALUE 28526 REAL SSQ( 2 ), COLSSQ( 2 ) 28527 LOGICAL LSAME, SISNAN 28528 EXTERNAL LSAME, SISNAN 28529 EXTERNAL SLASSQ, SCOMBSSQ 28530 INTRINSIC ABS, SQRT 28531 IF( N.EQ.0 ) THEN 28532 VALUE = ZERO 28533 ELSE IF( LSAME( NORM, 'M' ) ) THEN 28534 VALUE = ZERO 28535 IF( LSAME( UPLO, 'U' ) ) THEN 28536 K = 1 28537 DO 20 J = 1, N 28538 DO 10 I = K, K + J - 1 28539 SUM = ABS( AP( I ) ) 28540 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28541 10 CONTINUE 28542 K = K + J 28543 20 CONTINUE 28544 ELSE 28545 K = 1 28546 DO 40 J = 1, N 28547 DO 30 I = K, K + N - J 28548 SUM = ABS( AP( I ) ) 28549 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28550 30 CONTINUE 28551 K = K + N - J + 1 28552 40 CONTINUE 28553 END IF 28554 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 28555 $ ( NORM.EQ.'1' ) ) THEN 28556 VALUE = ZERO 28557 K = 1 28558 IF( LSAME( UPLO, 'U' ) ) THEN 28559 DO 60 J = 1, N 28560 SUM = ZERO 28561 DO 50 I = 1, J - 1 28562 ABSA = ABS( AP( K ) ) 28563 SUM = SUM + ABSA 28564 WORK( I ) = WORK( I ) + ABSA 28565 K = K + 1 28566 50 CONTINUE 28567 WORK( J ) = SUM + ABS( AP( K ) ) 28568 K = K + 1 28569 60 CONTINUE 28570 DO 70 I = 1, N 28571 SUM = WORK( I ) 28572 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28573 70 CONTINUE 28574 ELSE 28575 DO 80 I = 1, N 28576 WORK( I ) = ZERO 28577 80 CONTINUE 28578 DO 100 J = 1, N 28579 SUM = WORK( J ) + ABS( AP( K ) ) 28580 K = K + 1 28581 DO 90 I = J + 1, N 28582 ABSA = ABS( AP( K ) ) 28583 SUM = SUM + ABSA 28584 WORK( I ) = WORK( I ) + ABSA 28585 K = K + 1 28586 90 CONTINUE 28587 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28588 100 CONTINUE 28589 END IF 28590 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 28591 SSQ( 1 ) = ZERO 28592 SSQ( 2 ) = ONE 28593 K = 2 28594 IF( LSAME( UPLO, 'U' ) ) THEN 28595 DO 110 J = 2, N 28596 COLSSQ( 1 ) = ZERO 28597 COLSSQ( 2 ) = ONE 28598 CALL SLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 28599 CALL SCOMBSSQ( SSQ, COLSSQ ) 28600 K = K + J 28601 110 CONTINUE 28602 ELSE 28603 DO 120 J = 1, N - 1 28604 COLSSQ( 1 ) = ZERO 28605 COLSSQ( 2 ) = ONE 28606 CALL SLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 28607 CALL SCOMBSSQ( SSQ, COLSSQ ) 28608 K = K + N - J + 1 28609 120 CONTINUE 28610 END IF 28611 SSQ( 2 ) = 2*SSQ( 2 ) 28612 K = 1 28613 COLSSQ( 1 ) = ZERO 28614 COLSSQ( 2 ) = ONE 28615 DO 130 I = 1, N 28616 IF( AP( K ).NE.ZERO ) THEN 28617 ABSA = ABS( AP( K ) ) 28618 IF( COLSSQ( 1 ).LT.ABSA ) THEN 28619 COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 28620 COLSSQ( 1 ) = ABSA 28621 ELSE 28622 COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 28623 END IF 28624 END IF 28625 IF( LSAME( UPLO, 'U' ) ) THEN 28626 K = K + I + 1 28627 ELSE 28628 K = K + N - I + 1 28629 END IF 28630 130 CONTINUE 28631 CALL SCOMBSSQ( SSQ, COLSSQ ) 28632 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 28633 END IF 28634 SLANSP = VALUE 28635 RETURN 28636 END 28637! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slanst.f 28638 REAL FUNCTION SLANST( NORM, N, D, E ) 28639 CHARACTER NORM 28640 INTEGER N 28641 REAL D( * ), E( * ) 28642 REAL ONE, ZERO 28643 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 28644 INTEGER I 28645 REAL ANORM, SCALE, SUM 28646 LOGICAL LSAME, SISNAN 28647 EXTERNAL LSAME, SISNAN 28648 EXTERNAL SLASSQ 28649 INTRINSIC ABS, SQRT 28650 IF( N.LE.0 ) THEN 28651 ANORM = ZERO 28652 ELSE IF( LSAME( NORM, 'M' ) ) THEN 28653 ANORM = ABS( D( N ) ) 28654 DO 10 I = 1, N - 1 28655 SUM = ABS( D( I ) ) 28656 IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM 28657 SUM = ABS( E( I ) ) 28658 IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM 28659 10 CONTINUE 28660 ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. 28661 $ LSAME( NORM, 'I' ) ) THEN 28662 IF( N.EQ.1 ) THEN 28663 ANORM = ABS( D( 1 ) ) 28664 ELSE 28665 ANORM = ABS( D( 1 ) )+ABS( E( 1 ) ) 28666 SUM = ABS( E( N-1 ) )+ABS( D( N ) ) 28667 IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM 28668 DO 20 I = 2, N - 1 28669 SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) ) 28670 IF( ANORM .LT. SUM .OR. SISNAN( SUM ) ) ANORM = SUM 28671 20 CONTINUE 28672 END IF 28673 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 28674 SCALE = ZERO 28675 SUM = ONE 28676 IF( N.GT.1 ) THEN 28677 CALL SLASSQ( N-1, E, 1, SCALE, SUM ) 28678 SUM = 2*SUM 28679 END IF 28680 CALL SLASSQ( N, D, 1, SCALE, SUM ) 28681 ANORM = SCALE*SQRT( SUM ) 28682 END IF 28683 SLANST = ANORM 28684 RETURN 28685 END 28686! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slansy.f 28687 REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK ) 28688 IMPLICIT NONE 28689 CHARACTER NORM, UPLO 28690 INTEGER LDA, N 28691 REAL A( LDA, * ), WORK( * ) 28692 REAL ONE, ZERO 28693 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 28694 INTEGER I, J 28695 REAL ABSA, SUM, VALUE 28696 REAL SSQ( 2 ), COLSSQ( 2 ) 28697 LOGICAL LSAME, SISNAN 28698 EXTERNAL LSAME, SISNAN 28699 EXTERNAL SLASSQ, SCOMBSSQ 28700 INTRINSIC ABS, SQRT 28701 IF( N.EQ.0 ) THEN 28702 VALUE = ZERO 28703 ELSE IF( LSAME( NORM, 'M' ) ) THEN 28704 VALUE = ZERO 28705 IF( LSAME( UPLO, 'U' ) ) THEN 28706 DO 20 J = 1, N 28707 DO 10 I = 1, J 28708 SUM = ABS( A( I, J ) ) 28709 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28710 10 CONTINUE 28711 20 CONTINUE 28712 ELSE 28713 DO 40 J = 1, N 28714 DO 30 I = J, N 28715 SUM = ABS( A( I, J ) ) 28716 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28717 30 CONTINUE 28718 40 CONTINUE 28719 END IF 28720 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 28721 $ ( NORM.EQ.'1' ) ) THEN 28722 VALUE = ZERO 28723 IF( LSAME( UPLO, 'U' ) ) THEN 28724 DO 60 J = 1, N 28725 SUM = ZERO 28726 DO 50 I = 1, J - 1 28727 ABSA = ABS( A( I, J ) ) 28728 SUM = SUM + ABSA 28729 WORK( I ) = WORK( I ) + ABSA 28730 50 CONTINUE 28731 WORK( J ) = SUM + ABS( A( J, J ) ) 28732 60 CONTINUE 28733 DO 70 I = 1, N 28734 SUM = WORK( I ) 28735 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28736 70 CONTINUE 28737 ELSE 28738 DO 80 I = 1, N 28739 WORK( I ) = ZERO 28740 80 CONTINUE 28741 DO 100 J = 1, N 28742 SUM = WORK( J ) + ABS( A( J, J ) ) 28743 DO 90 I = J + 1, N 28744 ABSA = ABS( A( I, J ) ) 28745 SUM = SUM + ABSA 28746 WORK( I ) = WORK( I ) + ABSA 28747 90 CONTINUE 28748 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28749 100 CONTINUE 28750 END IF 28751 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 28752 SSQ( 1 ) = ZERO 28753 SSQ( 2 ) = ONE 28754 IF( LSAME( UPLO, 'U' ) ) THEN 28755 DO 110 J = 2, N 28756 COLSSQ( 1 ) = ZERO 28757 COLSSQ( 2 ) = ONE 28758 CALL SLASSQ( J-1, A( 1, J ), 1, COLSSQ(1), COLSSQ(2) ) 28759 CALL SCOMBSSQ( SSQ, COLSSQ ) 28760 110 CONTINUE 28761 ELSE 28762 DO 120 J = 1, N - 1 28763 COLSSQ( 1 ) = ZERO 28764 COLSSQ( 2 ) = ONE 28765 CALL SLASSQ( N-J, A( J+1, J ), 1, COLSSQ(1), COLSSQ(2) ) 28766 CALL SCOMBSSQ( SSQ, COLSSQ ) 28767 120 CONTINUE 28768 END IF 28769 SSQ( 2 ) = 2*SSQ( 2 ) 28770 COLSSQ( 1 ) = ZERO 28771 COLSSQ( 2 ) = ONE 28772 CALL SLASSQ( N, A, LDA+1, COLSSQ( 1 ), COLSSQ( 2 ) ) 28773 CALL SCOMBSSQ( SSQ, COLSSQ ) 28774 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 28775 END IF 28776 SLANSY = VALUE 28777 RETURN 28778 END 28779! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slantb.f 28780 REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, 28781 $ LDAB, WORK ) 28782 IMPLICIT NONE 28783 CHARACTER DIAG, NORM, UPLO 28784 INTEGER K, LDAB, N 28785 REAL AB( LDAB, * ), WORK( * ) 28786 REAL ONE, ZERO 28787 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 28788 LOGICAL UDIAG 28789 INTEGER I, J, L 28790 REAL SUM, VALUE 28791 REAL SSQ( 2 ), COLSSQ( 2 ) 28792 LOGICAL LSAME, SISNAN 28793 EXTERNAL LSAME, SISNAN 28794 EXTERNAL SLASSQ, SCOMBSSQ 28795 INTRINSIC ABS, MAX, MIN, SQRT 28796 IF( N.EQ.0 ) THEN 28797 VALUE = ZERO 28798 ELSE IF( LSAME( NORM, 'M' ) ) THEN 28799 IF( LSAME( DIAG, 'U' ) ) THEN 28800 VALUE = ONE 28801 IF( LSAME( UPLO, 'U' ) ) THEN 28802 DO 20 J = 1, N 28803 DO 10 I = MAX( K+2-J, 1 ), K 28804 SUM = ABS( AB( I, J ) ) 28805 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28806 10 CONTINUE 28807 20 CONTINUE 28808 ELSE 28809 DO 40 J = 1, N 28810 DO 30 I = 2, MIN( N+1-J, K+1 ) 28811 SUM = ABS( AB( I, J ) ) 28812 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28813 30 CONTINUE 28814 40 CONTINUE 28815 END IF 28816 ELSE 28817 VALUE = ZERO 28818 IF( LSAME( UPLO, 'U' ) ) THEN 28819 DO 60 J = 1, N 28820 DO 50 I = MAX( K+2-J, 1 ), K + 1 28821 SUM = ABS( AB( I, J ) ) 28822 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28823 50 CONTINUE 28824 60 CONTINUE 28825 ELSE 28826 DO 80 J = 1, N 28827 DO 70 I = 1, MIN( N+1-J, K+1 ) 28828 SUM = ABS( AB( I, J ) ) 28829 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28830 70 CONTINUE 28831 80 CONTINUE 28832 END IF 28833 END IF 28834 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 28835 VALUE = ZERO 28836 UDIAG = LSAME( DIAG, 'U' ) 28837 IF( LSAME( UPLO, 'U' ) ) THEN 28838 DO 110 J = 1, N 28839 IF( UDIAG ) THEN 28840 SUM = ONE 28841 DO 90 I = MAX( K+2-J, 1 ), K 28842 SUM = SUM + ABS( AB( I, J ) ) 28843 90 CONTINUE 28844 ELSE 28845 SUM = ZERO 28846 DO 100 I = MAX( K+2-J, 1 ), K + 1 28847 SUM = SUM + ABS( AB( I, J ) ) 28848 100 CONTINUE 28849 END IF 28850 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28851 110 CONTINUE 28852 ELSE 28853 DO 140 J = 1, N 28854 IF( UDIAG ) THEN 28855 SUM = ONE 28856 DO 120 I = 2, MIN( N+1-J, K+1 ) 28857 SUM = SUM + ABS( AB( I, J ) ) 28858 120 CONTINUE 28859 ELSE 28860 SUM = ZERO 28861 DO 130 I = 1, MIN( N+1-J, K+1 ) 28862 SUM = SUM + ABS( AB( I, J ) ) 28863 130 CONTINUE 28864 END IF 28865 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28866 140 CONTINUE 28867 END IF 28868 ELSE IF( LSAME( NORM, 'I' ) ) THEN 28869 VALUE = ZERO 28870 IF( LSAME( UPLO, 'U' ) ) THEN 28871 IF( LSAME( DIAG, 'U' ) ) THEN 28872 DO 150 I = 1, N 28873 WORK( I ) = ONE 28874 150 CONTINUE 28875 DO 170 J = 1, N 28876 L = K + 1 - J 28877 DO 160 I = MAX( 1, J-K ), J - 1 28878 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 28879 160 CONTINUE 28880 170 CONTINUE 28881 ELSE 28882 DO 180 I = 1, N 28883 WORK( I ) = ZERO 28884 180 CONTINUE 28885 DO 200 J = 1, N 28886 L = K + 1 - J 28887 DO 190 I = MAX( 1, J-K ), J 28888 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 28889 190 CONTINUE 28890 200 CONTINUE 28891 END IF 28892 ELSE 28893 IF( LSAME( DIAG, 'U' ) ) THEN 28894 DO 210 I = 1, N 28895 WORK( I ) = ONE 28896 210 CONTINUE 28897 DO 230 J = 1, N 28898 L = 1 - J 28899 DO 220 I = J + 1, MIN( N, J+K ) 28900 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 28901 220 CONTINUE 28902 230 CONTINUE 28903 ELSE 28904 DO 240 I = 1, N 28905 WORK( I ) = ZERO 28906 240 CONTINUE 28907 DO 260 J = 1, N 28908 L = 1 - J 28909 DO 250 I = J, MIN( N, J+K ) 28910 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 28911 250 CONTINUE 28912 260 CONTINUE 28913 END IF 28914 END IF 28915 DO 270 I = 1, N 28916 SUM = WORK( I ) 28917 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 28918 270 CONTINUE 28919 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 28920 IF( LSAME( UPLO, 'U' ) ) THEN 28921 IF( LSAME( DIAG, 'U' ) ) THEN 28922 SSQ( 1 ) = ONE 28923 SSQ( 2 ) = N 28924 IF( K.GT.0 ) THEN 28925 DO 280 J = 2, N 28926 COLSSQ( 1 ) = ZERO 28927 COLSSQ( 2 ) = ONE 28928 CALL SLASSQ( MIN( J-1, K ), 28929 $ AB( MAX( K+2-J, 1 ), J ), 1, 28930 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 28931 CALL SCOMBSSQ( SSQ, COLSSQ ) 28932 280 CONTINUE 28933 END IF 28934 ELSE 28935 SSQ( 1 ) = ZERO 28936 SSQ( 2 ) = ONE 28937 DO 290 J = 1, N 28938 COLSSQ( 1 ) = ZERO 28939 COLSSQ( 2 ) = ONE 28940 CALL SLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), 28941 $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 28942 CALL SCOMBSSQ( SSQ, COLSSQ ) 28943 290 CONTINUE 28944 END IF 28945 ELSE 28946 IF( LSAME( DIAG, 'U' ) ) THEN 28947 SSQ( 1 ) = ONE 28948 SSQ( 2 ) = N 28949 IF( K.GT.0 ) THEN 28950 DO 300 J = 1, N - 1 28951 COLSSQ( 1 ) = ZERO 28952 COLSSQ( 2 ) = ONE 28953 CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, 28954 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 28955 CALL SCOMBSSQ( SSQ, COLSSQ ) 28956 300 CONTINUE 28957 END IF 28958 ELSE 28959 SSQ( 1 ) = ZERO 28960 SSQ( 2 ) = ONE 28961 DO 310 J = 1, N 28962 COLSSQ( 1 ) = ZERO 28963 COLSSQ( 2 ) = ONE 28964 CALL SLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, 28965 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 28966 CALL SCOMBSSQ( SSQ, COLSSQ ) 28967 310 CONTINUE 28968 END IF 28969 END IF 28970 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 28971 END IF 28972 SLANTB = VALUE 28973 RETURN 28974 END 28975! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slantp.f 28976 REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK ) 28977 IMPLICIT NONE 28978 CHARACTER DIAG, NORM, UPLO 28979 INTEGER N 28980 REAL AP( * ), WORK( * ) 28981 REAL ONE, ZERO 28982 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 28983 LOGICAL UDIAG 28984 INTEGER I, J, K 28985 REAL SUM, VALUE 28986 REAL SSQ( 2 ), COLSSQ( 2 ) 28987 LOGICAL LSAME, SISNAN 28988 EXTERNAL LSAME, SISNAN 28989 EXTERNAL SLASSQ, SCOMBSSQ 28990 INTRINSIC ABS, SQRT 28991 IF( N.EQ.0 ) THEN 28992 VALUE = ZERO 28993 ELSE IF( LSAME( NORM, 'M' ) ) THEN 28994 K = 1 28995 IF( LSAME( DIAG, 'U' ) ) THEN 28996 VALUE = ONE 28997 IF( LSAME( UPLO, 'U' ) ) THEN 28998 DO 20 J = 1, N 28999 DO 10 I = K, K + J - 2 29000 SUM = ABS( AP( I ) ) 29001 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29002 10 CONTINUE 29003 K = K + J 29004 20 CONTINUE 29005 ELSE 29006 DO 40 J = 1, N 29007 DO 30 I = K + 1, K + N - J 29008 SUM = ABS( AP( I ) ) 29009 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29010 30 CONTINUE 29011 K = K + N - J + 1 29012 40 CONTINUE 29013 END IF 29014 ELSE 29015 VALUE = ZERO 29016 IF( LSAME( UPLO, 'U' ) ) THEN 29017 DO 60 J = 1, N 29018 DO 50 I = K, K + J - 1 29019 SUM = ABS( AP( I ) ) 29020 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29021 50 CONTINUE 29022 K = K + J 29023 60 CONTINUE 29024 ELSE 29025 DO 80 J = 1, N 29026 DO 70 I = K, K + N - J 29027 SUM = ABS( AP( I ) ) 29028 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29029 70 CONTINUE 29030 K = K + N - J + 1 29031 80 CONTINUE 29032 END IF 29033 END IF 29034 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 29035 VALUE = ZERO 29036 K = 1 29037 UDIAG = LSAME( DIAG, 'U' ) 29038 IF( LSAME( UPLO, 'U' ) ) THEN 29039 DO 110 J = 1, N 29040 IF( UDIAG ) THEN 29041 SUM = ONE 29042 DO 90 I = K, K + J - 2 29043 SUM = SUM + ABS( AP( I ) ) 29044 90 CONTINUE 29045 ELSE 29046 SUM = ZERO 29047 DO 100 I = K, K + J - 1 29048 SUM = SUM + ABS( AP( I ) ) 29049 100 CONTINUE 29050 END IF 29051 K = K + J 29052 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29053 110 CONTINUE 29054 ELSE 29055 DO 140 J = 1, N 29056 IF( UDIAG ) THEN 29057 SUM = ONE 29058 DO 120 I = K + 1, K + N - J 29059 SUM = SUM + ABS( AP( I ) ) 29060 120 CONTINUE 29061 ELSE 29062 SUM = ZERO 29063 DO 130 I = K, K + N - J 29064 SUM = SUM + ABS( AP( I ) ) 29065 130 CONTINUE 29066 END IF 29067 K = K + N - J + 1 29068 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29069 140 CONTINUE 29070 END IF 29071 ELSE IF( LSAME( NORM, 'I' ) ) THEN 29072 K = 1 29073 IF( LSAME( UPLO, 'U' ) ) THEN 29074 IF( LSAME( DIAG, 'U' ) ) THEN 29075 DO 150 I = 1, N 29076 WORK( I ) = ONE 29077 150 CONTINUE 29078 DO 170 J = 1, N 29079 DO 160 I = 1, J - 1 29080 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 29081 K = K + 1 29082 160 CONTINUE 29083 K = K + 1 29084 170 CONTINUE 29085 ELSE 29086 DO 180 I = 1, N 29087 WORK( I ) = ZERO 29088 180 CONTINUE 29089 DO 200 J = 1, N 29090 DO 190 I = 1, J 29091 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 29092 K = K + 1 29093 190 CONTINUE 29094 200 CONTINUE 29095 END IF 29096 ELSE 29097 IF( LSAME( DIAG, 'U' ) ) THEN 29098 DO 210 I = 1, N 29099 WORK( I ) = ONE 29100 210 CONTINUE 29101 DO 230 J = 1, N 29102 K = K + 1 29103 DO 220 I = J + 1, N 29104 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 29105 K = K + 1 29106 220 CONTINUE 29107 230 CONTINUE 29108 ELSE 29109 DO 240 I = 1, N 29110 WORK( I ) = ZERO 29111 240 CONTINUE 29112 DO 260 J = 1, N 29113 DO 250 I = J, N 29114 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 29115 K = K + 1 29116 250 CONTINUE 29117 260 CONTINUE 29118 END IF 29119 END IF 29120 VALUE = ZERO 29121 DO 270 I = 1, N 29122 SUM = WORK( I ) 29123 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29124 270 CONTINUE 29125 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 29126 IF( LSAME( UPLO, 'U' ) ) THEN 29127 IF( LSAME( DIAG, 'U' ) ) THEN 29128 SSQ( 1 ) = ONE 29129 SSQ( 2 ) = N 29130 K = 2 29131 DO 280 J = 2, N 29132 COLSSQ( 1 ) = ZERO 29133 COLSSQ( 2 ) = ONE 29134 CALL SLASSQ( J-1, AP( K ), 1, 29135 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 29136 CALL SCOMBSSQ( SSQ, COLSSQ ) 29137 K = K + J 29138 280 CONTINUE 29139 ELSE 29140 SSQ( 1 ) = ZERO 29141 SSQ( 2 ) = ONE 29142 K = 1 29143 DO 290 J = 1, N 29144 COLSSQ( 1 ) = ZERO 29145 COLSSQ( 2 ) = ONE 29146 CALL SLASSQ( J, AP( K ), 1, 29147 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 29148 CALL SCOMBSSQ( SSQ, COLSSQ ) 29149 K = K + J 29150 290 CONTINUE 29151 END IF 29152 ELSE 29153 IF( LSAME( DIAG, 'U' ) ) THEN 29154 SSQ( 1 ) = ONE 29155 SSQ( 2 ) = N 29156 K = 2 29157 DO 300 J = 1, N - 1 29158 COLSSQ( 1 ) = ZERO 29159 COLSSQ( 2 ) = ONE 29160 CALL SLASSQ( N-J, AP( K ), 1, 29161 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 29162 CALL SCOMBSSQ( SSQ, COLSSQ ) 29163 K = K + N - J + 1 29164 300 CONTINUE 29165 ELSE 29166 SSQ( 1 ) = ZERO 29167 SSQ( 2 ) = ONE 29168 K = 1 29169 DO 310 J = 1, N 29170 COLSSQ( 1 ) = ZERO 29171 COLSSQ( 2 ) = ONE 29172 CALL SLASSQ( N-J+1, AP( K ), 1, 29173 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 29174 CALL SCOMBSSQ( SSQ, COLSSQ ) 29175 K = K + N - J + 1 29176 310 CONTINUE 29177 END IF 29178 END IF 29179 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 29180 END IF 29181 SLANTP = VALUE 29182 RETURN 29183 END 29184! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slantr.f 29185 REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, 29186 $ WORK ) 29187 IMPLICIT NONE 29188 CHARACTER DIAG, NORM, UPLO 29189 INTEGER LDA, M, N 29190 REAL A( LDA, * ), WORK( * ) 29191 REAL ONE, ZERO 29192 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 29193 LOGICAL UDIAG 29194 INTEGER I, J 29195 REAL SUM, VALUE 29196 REAL SSQ( 2 ), COLSSQ( 2 ) 29197 LOGICAL LSAME, SISNAN 29198 EXTERNAL LSAME, SISNAN 29199 EXTERNAL SLASSQ, SCOMBSSQ 29200 INTRINSIC ABS, MIN, SQRT 29201 IF( MIN( M, N ).EQ.0 ) THEN 29202 VALUE = ZERO 29203 ELSE IF( LSAME( NORM, 'M' ) ) THEN 29204 IF( LSAME( DIAG, 'U' ) ) THEN 29205 VALUE = ONE 29206 IF( LSAME( UPLO, 'U' ) ) THEN 29207 DO 20 J = 1, N 29208 DO 10 I = 1, MIN( M, J-1 ) 29209 SUM = ABS( A( I, J ) ) 29210 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29211 10 CONTINUE 29212 20 CONTINUE 29213 ELSE 29214 DO 40 J = 1, N 29215 DO 30 I = J + 1, M 29216 SUM = ABS( A( I, J ) ) 29217 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29218 30 CONTINUE 29219 40 CONTINUE 29220 END IF 29221 ELSE 29222 VALUE = ZERO 29223 IF( LSAME( UPLO, 'U' ) ) THEN 29224 DO 60 J = 1, N 29225 DO 50 I = 1, MIN( M, J ) 29226 SUM = ABS( A( I, J ) ) 29227 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29228 50 CONTINUE 29229 60 CONTINUE 29230 ELSE 29231 DO 80 J = 1, N 29232 DO 70 I = J, M 29233 SUM = ABS( A( I, J ) ) 29234 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29235 70 CONTINUE 29236 80 CONTINUE 29237 END IF 29238 END IF 29239 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 29240 VALUE = ZERO 29241 UDIAG = LSAME( DIAG, 'U' ) 29242 IF( LSAME( UPLO, 'U' ) ) THEN 29243 DO 110 J = 1, N 29244 IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN 29245 SUM = ONE 29246 DO 90 I = 1, J - 1 29247 SUM = SUM + ABS( A( I, J ) ) 29248 90 CONTINUE 29249 ELSE 29250 SUM = ZERO 29251 DO 100 I = 1, MIN( M, J ) 29252 SUM = SUM + ABS( A( I, J ) ) 29253 100 CONTINUE 29254 END IF 29255 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29256 110 CONTINUE 29257 ELSE 29258 DO 140 J = 1, N 29259 IF( UDIAG ) THEN 29260 SUM = ONE 29261 DO 120 I = J + 1, M 29262 SUM = SUM + ABS( A( I, J ) ) 29263 120 CONTINUE 29264 ELSE 29265 SUM = ZERO 29266 DO 130 I = J, M 29267 SUM = SUM + ABS( A( I, J ) ) 29268 130 CONTINUE 29269 END IF 29270 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29271 140 CONTINUE 29272 END IF 29273 ELSE IF( LSAME( NORM, 'I' ) ) THEN 29274 IF( LSAME( UPLO, 'U' ) ) THEN 29275 IF( LSAME( DIAG, 'U' ) ) THEN 29276 DO 150 I = 1, M 29277 WORK( I ) = ONE 29278 150 CONTINUE 29279 DO 170 J = 1, N 29280 DO 160 I = 1, MIN( M, J-1 ) 29281 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 29282 160 CONTINUE 29283 170 CONTINUE 29284 ELSE 29285 DO 180 I = 1, M 29286 WORK( I ) = ZERO 29287 180 CONTINUE 29288 DO 200 J = 1, N 29289 DO 190 I = 1, MIN( M, J ) 29290 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 29291 190 CONTINUE 29292 200 CONTINUE 29293 END IF 29294 ELSE 29295 IF( LSAME( DIAG, 'U' ) ) THEN 29296 DO 210 I = 1, MIN( M, N ) 29297 WORK( I ) = ONE 29298 210 CONTINUE 29299 DO 220 I = N + 1, M 29300 WORK( I ) = ZERO 29301 220 CONTINUE 29302 DO 240 J = 1, N 29303 DO 230 I = J + 1, M 29304 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 29305 230 CONTINUE 29306 240 CONTINUE 29307 ELSE 29308 DO 250 I = 1, M 29309 WORK( I ) = ZERO 29310 250 CONTINUE 29311 DO 270 J = 1, N 29312 DO 260 I = J, M 29313 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 29314 260 CONTINUE 29315 270 CONTINUE 29316 END IF 29317 END IF 29318 VALUE = ZERO 29319 DO 280 I = 1, M 29320 SUM = WORK( I ) 29321 IF( VALUE .LT. SUM .OR. SISNAN( SUM ) ) VALUE = SUM 29322 280 CONTINUE 29323 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 29324 IF( LSAME( UPLO, 'U' ) ) THEN 29325 IF( LSAME( DIAG, 'U' ) ) THEN 29326 SSQ( 1 ) = ONE 29327 SSQ( 2 ) = MIN( M, N ) 29328 DO 290 J = 2, N 29329 COLSSQ( 1 ) = ZERO 29330 COLSSQ( 2 ) = ONE 29331 CALL SLASSQ( MIN( M, J-1 ), A( 1, J ), 1, 29332 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 29333 CALL SCOMBSSQ( SSQ, COLSSQ ) 29334 290 CONTINUE 29335 ELSE 29336 SSQ( 1 ) = ZERO 29337 SSQ( 2 ) = ONE 29338 DO 300 J = 1, N 29339 COLSSQ( 1 ) = ZERO 29340 COLSSQ( 2 ) = ONE 29341 CALL SLASSQ( MIN( M, J ), A( 1, J ), 1, 29342 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 29343 CALL SCOMBSSQ( SSQ, COLSSQ ) 29344 300 CONTINUE 29345 END IF 29346 ELSE 29347 IF( LSAME( DIAG, 'U' ) ) THEN 29348 SSQ( 1 ) = ONE 29349 SSQ( 2 ) = MIN( M, N ) 29350 DO 310 J = 1, N 29351 COLSSQ( 1 ) = ZERO 29352 COLSSQ( 2 ) = ONE 29353 CALL SLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, 29354 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 29355 CALL SCOMBSSQ( SSQ, COLSSQ ) 29356 310 CONTINUE 29357 ELSE 29358 SSQ( 1 ) = ZERO 29359 SSQ( 2 ) = ONE 29360 DO 320 J = 1, N 29361 COLSSQ( 1 ) = ZERO 29362 COLSSQ( 2 ) = ONE 29363 CALL SLASSQ( M-J+1, A( J, J ), 1, 29364 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 29365 CALL SCOMBSSQ( SSQ, COLSSQ ) 29366 320 CONTINUE 29367 END IF 29368 END IF 29369 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 29370 END IF 29371 SLANTR = VALUE 29372 RETURN 29373 END 29374! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slapy2.f 29375 REAL FUNCTION SLAPY2( X, Y ) 29376 REAL X, Y 29377 REAL ZERO 29378 PARAMETER ( ZERO = 0.0E0 ) 29379 REAL ONE 29380 PARAMETER ( ONE = 1.0E0 ) 29381 REAL W, XABS, YABS, Z 29382 LOGICAL X_IS_NAN, Y_IS_NAN 29383 LOGICAL SISNAN 29384 EXTERNAL SISNAN 29385 INTRINSIC ABS, MAX, MIN, SQRT 29386 X_IS_NAN = SISNAN( X ) 29387 Y_IS_NAN = SISNAN( Y ) 29388 IF ( X_IS_NAN ) SLAPY2 = X 29389 IF ( Y_IS_NAN ) SLAPY2 = Y 29390 IF ( .NOT.( X_IS_NAN.OR.Y_IS_NAN ) ) THEN 29391 XABS = ABS( X ) 29392 YABS = ABS( Y ) 29393 W = MAX( XABS, YABS ) 29394 Z = MIN( XABS, YABS ) 29395 IF( Z.EQ.ZERO ) THEN 29396 SLAPY2 = W 29397 ELSE 29398 SLAPY2 = W*SQRT( ONE+( Z / W )**2 ) 29399 END IF 29400 END IF 29401 RETURN 29402 END 29403! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slapy3.f 29404 REAL FUNCTION SLAPY3( X, Y, Z ) 29405 REAL X, Y, Z 29406 REAL ZERO 29407 PARAMETER ( ZERO = 0.0E0 ) 29408 REAL W, XABS, YABS, ZABS 29409 INTRINSIC ABS, MAX, SQRT 29410 XABS = ABS( X ) 29411 YABS = ABS( Y ) 29412 ZABS = ABS( Z ) 29413 W = MAX( XABS, YABS, ZABS ) 29414 IF( W.EQ.ZERO ) THEN 29415 SLAPY3 = XABS + YABS + ZABS 29416 ELSE 29417 SLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ 29418 $ ( ZABS / W )**2 ) 29419 END IF 29420 RETURN 29421 END 29422! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slassq.f 29423 SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ ) 29424 INTEGER INCX, N 29425 REAL SCALE, SUMSQ 29426 REAL X( * ) 29427 REAL ZERO 29428 PARAMETER ( ZERO = 0.0E+0 ) 29429 INTEGER IX 29430 REAL ABSXI 29431 LOGICAL SISNAN 29432 EXTERNAL SISNAN 29433 INTRINSIC ABS 29434 IF( N.GT.0 ) THEN 29435 DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX 29436 ABSXI = ABS( X( IX ) ) 29437 IF( ABSXI.GT.ZERO.OR.SISNAN( ABSXI ) ) THEN 29438 IF( SCALE.LT.ABSXI ) THEN 29439 SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 29440 SCALE = ABSXI 29441 ELSE 29442 SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 29443 END IF 29444 END IF 29445 10 CONTINUE 29446 END IF 29447 RETURN 29448 END 29449! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/slaswp.f 29450 SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX ) 29451 INTEGER INCX, K1, K2, LDA, N 29452 INTEGER IPIV( * ) 29453 REAL A( LDA, * ) 29454 INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 29455 REAL TEMP 29456 IF( INCX.GT.0 ) THEN 29457 IX0 = K1 29458 I1 = K1 29459 I2 = K2 29460 INC = 1 29461 ELSE IF( INCX.LT.0 ) THEN 29462 IX0 = K1 + ( K1-K2 )*INCX 29463 I1 = K2 29464 I2 = K1 29465 INC = -1 29466 ELSE 29467 RETURN 29468 END IF 29469 N32 = ( N / 32 )*32 29470 IF( N32.NE.0 ) THEN 29471 DO 30 J = 1, N32, 32 29472 IX = IX0 29473 DO 20 I = I1, I2, INC 29474 IP = IPIV( IX ) 29475 IF( IP.NE.I ) THEN 29476 DO 10 K = J, J + 31 29477 TEMP = A( I, K ) 29478 A( I, K ) = A( IP, K ) 29479 A( IP, K ) = TEMP 29480 10 CONTINUE 29481 END IF 29482 IX = IX + INCX 29483 20 CONTINUE 29484 30 CONTINUE 29485 END IF 29486 IF( N32.NE.N ) THEN 29487 N32 = N32 + 1 29488 IX = IX0 29489 DO 50 I = I1, I2, INC 29490 IP = IPIV( IX ) 29491 IF( IP.NE.I ) THEN 29492 DO 40 K = N32, N 29493 TEMP = A( I, K ) 29494 A( I, K ) = A( IP, K ) 29495 A( IP, K ) = TEMP 29496 40 CONTINUE 29497 END IF 29498 IX = IX + INCX 29499 50 CONTINUE 29500 END IF 29501 RETURN 29502 END 29503! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/spotrs.f 29504 SUBROUTINE SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) 29505 CHARACTER UPLO 29506 INTEGER INFO, LDA, LDB, N, NRHS 29507 REAL A( LDA, * ), B( LDB, * ) 29508 REAL ONE 29509 PARAMETER ( ONE = 1.0E+0 ) 29510 LOGICAL UPPER 29511 LOGICAL LSAME 29512 EXTERNAL LSAME 29513 EXTERNAL STRSM, XERBLA 29514 INTRINSIC MAX 29515 INFO = 0 29516 UPPER = LSAME( UPLO, 'U' ) 29517 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 29518 INFO = -1 29519 ELSE IF( N.LT.0 ) THEN 29520 INFO = -2 29521 ELSE IF( NRHS.LT.0 ) THEN 29522 INFO = -3 29523 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 29524 INFO = -5 29525 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 29526 INFO = -7 29527 END IF 29528 IF( INFO.NE.0 ) THEN 29529 CALL XERBLA( 'SPOTRS', -INFO ) 29530 RETURN 29531 END IF 29532 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 29533 $ RETURN 29534 IF( UPPER ) THEN 29535 CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, 29536 $ ONE, A, LDA, B, LDB ) 29537 CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, 29538 $ NRHS, ONE, A, LDA, B, LDB ) 29539 ELSE 29540 CALL STRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, 29541 $ NRHS, ONE, A, LDA, B, LDB ) 29542 CALL STRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, 29543 $ ONE, A, LDA, B, LDB ) 29544 END IF 29545 RETURN 29546 END 29547! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ssytrs.f 29548 SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 29549 CHARACTER UPLO 29550 INTEGER INFO, LDA, LDB, N, NRHS 29551 INTEGER IPIV( * ) 29552 REAL A( LDA, * ), B( LDB, * ) 29553 REAL ONE 29554 PARAMETER ( ONE = 1.0E+0 ) 29555 LOGICAL UPPER 29556 INTEGER J, K, KP 29557 REAL AK, AKM1, AKM1K, BK, BKM1, DENOM 29558 LOGICAL LSAME 29559 EXTERNAL LSAME 29560 EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA 29561 INTRINSIC MAX 29562 INFO = 0 29563 UPPER = LSAME( UPLO, 'U' ) 29564 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 29565 INFO = -1 29566 ELSE IF( N.LT.0 ) THEN 29567 INFO = -2 29568 ELSE IF( NRHS.LT.0 ) THEN 29569 INFO = -3 29570 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 29571 INFO = -5 29572 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 29573 INFO = -8 29574 END IF 29575 IF( INFO.NE.0 ) THEN 29576 CALL XERBLA( 'SSYTRS', -INFO ) 29577 RETURN 29578 END IF 29579 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 29580 $ RETURN 29581 IF( UPPER ) THEN 29582 K = N 29583 10 CONTINUE 29584 IF( K.LT.1 ) 29585 $ GO TO 30 29586 IF( IPIV( K ).GT.0 ) THEN 29587 KP = IPIV( K ) 29588 IF( KP.NE.K ) 29589 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 29590 CALL SGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 29591 $ B( 1, 1 ), LDB ) 29592 CALL SSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) 29593 K = K - 1 29594 ELSE 29595 KP = -IPIV( K ) 29596 IF( KP.NE.K-1 ) 29597 $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) 29598 CALL SGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 29599 $ B( 1, 1 ), LDB ) 29600 CALL SGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), 29601 $ LDB, B( 1, 1 ), LDB ) 29602 AKM1K = A( K-1, K ) 29603 AKM1 = A( K-1, K-1 ) / AKM1K 29604 AK = A( K, K ) / AKM1K 29605 DENOM = AKM1*AK - ONE 29606 DO 20 J = 1, NRHS 29607 BKM1 = B( K-1, J ) / AKM1K 29608 BK = B( K, J ) / AKM1K 29609 B( K-1, J ) = ( AK*BKM1-BK ) / DENOM 29610 B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM 29611 20 CONTINUE 29612 K = K - 2 29613 END IF 29614 GO TO 10 29615 30 CONTINUE 29616 K = 1 29617 40 CONTINUE 29618 IF( K.GT.N ) 29619 $ GO TO 50 29620 IF( IPIV( K ).GT.0 ) THEN 29621 CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), 29622 $ 1, ONE, B( K, 1 ), LDB ) 29623 KP = IPIV( K ) 29624 IF( KP.NE.K ) 29625 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 29626 K = K + 1 29627 ELSE 29628 CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), 29629 $ 1, ONE, B( K, 1 ), LDB ) 29630 CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, 29631 $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) 29632 KP = -IPIV( K ) 29633 IF( KP.NE.K ) 29634 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 29635 K = K + 2 29636 END IF 29637 GO TO 40 29638 50 CONTINUE 29639 ELSE 29640 K = 1 29641 60 CONTINUE 29642 IF( K.GT.N ) 29643 $ GO TO 80 29644 IF( IPIV( K ).GT.0 ) THEN 29645 KP = IPIV( K ) 29646 IF( KP.NE.K ) 29647 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 29648 IF( K.LT.N ) 29649 $ CALL SGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), 29650 $ LDB, B( K+1, 1 ), LDB ) 29651 CALL SSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) 29652 K = K + 1 29653 ELSE 29654 KP = -IPIV( K ) 29655 IF( KP.NE.K+1 ) 29656 $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) 29657 IF( K.LT.N-1 ) THEN 29658 CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), 29659 $ LDB, B( K+2, 1 ), LDB ) 29660 CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, 29661 $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) 29662 END IF 29663 AKM1K = A( K+1, K ) 29664 AKM1 = A( K, K ) / AKM1K 29665 AK = A( K+1, K+1 ) / AKM1K 29666 DENOM = AKM1*AK - ONE 29667 DO 70 J = 1, NRHS 29668 BKM1 = B( K, J ) / AKM1K 29669 BK = B( K+1, J ) / AKM1K 29670 B( K, J ) = ( AK*BKM1-BK ) / DENOM 29671 B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM 29672 70 CONTINUE 29673 K = K + 2 29674 END IF 29675 GO TO 60 29676 80 CONTINUE 29677 K = N 29678 90 CONTINUE 29679 IF( K.LT.1 ) 29680 $ GO TO 100 29681 IF( IPIV( K ).GT.0 ) THEN 29682 IF( K.LT.N ) 29683 $ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 29684 $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) 29685 KP = IPIV( K ) 29686 IF( KP.NE.K ) 29687 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 29688 K = K - 1 29689 ELSE 29690 IF( K.LT.N ) THEN 29691 CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 29692 $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) 29693 CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 29694 $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), 29695 $ LDB ) 29696 END IF 29697 KP = -IPIV( K ) 29698 IF( KP.NE.K ) 29699 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 29700 K = K - 2 29701 END IF 29702 GO TO 90 29703 100 CONTINUE 29704 END IF 29705 RETURN 29706 END 29707! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgbtrs.f 29708 SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, 29709 $ INFO ) 29710 CHARACTER TRANS 29711 INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS 29712 INTEGER IPIV( * ) 29713 COMPLEX*16 AB( LDAB, * ), B( LDB, * ) 29714 COMPLEX*16 ONE 29715 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 29716 LOGICAL LNOTI, NOTRAN 29717 INTEGER I, J, KD, L, LM 29718 LOGICAL LSAME 29719 EXTERNAL LSAME 29720 EXTERNAL XERBLA, ZGEMV, ZGERU, ZLACGV, ZSWAP, ZTBSV 29721 INTRINSIC MAX, MIN 29722 INFO = 0 29723 NOTRAN = LSAME( TRANS, 'N' ) 29724 IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. 29725 $ LSAME( TRANS, 'C' ) ) THEN 29726 INFO = -1 29727 ELSE IF( N.LT.0 ) THEN 29728 INFO = -2 29729 ELSE IF( KL.LT.0 ) THEN 29730 INFO = -3 29731 ELSE IF( KU.LT.0 ) THEN 29732 INFO = -4 29733 ELSE IF( NRHS.LT.0 ) THEN 29734 INFO = -5 29735 ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN 29736 INFO = -7 29737 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 29738 INFO = -10 29739 END IF 29740 IF( INFO.NE.0 ) THEN 29741 CALL XERBLA( 'ZGBTRS', -INFO ) 29742 RETURN 29743 END IF 29744 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 29745 $ RETURN 29746 KD = KU + KL + 1 29747 LNOTI = KL.GT.0 29748 IF( NOTRAN ) THEN 29749 IF( LNOTI ) THEN 29750 DO 10 J = 1, N - 1 29751 LM = MIN( KL, N-J ) 29752 L = IPIV( J ) 29753 IF( L.NE.J ) 29754 $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 29755 CALL ZGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), 29756 $ LDB, B( J+1, 1 ), LDB ) 29757 10 CONTINUE 29758 END IF 29759 DO 20 I = 1, NRHS 29760 CALL ZTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, 29761 $ AB, LDAB, B( 1, I ), 1 ) 29762 20 CONTINUE 29763 ELSE IF( LSAME( TRANS, 'T' ) ) THEN 29764 DO 30 I = 1, NRHS 29765 CALL ZTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, 29766 $ LDAB, B( 1, I ), 1 ) 29767 30 CONTINUE 29768 IF( LNOTI ) THEN 29769 DO 40 J = N - 1, 1, -1 29770 LM = MIN( KL, N-J ) 29771 CALL ZGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), 29772 $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) 29773 L = IPIV( J ) 29774 IF( L.NE.J ) 29775 $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 29776 40 CONTINUE 29777 END IF 29778 ELSE 29779 DO 50 I = 1, NRHS 29780 CALL ZTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N, 29781 $ KL+KU, AB, LDAB, B( 1, I ), 1 ) 29782 50 CONTINUE 29783 IF( LNOTI ) THEN 29784 DO 60 J = N - 1, 1, -1 29785 LM = MIN( KL, N-J ) 29786 CALL ZLACGV( NRHS, B( J, 1 ), LDB ) 29787 CALL ZGEMV( 'Conjugate transpose', LM, NRHS, -ONE, 29788 $ B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE, 29789 $ B( J, 1 ), LDB ) 29790 CALL ZLACGV( NRHS, B( J, 1 ), LDB ) 29791 L = IPIV( J ) 29792 IF( L.NE.J ) 29793 $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 29794 60 CONTINUE 29795 END IF 29796 END IF 29797 RETURN 29798 END 29799! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgebak.f 29800 SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, 29801 $ INFO ) 29802 CHARACTER JOB, SIDE 29803 INTEGER IHI, ILO, INFO, LDV, M, N 29804 DOUBLE PRECISION SCALE( * ) 29805 COMPLEX*16 V( LDV, * ) 29806 DOUBLE PRECISION ONE 29807 PARAMETER ( ONE = 1.0D+0 ) 29808 LOGICAL LEFTV, RIGHTV 29809 INTEGER I, II, K 29810 DOUBLE PRECISION S 29811 LOGICAL LSAME 29812 EXTERNAL LSAME 29813 EXTERNAL XERBLA, ZDSCAL, ZSWAP 29814 INTRINSIC MAX, MIN 29815 RIGHTV = LSAME( SIDE, 'R' ) 29816 LEFTV = LSAME( SIDE, 'L' ) 29817 INFO = 0 29818 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. 29819 $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN 29820 INFO = -1 29821 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN 29822 INFO = -2 29823 ELSE IF( N.LT.0 ) THEN 29824 INFO = -3 29825 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN 29826 INFO = -4 29827 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN 29828 INFO = -5 29829 ELSE IF( M.LT.0 ) THEN 29830 INFO = -7 29831 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN 29832 INFO = -9 29833 END IF 29834 IF( INFO.NE.0 ) THEN 29835 CALL XERBLA( 'ZGEBAK', -INFO ) 29836 RETURN 29837 END IF 29838 IF( N.EQ.0 ) 29839 $ RETURN 29840 IF( M.EQ.0 ) 29841 $ RETURN 29842 IF( LSAME( JOB, 'N' ) ) 29843 $ RETURN 29844 IF( ILO.EQ.IHI ) 29845 $ GO TO 30 29846 IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN 29847 IF( RIGHTV ) THEN 29848 DO 10 I = ILO, IHI 29849 S = SCALE( I ) 29850 CALL ZDSCAL( M, S, V( I, 1 ), LDV ) 29851 10 CONTINUE 29852 END IF 29853 IF( LEFTV ) THEN 29854 DO 20 I = ILO, IHI 29855 S = ONE / SCALE( I ) 29856 CALL ZDSCAL( M, S, V( I, 1 ), LDV ) 29857 20 CONTINUE 29858 END IF 29859 END IF 29860 30 CONTINUE 29861 IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN 29862 IF( RIGHTV ) THEN 29863 DO 40 II = 1, N 29864 I = II 29865 IF( I.GE.ILO .AND. I.LE.IHI ) 29866 $ GO TO 40 29867 IF( I.LT.ILO ) 29868 $ I = ILO - II 29869 K = SCALE( I ) 29870 IF( K.EQ.I ) 29871 $ GO TO 40 29872 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 29873 40 CONTINUE 29874 END IF 29875 IF( LEFTV ) THEN 29876 DO 50 II = 1, N 29877 I = II 29878 IF( I.GE.ILO .AND. I.LE.IHI ) 29879 $ GO TO 50 29880 IF( I.LT.ILO ) 29881 $ I = ILO - II 29882 K = SCALE( I ) 29883 IF( K.EQ.I ) 29884 $ GO TO 50 29885 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 29886 50 CONTINUE 29887 END IF 29888 END IF 29889 RETURN 29890 END 29891! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgebal.f 29892 SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) 29893 CHARACTER JOB 29894 INTEGER IHI, ILO, INFO, LDA, N 29895 DOUBLE PRECISION SCALE( * ) 29896 COMPLEX*16 A( LDA, * ) 29897 DOUBLE PRECISION ZERO, ONE 29898 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 29899 DOUBLE PRECISION SCLFAC 29900 PARAMETER ( SCLFAC = 2.0D+0 ) 29901 DOUBLE PRECISION FACTOR 29902 PARAMETER ( FACTOR = 0.95D+0 ) 29903 LOGICAL NOCONV 29904 INTEGER I, ICA, IEXC, IRA, J, K, L, M 29905 DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1, 29906 $ SFMIN2 29907 LOGICAL DISNAN, LSAME 29908 INTEGER IZAMAX 29909 DOUBLE PRECISION DLAMCH, DZNRM2 29910 EXTERNAL DISNAN, LSAME, IZAMAX, DLAMCH, DZNRM2 29911 EXTERNAL XERBLA, ZDSCAL, ZSWAP 29912 INTRINSIC ABS, DBLE, DIMAG, MAX, MIN 29913 INFO = 0 29914 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. 29915 $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN 29916 INFO = -1 29917 ELSE IF( N.LT.0 ) THEN 29918 INFO = -2 29919 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 29920 INFO = -4 29921 END IF 29922 IF( INFO.NE.0 ) THEN 29923 CALL XERBLA( 'ZGEBAL', -INFO ) 29924 RETURN 29925 END IF 29926 K = 1 29927 L = N 29928 IF( N.EQ.0 ) 29929 $ GO TO 210 29930 IF( LSAME( JOB, 'N' ) ) THEN 29931 DO 10 I = 1, N 29932 SCALE( I ) = ONE 29933 10 CONTINUE 29934 GO TO 210 29935 END IF 29936 IF( LSAME( JOB, 'S' ) ) 29937 $ GO TO 120 29938 GO TO 50 29939 20 CONTINUE 29940 SCALE( M ) = J 29941 IF( J.EQ.M ) 29942 $ GO TO 30 29943 CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) 29944 CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA ) 29945 30 CONTINUE 29946 GO TO ( 40, 80 )IEXC 29947 40 CONTINUE 29948 IF( L.EQ.1 ) 29949 $ GO TO 210 29950 L = L - 1 29951 50 CONTINUE 29952 DO 70 J = L, 1, -1 29953 DO 60 I = 1, L 29954 IF( I.EQ.J ) 29955 $ GO TO 60 29956 IF( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( A( J, I ) ).NE. 29957 $ ZERO )GO TO 70 29958 60 CONTINUE 29959 M = L 29960 IEXC = 1 29961 GO TO 20 29962 70 CONTINUE 29963 GO TO 90 29964 80 CONTINUE 29965 K = K + 1 29966 90 CONTINUE 29967 DO 110 J = K, L 29968 DO 100 I = K, L 29969 IF( I.EQ.J ) 29970 $ GO TO 100 29971 IF( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( A( I, J ) ).NE. 29972 $ ZERO )GO TO 110 29973 100 CONTINUE 29974 M = K 29975 IEXC = 2 29976 GO TO 20 29977 110 CONTINUE 29978 120 CONTINUE 29979 DO 130 I = K, L 29980 SCALE( I ) = ONE 29981 130 CONTINUE 29982 IF( LSAME( JOB, 'P' ) ) 29983 $ GO TO 210 29984 SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) 29985 SFMAX1 = ONE / SFMIN1 29986 SFMIN2 = SFMIN1*SCLFAC 29987 SFMAX2 = ONE / SFMIN2 29988 140 CONTINUE 29989 NOCONV = .FALSE. 29990 DO 200 I = K, L 29991 C = DZNRM2( L-K+1, A( K, I ), 1 ) 29992 R = DZNRM2( L-K+1, A( I, K ), LDA ) 29993 ICA = IZAMAX( L, A( 1, I ), 1 ) 29994 CA = ABS( A( ICA, I ) ) 29995 IRA = IZAMAX( N-K+1, A( I, K ), LDA ) 29996 RA = ABS( A( I, IRA+K-1 ) ) 29997 IF( C.EQ.ZERO .OR. R.EQ.ZERO ) 29998 $ GO TO 200 29999 G = R / SCLFAC 30000 F = ONE 30001 S = C + R 30002 160 CONTINUE 30003 IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. 30004 $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170 30005 IF( DISNAN( C+F+CA+R+G+RA ) ) THEN 30006 INFO = -3 30007 CALL XERBLA( 'ZGEBAL', -INFO ) 30008 RETURN 30009 END IF 30010 F = F*SCLFAC 30011 C = C*SCLFAC 30012 CA = CA*SCLFAC 30013 R = R / SCLFAC 30014 G = G / SCLFAC 30015 RA = RA / SCLFAC 30016 GO TO 160 30017 170 CONTINUE 30018 G = C / SCLFAC 30019 180 CONTINUE 30020 IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. 30021 $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190 30022 F = F / SCLFAC 30023 C = C / SCLFAC 30024 G = G / SCLFAC 30025 CA = CA / SCLFAC 30026 R = R*SCLFAC 30027 RA = RA*SCLFAC 30028 GO TO 180 30029 190 CONTINUE 30030 IF( ( C+R ).GE.FACTOR*S ) 30031 $ GO TO 200 30032 IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN 30033 IF( F*SCALE( I ).LE.SFMIN1 ) 30034 $ GO TO 200 30035 END IF 30036 IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN 30037 IF( SCALE( I ).GE.SFMAX1 / F ) 30038 $ GO TO 200 30039 END IF 30040 G = ONE / F 30041 SCALE( I ) = SCALE( I )*F 30042 NOCONV = .TRUE. 30043 CALL ZDSCAL( N-K+1, G, A( I, K ), LDA ) 30044 CALL ZDSCAL( L, F, A( 1, I ), 1 ) 30045 200 CONTINUE 30046 IF( NOCONV ) 30047 $ GO TO 140 30048 210 CONTINUE 30049 ILO = K 30050 IHI = L 30051 RETURN 30052 END 30053! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgeev.f 30054 SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, 30055 $ WORK, LWORK, RWORK, INFO ) 30056 implicit none 30057 CHARACTER JOBVL, JOBVR 30058 INTEGER INFO, LDA, LDVL, LDVR, LWORK, N 30059 DOUBLE PRECISION RWORK( * ) 30060 COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), 30061 $ W( * ), WORK( * ) 30062 DOUBLE PRECISION ZERO, ONE 30063 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 30064 LOGICAL LQUERY, SCALEA, WANTVL, WANTVR 30065 CHARACTER SIDE 30066 INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU, 30067 $ IWRK, K, LWORK_TREVC, MAXWRK, MINWRK, NOUT 30068 DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM 30069 COMPLEX*16 TMP 30070 LOGICAL SELECT( 1 ) 30071 DOUBLE PRECISION DUM( 1 ) 30072 EXTERNAL DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD, 30073 $ ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC3, ZUNGHR 30074 LOGICAL LSAME 30075 INTEGER IDAMAX, ILAENV 30076 DOUBLE PRECISION DLAMCH, DZNRM2, ZLANGE 30077 EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE 30078 INTRINSIC DBLE, DCMPLX, CONJG, AIMAG, MAX, SQRT 30079 INFO = 0 30080 LQUERY = ( LWORK.EQ.-1 ) 30081 WANTVL = LSAME( JOBVL, 'V' ) 30082 WANTVR = LSAME( JOBVR, 'V' ) 30083 IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN 30084 INFO = -1 30085 ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN 30086 INFO = -2 30087 ELSE IF( N.LT.0 ) THEN 30088 INFO = -3 30089 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 30090 INFO = -5 30091 ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN 30092 INFO = -8 30093 ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN 30094 INFO = -10 30095 END IF 30096 IF( INFO.EQ.0 ) THEN 30097 IF( N.EQ.0 ) THEN 30098 MINWRK = 1 30099 MAXWRK = 1 30100 ELSE 30101 MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 ) 30102 MINWRK = 2*N 30103 IF( WANTVL ) THEN 30104 MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', 30105 $ ' ', N, 1, N, -1 ) ) 30106 CALL ZTREVC3( 'L', 'B', SELECT, N, A, LDA, 30107 $ VL, LDVL, VR, LDVR, 30108 $ N, NOUT, WORK, -1, RWORK, -1, IERR ) 30109 LWORK_TREVC = INT( WORK(1) ) 30110 MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) 30111 CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL, 30112 $ WORK, -1, INFO ) 30113 ELSE IF( WANTVR ) THEN 30114 MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR', 30115 $ ' ', N, 1, N, -1 ) ) 30116 CALL ZTREVC3( 'R', 'B', SELECT, N, A, LDA, 30117 $ VL, LDVL, VR, LDVR, 30118 $ N, NOUT, WORK, -1, RWORK, -1, IERR ) 30119 LWORK_TREVC = INT( WORK(1) ) 30120 MAXWRK = MAX( MAXWRK, N + LWORK_TREVC ) 30121 CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR, 30122 $ WORK, -1, INFO ) 30123 ELSE 30124 CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR, 30125 $ WORK, -1, INFO ) 30126 END IF 30127 HSWORK = INT( WORK(1) ) 30128 MAXWRK = MAX( MAXWRK, HSWORK, MINWRK ) 30129 END IF 30130 WORK( 1 ) = MAXWRK 30131 IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN 30132 INFO = -12 30133 END IF 30134 END IF 30135 IF( INFO.NE.0 ) THEN 30136 CALL XERBLA( 'ZGEEV ', -INFO ) 30137 RETURN 30138 ELSE IF( LQUERY ) THEN 30139 RETURN 30140 END IF 30141 IF( N.EQ.0 ) 30142 $ RETURN 30143 EPS = DLAMCH( 'P' ) 30144 SMLNUM = DLAMCH( 'S' ) 30145 BIGNUM = ONE / SMLNUM 30146 CALL DLABAD( SMLNUM, BIGNUM ) 30147 SMLNUM = SQRT( SMLNUM ) / EPS 30148 BIGNUM = ONE / SMLNUM 30149 ANRM = ZLANGE( 'M', N, N, A, LDA, DUM ) 30150 SCALEA = .FALSE. 30151 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN 30152 SCALEA = .TRUE. 30153 CSCALE = SMLNUM 30154 ELSE IF( ANRM.GT.BIGNUM ) THEN 30155 SCALEA = .TRUE. 30156 CSCALE = BIGNUM 30157 END IF 30158 IF( SCALEA ) 30159 $ CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) 30160 IBAL = 1 30161 CALL ZGEBAL( 'B', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR ) 30162 ITAU = 1 30163 IWRK = ITAU + N 30164 CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ), 30165 $ LWORK-IWRK+1, IERR ) 30166 IF( WANTVL ) THEN 30167 SIDE = 'L' 30168 CALL ZLACPY( 'L', N, N, A, LDA, VL, LDVL ) 30169 CALL ZUNGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ), 30170 $ LWORK-IWRK+1, IERR ) 30171 IWRK = ITAU 30172 CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VL, LDVL, 30173 $ WORK( IWRK ), LWORK-IWRK+1, INFO ) 30174 IF( WANTVR ) THEN 30175 SIDE = 'B' 30176 CALL ZLACPY( 'F', N, N, VL, LDVL, VR, LDVR ) 30177 END IF 30178 ELSE IF( WANTVR ) THEN 30179 SIDE = 'R' 30180 CALL ZLACPY( 'L', N, N, A, LDA, VR, LDVR ) 30181 CALL ZUNGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ), 30182 $ LWORK-IWRK+1, IERR ) 30183 IWRK = ITAU 30184 CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VR, LDVR, 30185 $ WORK( IWRK ), LWORK-IWRK+1, INFO ) 30186 ELSE 30187 IWRK = ITAU 30188 CALL ZHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, W, VR, LDVR, 30189 $ WORK( IWRK ), LWORK-IWRK+1, INFO ) 30190 END IF 30191 IF( INFO.NE.0 ) 30192 $ GO TO 50 30193 IF( WANTVL .OR. WANTVR ) THEN 30194 IRWORK = IBAL + N 30195 CALL ZTREVC3( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR, 30196 $ N, NOUT, WORK( IWRK ), LWORK-IWRK+1, 30197 $ RWORK( IRWORK ), N, IERR ) 30198 END IF 30199 IF( WANTVL ) THEN 30200 CALL ZGEBAK( 'B', 'L', N, ILO, IHI, RWORK( IBAL ), N, VL, LDVL, 30201 $ IERR ) 30202 DO 20 I = 1, N 30203 SCL = ONE / DZNRM2( N, VL( 1, I ), 1 ) 30204 CALL ZDSCAL( N, SCL, VL( 1, I ), 1 ) 30205 DO 10 K = 1, N 30206 RWORK( IRWORK+K-1 ) = DBLE( VL( K, I ) )**2 + 30207 $ AIMAG( VL( K, I ) )**2 30208 10 CONTINUE 30209 K = IDAMAX( N, RWORK( IRWORK ), 1 ) 30210 TMP = CONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) 30211 CALL ZSCAL( N, TMP, VL( 1, I ), 1 ) 30212 VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO ) 30213 20 CONTINUE 30214 END IF 30215 IF( WANTVR ) THEN 30216 CALL ZGEBAK( 'B', 'R', N, ILO, IHI, RWORK( IBAL ), N, VR, LDVR, 30217 $ IERR ) 30218 DO 40 I = 1, N 30219 SCL = ONE / DZNRM2( N, VR( 1, I ), 1 ) 30220 CALL ZDSCAL( N, SCL, VR( 1, I ), 1 ) 30221 DO 30 K = 1, N 30222 RWORK( IRWORK+K-1 ) = DBLE( VR( K, I ) )**2 + 30223 $ AIMAG( VR( K, I ) )**2 30224 30 CONTINUE 30225 K = IDAMAX( N, RWORK( IRWORK ), 1 ) 30226 TMP = CONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) ) 30227 CALL ZSCAL( N, TMP, VR( 1, I ), 1 ) 30228 VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO ) 30229 40 CONTINUE 30230 END IF 30231 50 CONTINUE 30232 IF( SCALEA ) THEN 30233 CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ), 30234 $ MAX( N-INFO, 1 ), IERR ) 30235 IF( INFO.GT.0 ) THEN 30236 CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR ) 30237 END IF 30238 END IF 30239 WORK( 1 ) = MAXWRK 30240 RETURN 30241 END 30242! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgehd2.f 30243 SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) 30244 INTEGER IHI, ILO, INFO, LDA, N 30245 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 30246 COMPLEX*16 ONE 30247 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 30248 INTEGER I 30249 COMPLEX*16 ALPHA 30250 EXTERNAL XERBLA, ZLARF, ZLARFG 30251 INTRINSIC DCONJG, MAX, MIN 30252 INFO = 0 30253 IF( N.LT.0 ) THEN 30254 INFO = -1 30255 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN 30256 INFO = -2 30257 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN 30258 INFO = -3 30259 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 30260 INFO = -5 30261 END IF 30262 IF( INFO.NE.0 ) THEN 30263 CALL XERBLA( 'ZGEHD2', -INFO ) 30264 RETURN 30265 END IF 30266 DO 10 I = ILO, IHI - 1 30267 ALPHA = A( I+1, I ) 30268 CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) ) 30269 A( I+1, I ) = ONE 30270 CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), 30271 $ A( 1, I+1 ), LDA, WORK ) 30272 CALL ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, 30273 $ DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) 30274 A( I+1, I ) = ALPHA 30275 10 CONTINUE 30276 RETURN 30277 END 30278! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgehrd.f 30279 SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) 30280 INTEGER IHI, ILO, INFO, LDA, LWORK, N 30281 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 30282 INTEGER NBMAX, LDT, TSIZE 30283 PARAMETER ( NBMAX = 64, LDT = NBMAX+1, 30284 $ TSIZE = LDT*NBMAX ) 30285 COMPLEX*16 ZERO, ONE 30286 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), 30287 $ ONE = ( 1.0D+0, 0.0D+0 ) ) 30288 LOGICAL LQUERY 30289 INTEGER I, IB, IINFO, IWT, J, LDWORK, LWKOPT, NB, 30290 $ NBMIN, NH, NX 30291 COMPLEX*16 EI 30292 EXTERNAL ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM, 30293 $ XERBLA 30294 INTRINSIC MAX, MIN 30295 INTEGER ILAENV 30296 EXTERNAL ILAENV 30297 INFO = 0 30298 LQUERY = ( LWORK.EQ.-1 ) 30299 IF( N.LT.0 ) THEN 30300 INFO = -1 30301 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN 30302 INFO = -2 30303 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN 30304 INFO = -3 30305 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 30306 INFO = -5 30307 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 30308 INFO = -8 30309 END IF 30310 IF( INFO.EQ.0 ) THEN 30311 NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) 30312 LWKOPT = N*NB + TSIZE 30313 WORK( 1 ) = LWKOPT 30314 ENDIF 30315 IF( INFO.NE.0 ) THEN 30316 CALL XERBLA( 'ZGEHRD', -INFO ) 30317 RETURN 30318 ELSE IF( LQUERY ) THEN 30319 RETURN 30320 END IF 30321 DO 10 I = 1, ILO - 1 30322 TAU( I ) = ZERO 30323 10 CONTINUE 30324 DO 20 I = MAX( 1, IHI ), N - 1 30325 TAU( I ) = ZERO 30326 20 CONTINUE 30327 NH = IHI - ILO + 1 30328 IF( NH.LE.1 ) THEN 30329 WORK( 1 ) = 1 30330 RETURN 30331 END IF 30332 NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) 30333 NBMIN = 2 30334 IF( NB.GT.1 .AND. NB.LT.NH ) THEN 30335 NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) ) 30336 IF( NX.LT.NH ) THEN 30337 IF( LWORK.LT.N*NB+TSIZE ) THEN 30338 NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI, 30339 $ -1 ) ) 30340 IF( LWORK.GE.(N*NBMIN + TSIZE) ) THEN 30341 NB = (LWORK-TSIZE) / N 30342 ELSE 30343 NB = 1 30344 END IF 30345 END IF 30346 END IF 30347 END IF 30348 LDWORK = N 30349 IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN 30350 I = ILO 30351 ELSE 30352 IWT = 1 + N*NB 30353 DO 40 I = ILO, IHI - 1 - NX, NB 30354 IB = MIN( NB, IHI-I ) 30355 CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), 30356 $ WORK( IWT ), LDT, WORK, LDWORK ) 30357 EI = A( I+IB, I+IB-1 ) 30358 A( I+IB, I+IB-1 ) = ONE 30359 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 30360 $ IHI, IHI-I-IB+1, 30361 $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE, 30362 $ A( 1, I+IB ), LDA ) 30363 A( I+IB, I+IB-1 ) = EI 30364 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 30365 $ 'Unit', I, IB-1, 30366 $ ONE, A( I+1, I ), LDA, WORK, LDWORK ) 30367 DO 30 J = 0, IB-2 30368 CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1, 30369 $ A( 1, I+J+1 ), 1 ) 30370 30 CONTINUE 30371 CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', 30372 $ 'Columnwise', 30373 $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, 30374 $ WORK( IWT ), LDT, A( I+1, I+IB ), LDA, 30375 $ WORK, LDWORK ) 30376 40 CONTINUE 30377 END IF 30378 CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO ) 30379 WORK( 1 ) = LWKOPT 30380 RETURN 30381 END 30382! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgelq2.f 30383 SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) 30384 INTEGER INFO, LDA, M, N 30385 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 30386 COMPLEX*16 ONE 30387 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 30388 INTEGER I, K 30389 COMPLEX*16 ALPHA 30390 EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG 30391 INTRINSIC MAX, MIN 30392 INFO = 0 30393 IF( M.LT.0 ) THEN 30394 INFO = -1 30395 ELSE IF( N.LT.0 ) THEN 30396 INFO = -2 30397 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 30398 INFO = -4 30399 END IF 30400 IF( INFO.NE.0 ) THEN 30401 CALL XERBLA( 'ZGELQ2', -INFO ) 30402 RETURN 30403 END IF 30404 K = MIN( M, N ) 30405 DO 10 I = 1, K 30406 CALL ZLACGV( N-I+1, A( I, I ), LDA ) 30407 ALPHA = A( I, I ) 30408 CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, 30409 $ TAU( I ) ) 30410 IF( I.LT.M ) THEN 30411 A( I, I ) = ONE 30412 CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), 30413 $ A( I+1, I ), LDA, WORK ) 30414 END IF 30415 A( I, I ) = ALPHA 30416 CALL ZLACGV( N-I+1, A( I, I ), LDA ) 30417 10 CONTINUE 30418 RETURN 30419 END 30420! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgelqf.f 30421 SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) 30422 INTEGER INFO, LDA, LWORK, M, N 30423 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 30424 LOGICAL LQUERY 30425 INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, 30426 $ NBMIN, NX 30427 EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT 30428 INTRINSIC MAX, MIN 30429 INTEGER ILAENV 30430 EXTERNAL ILAENV 30431 INFO = 0 30432 NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) 30433 LWKOPT = M*NB 30434 WORK( 1 ) = LWKOPT 30435 LQUERY = ( LWORK.EQ.-1 ) 30436 IF( M.LT.0 ) THEN 30437 INFO = -1 30438 ELSE IF( N.LT.0 ) THEN 30439 INFO = -2 30440 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 30441 INFO = -4 30442 ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN 30443 INFO = -7 30444 END IF 30445 IF( INFO.NE.0 ) THEN 30446 CALL XERBLA( 'ZGELQF', -INFO ) 30447 RETURN 30448 ELSE IF( LQUERY ) THEN 30449 RETURN 30450 END IF 30451 K = MIN( M, N ) 30452 IF( K.EQ.0 ) THEN 30453 WORK( 1 ) = 1 30454 RETURN 30455 END IF 30456 NBMIN = 2 30457 NX = 0 30458 IWS = M 30459 IF( NB.GT.1 .AND. NB.LT.K ) THEN 30460 NX = MAX( 0, ILAENV( 3, 'ZGELQF', ' ', M, N, -1, -1 ) ) 30461 IF( NX.LT.K ) THEN 30462 LDWORK = M 30463 IWS = LDWORK*NB 30464 IF( LWORK.LT.IWS ) THEN 30465 NB = LWORK / LDWORK 30466 NBMIN = MAX( 2, ILAENV( 2, 'ZGELQF', ' ', M, N, -1, 30467 $ -1 ) ) 30468 END IF 30469 END IF 30470 END IF 30471 IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN 30472 DO 10 I = 1, K - NX, NB 30473 IB = MIN( K-I+1, NB ) 30474 CALL ZGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, 30475 $ IINFO ) 30476 IF( I+IB.LE.M ) THEN 30477 CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), 30478 $ LDA, TAU( I ), WORK, LDWORK ) 30479 CALL ZLARFB( 'Right', 'No transpose', 'Forward', 30480 $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), 30481 $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, 30482 $ WORK( IB+1 ), LDWORK ) 30483 END IF 30484 10 CONTINUE 30485 ELSE 30486 I = 1 30487 END IF 30488 IF( I.LE.K ) 30489 $ CALL ZGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, 30490 $ IINFO ) 30491 WORK( 1 ) = IWS 30492 RETURN 30493 END 30494! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgeqr2.f 30495 SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) 30496 INTEGER INFO, LDA, M, N 30497 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 30498 COMPLEX*16 ONE 30499 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 30500 INTEGER I, K 30501 COMPLEX*16 ALPHA 30502 EXTERNAL XERBLA, ZLARF, ZLARFG 30503 INTRINSIC DCONJG, MAX, MIN 30504 INFO = 0 30505 IF( M.LT.0 ) THEN 30506 INFO = -1 30507 ELSE IF( N.LT.0 ) THEN 30508 INFO = -2 30509 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 30510 INFO = -4 30511 END IF 30512 IF( INFO.NE.0 ) THEN 30513 CALL XERBLA( 'ZGEQR2', -INFO ) 30514 RETURN 30515 END IF 30516 K = MIN( M, N ) 30517 DO 10 I = 1, K 30518 CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, 30519 $ TAU( I ) ) 30520 IF( I.LT.N ) THEN 30521 ALPHA = A( I, I ) 30522 A( I, I ) = ONE 30523 CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, 30524 $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) 30525 A( I, I ) = ALPHA 30526 END IF 30527 10 CONTINUE 30528 RETURN 30529 END 30530! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgeqrf.f 30531 SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) 30532 INTEGER INFO, LDA, LWORK, M, N 30533 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 30534 LOGICAL LQUERY 30535 INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, 30536 $ NBMIN, NX 30537 EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT 30538 INTRINSIC MAX, MIN 30539 INTEGER ILAENV 30540 EXTERNAL ILAENV 30541 INFO = 0 30542 NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) 30543 LWKOPT = N*NB 30544 WORK( 1 ) = LWKOPT 30545 LQUERY = ( LWORK.EQ.-1 ) 30546 IF( M.LT.0 ) THEN 30547 INFO = -1 30548 ELSE IF( N.LT.0 ) THEN 30549 INFO = -2 30550 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 30551 INFO = -4 30552 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 30553 INFO = -7 30554 END IF 30555 IF( INFO.NE.0 ) THEN 30556 CALL XERBLA( 'ZGEQRF', -INFO ) 30557 RETURN 30558 ELSE IF( LQUERY ) THEN 30559 RETURN 30560 END IF 30561 K = MIN( M, N ) 30562 IF( K.EQ.0 ) THEN 30563 WORK( 1 ) = 1 30564 RETURN 30565 END IF 30566 NBMIN = 2 30567 NX = 0 30568 IWS = N 30569 IF( NB.GT.1 .AND. NB.LT.K ) THEN 30570 NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) ) 30571 IF( NX.LT.K ) THEN 30572 LDWORK = N 30573 IWS = LDWORK*NB 30574 IF( LWORK.LT.IWS ) THEN 30575 NB = LWORK / LDWORK 30576 NBMIN = MAX( 2, ILAENV( 2, 'ZGEQRF', ' ', M, N, -1, 30577 $ -1 ) ) 30578 END IF 30579 END IF 30580 END IF 30581 IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN 30582 DO 10 I = 1, K - NX, NB 30583 IB = MIN( K-I+1, NB ) 30584 CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, 30585 $ IINFO ) 30586 IF( I+IB.LE.N ) THEN 30587 CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, 30588 $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) 30589 CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', 30590 $ 'Columnwise', M-I+1, N-I-IB+1, IB, 30591 $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), 30592 $ LDA, WORK( IB+1 ), LDWORK ) 30593 END IF 30594 10 CONTINUE 30595 ELSE 30596 I = 1 30597 END IF 30598 IF( I.LE.K ) 30599 $ CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, 30600 $ IINFO ) 30601 WORK( 1 ) = IWS 30602 RETURN 30603 END 30604! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgesv.f 30605 SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 30606 INTEGER INFO, LDA, LDB, N, NRHS 30607 INTEGER IPIV( * ) 30608 COMPLEX*16 A( LDA, * ), B( LDB, * ) 30609 EXTERNAL XERBLA, ZGETRF, ZGETRS 30610 INTRINSIC MAX 30611 INFO = 0 30612 IF( N.LT.0 ) THEN 30613 INFO = -1 30614 ELSE IF( NRHS.LT.0 ) THEN 30615 INFO = -2 30616 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 30617 INFO = -4 30618 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 30619 INFO = -7 30620 END IF 30621 IF( INFO.NE.0 ) THEN 30622 CALL XERBLA( 'ZGESV ', -INFO ) 30623 RETURN 30624 END IF 30625 CALL ZGETRF( N, N, A, LDA, IPIV, INFO ) 30626 IF( INFO.EQ.0 ) THEN 30627 CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, 30628 $ INFO ) 30629 END IF 30630 RETURN 30631 END 30632! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgetrf.f 30633 SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) 30634 INTEGER INFO, LDA, M, N 30635 INTEGER IPIV( * ) 30636 COMPLEX*16 A( LDA, * ) 30637 COMPLEX*16 ONE 30638 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 30639 INTEGER I, IINFO, J, JB, NB 30640 EXTERNAL XERBLA, ZGEMM, ZGETRF2, ZLASWP, ZTRSM 30641 INTEGER ILAENV 30642 EXTERNAL ILAENV 30643 INTRINSIC MAX, MIN 30644 INFO = 0 30645 IF( M.LT.0 ) THEN 30646 INFO = -1 30647 ELSE IF( N.LT.0 ) THEN 30648 INFO = -2 30649 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 30650 INFO = -4 30651 END IF 30652 IF( INFO.NE.0 ) THEN 30653 CALL XERBLA( 'ZGETRF', -INFO ) 30654 RETURN 30655 END IF 30656 IF( M.EQ.0 .OR. N.EQ.0 ) 30657 $ RETURN 30658 NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 ) 30659 IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN 30660 CALL ZGETRF2( M, N, A, LDA, IPIV, INFO ) 30661 ELSE 30662 DO 20 J = 1, MIN( M, N ), NB 30663 JB = MIN( MIN( M, N )-J+1, NB ) 30664 CALL ZGETRF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) 30665 IF( INFO.EQ.0 .AND. IINFO.GT.0 ) 30666 $ INFO = IINFO + J - 1 30667 DO 10 I = J, MIN( M, J+JB-1 ) 30668 IPIV( I ) = J - 1 + IPIV( I ) 30669 10 CONTINUE 30670 CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) 30671 IF( J+JB.LE.N ) THEN 30672 CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, 30673 $ IPIV, 1 ) 30674 CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, 30675 $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), 30676 $ LDA ) 30677 IF( J+JB.LE.M ) THEN 30678 CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1, 30679 $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, 30680 $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), 30681 $ LDA ) 30682 END IF 30683 END IF 30684 20 CONTINUE 30685 END IF 30686 RETURN 30687 END 30688! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgetrf2.f 30689 RECURSIVE SUBROUTINE ZGETRF2( M, N, A, LDA, IPIV, INFO ) 30690 INTEGER INFO, LDA, M, N 30691 INTEGER IPIV( * ) 30692 COMPLEX*16 A( LDA, * ) 30693 COMPLEX*16 ONE, ZERO 30694 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), 30695 $ ZERO = ( 0.0D+0, 0.0D+0 ) ) 30696 DOUBLE PRECISION SFMIN 30697 COMPLEX*16 TEMP 30698 INTEGER I, IINFO, N1, N2 30699 DOUBLE PRECISION DLAMCH 30700 INTEGER IZAMAX 30701 EXTERNAL DLAMCH, IZAMAX 30702 EXTERNAL ZGEMM, ZSCAL, ZLASWP, ZTRSM, XERBLA 30703 INTRINSIC MAX, MIN 30704 INFO = 0 30705 IF( M.LT.0 ) THEN 30706 INFO = -1 30707 ELSE IF( N.LT.0 ) THEN 30708 INFO = -2 30709 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 30710 INFO = -4 30711 END IF 30712 IF( INFO.NE.0 ) THEN 30713 CALL XERBLA( 'ZGETRF2', -INFO ) 30714 RETURN 30715 END IF 30716 IF( M.EQ.0 .OR. N.EQ.0 ) 30717 $ RETURN 30718 IF ( M.EQ.1 ) THEN 30719 IPIV( 1 ) = 1 30720 IF ( A(1,1).EQ.ZERO ) 30721 $ INFO = 1 30722 ELSE IF( N.EQ.1 ) THEN 30723 SFMIN = DLAMCH('S') 30724 I = IZAMAX( M, A( 1, 1 ), 1 ) 30725 IPIV( 1 ) = I 30726 IF( A( I, 1 ).NE.ZERO ) THEN 30727 IF( I.NE.1 ) THEN 30728 TEMP = A( 1, 1 ) 30729 A( 1, 1 ) = A( I, 1 ) 30730 A( I, 1 ) = TEMP 30731 END IF 30732 IF( ABS(A( 1, 1 )) .GE. SFMIN ) THEN 30733 CALL ZSCAL( M-1, ONE / A( 1, 1 ), A( 2, 1 ), 1 ) 30734 ELSE 30735 DO 10 I = 1, M-1 30736 A( 1+I, 1 ) = A( 1+I, 1 ) / A( 1, 1 ) 30737 10 CONTINUE 30738 END IF 30739 ELSE 30740 INFO = 1 30741 END IF 30742 ELSE 30743 N1 = MIN( M, N ) / 2 30744 N2 = N-N1 30745 CALL ZGETRF2( M, N1, A, LDA, IPIV, IINFO ) 30746 IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) 30747 $ INFO = IINFO 30748 CALL ZLASWP( N2, A( 1, N1+1 ), LDA, 1, N1, IPIV, 1 ) 30749 CALL ZTRSM( 'L', 'L', 'N', 'U', N1, N2, ONE, A, LDA, 30750 $ A( 1, N1+1 ), LDA ) 30751 CALL ZGEMM( 'N', 'N', M-N1, N2, N1, -ONE, A( N1+1, 1 ), LDA, 30752 $ A( 1, N1+1 ), LDA, ONE, A( N1+1, N1+1 ), LDA ) 30753 CALL ZGETRF2( M-N1, N2, A( N1+1, N1+1 ), LDA, IPIV( N1+1 ), 30754 $ IINFO ) 30755 IF ( INFO.EQ.0 .AND. IINFO.GT.0 ) 30756 $ INFO = IINFO + N1 30757 DO 20 I = N1+1, MIN( M, N ) 30758 IPIV( I ) = IPIV( I ) + N1 30759 20 CONTINUE 30760 CALL ZLASWP( N1, A( 1, 1 ), LDA, N1+1, MIN( M, N), IPIV, 1 ) 30761 END IF 30762 RETURN 30763 END 30764! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgetri.f 30765 SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) 30766 INTEGER INFO, LDA, LWORK, N 30767 INTEGER IPIV( * ) 30768 COMPLEX*16 A( LDA, * ), WORK( * ) 30769 COMPLEX*16 ZERO, ONE 30770 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), 30771 $ ONE = ( 1.0D+0, 0.0D+0 ) ) 30772 LOGICAL LQUERY 30773 INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, 30774 $ NBMIN, NN 30775 INTEGER ILAENV 30776 EXTERNAL ILAENV 30777 EXTERNAL XERBLA, ZGEMM, ZGEMV, ZSWAP, ZTRSM, ZTRTRI 30778 INTRINSIC MAX, MIN 30779 INFO = 0 30780 NB = ILAENV( 1, 'ZGETRI', ' ', N, -1, -1, -1 ) 30781 LWKOPT = N*NB 30782 WORK( 1 ) = LWKOPT 30783 LQUERY = ( LWORK.EQ.-1 ) 30784 IF( N.LT.0 ) THEN 30785 INFO = -1 30786 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 30787 INFO = -3 30788 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 30789 INFO = -6 30790 END IF 30791 IF( INFO.NE.0 ) THEN 30792 CALL XERBLA( 'ZGETRI', -INFO ) 30793 RETURN 30794 ELSE IF( LQUERY ) THEN 30795 RETURN 30796 END IF 30797 IF( N.EQ.0 ) 30798 $ RETURN 30799 CALL ZTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) 30800 IF( INFO.GT.0 ) 30801 $ RETURN 30802 NBMIN = 2 30803 LDWORK = N 30804 IF( NB.GT.1 .AND. NB.LT.N ) THEN 30805 IWS = MAX( LDWORK*NB, 1 ) 30806 IF( LWORK.LT.IWS ) THEN 30807 NB = LWORK / LDWORK 30808 NBMIN = MAX( 2, ILAENV( 2, 'ZGETRI', ' ', N, -1, -1, -1 ) ) 30809 END IF 30810 ELSE 30811 IWS = N 30812 END IF 30813 IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN 30814 DO 20 J = N, 1, -1 30815 DO 10 I = J + 1, N 30816 WORK( I ) = A( I, J ) 30817 A( I, J ) = ZERO 30818 10 CONTINUE 30819 IF( J.LT.N ) 30820 $ CALL ZGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), 30821 $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) 30822 20 CONTINUE 30823 ELSE 30824 NN = ( ( N-1 ) / NB )*NB + 1 30825 DO 50 J = NN, 1, -NB 30826 JB = MIN( NB, N-J+1 ) 30827 DO 40 JJ = J, J + JB - 1 30828 DO 30 I = JJ + 1, N 30829 WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) 30830 A( I, JJ ) = ZERO 30831 30 CONTINUE 30832 40 CONTINUE 30833 IF( J+JB.LE.N ) 30834 $ CALL ZGEMM( 'No transpose', 'No transpose', N, JB, 30835 $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, 30836 $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) 30837 CALL ZTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, 30838 $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) 30839 50 CONTINUE 30840 END IF 30841 DO 60 J = N - 1, 1, -1 30842 JP = IPIV( J ) 30843 IF( JP.NE.J ) 30844 $ CALL ZSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) 30845 60 CONTINUE 30846 WORK( 1 ) = IWS 30847 RETURN 30848 END 30849! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zgetrs.f 30850 SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 30851 CHARACTER TRANS 30852 INTEGER INFO, LDA, LDB, N, NRHS 30853 INTEGER IPIV( * ) 30854 COMPLEX*16 A( LDA, * ), B( LDB, * ) 30855 COMPLEX*16 ONE 30856 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 30857 LOGICAL NOTRAN 30858 LOGICAL LSAME 30859 EXTERNAL LSAME 30860 EXTERNAL XERBLA, ZLASWP, ZTRSM 30861 INTRINSIC MAX 30862 INFO = 0 30863 NOTRAN = LSAME( TRANS, 'N' ) 30864 IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. 30865 $ LSAME( TRANS, 'C' ) ) THEN 30866 INFO = -1 30867 ELSE IF( N.LT.0 ) THEN 30868 INFO = -2 30869 ELSE IF( NRHS.LT.0 ) THEN 30870 INFO = -3 30871 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 30872 INFO = -5 30873 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 30874 INFO = -8 30875 END IF 30876 IF( INFO.NE.0 ) THEN 30877 CALL XERBLA( 'ZGETRS', -INFO ) 30878 RETURN 30879 END IF 30880 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 30881 $ RETURN 30882 IF( NOTRAN ) THEN 30883 CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) 30884 CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, 30885 $ ONE, A, LDA, B, LDB ) 30886 CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, 30887 $ NRHS, ONE, A, LDA, B, LDB ) 30888 ELSE 30889 CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, 30890 $ A, LDA, B, LDB ) 30891 CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, 30892 $ LDA, B, LDB ) 30893 CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) 30894 END IF 30895 RETURN 30896 END 30897! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhb2st_kernels.f 30898 SUBROUTINE ZHB2ST_KERNELS( UPLO, WANTZ, TTYPE, 30899 $ ST, ED, SWEEP, N, NB, IB, 30900 $ A, LDA, V, TAU, LDVT, WORK) 30901 IMPLICIT NONE 30902 CHARACTER UPLO 30903 LOGICAL WANTZ 30904 INTEGER TTYPE, ST, ED, SWEEP, N, NB, IB, LDA, LDVT 30905 COMPLEX*16 A( LDA, * ), V( * ), 30906 $ TAU( * ), WORK( * ) 30907 COMPLEX*16 ZERO, ONE 30908 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), 30909 $ ONE = ( 1.0D+0, 0.0D+0 ) ) 30910 LOGICAL UPPER 30911 INTEGER I, J1, J2, LM, LN, VPOS, TAUPOS, 30912 $ DPOS, OFDPOS, AJETER 30913 COMPLEX*16 CTMP 30914 EXTERNAL ZLARFG, ZLARFX, ZLARFY 30915 INTRINSIC DCONJG, MOD 30916 LOGICAL LSAME 30917 EXTERNAL LSAME 30918 AJETER = IB + LDVT 30919 UPPER = LSAME( UPLO, 'U' ) 30920 IF( UPPER ) THEN 30921 DPOS = 2 * NB + 1 30922 OFDPOS = 2 * NB 30923 ELSE 30924 DPOS = 1 30925 OFDPOS = 2 30926 ENDIF 30927 IF( UPPER ) THEN 30928 IF( WANTZ ) THEN 30929 VPOS = MOD( SWEEP-1, 2 ) * N + ST 30930 TAUPOS = MOD( SWEEP-1, 2 ) * N + ST 30931 ELSE 30932 VPOS = MOD( SWEEP-1, 2 ) * N + ST 30933 TAUPOS = MOD( SWEEP-1, 2 ) * N + ST 30934 ENDIF 30935 IF( TTYPE.EQ.1 ) THEN 30936 LM = ED - ST + 1 30937 V( VPOS ) = ONE 30938 DO 10 I = 1, LM-1 30939 V( VPOS+I ) = DCONJG( A( OFDPOS-I, ST+I ) ) 30940 A( OFDPOS-I, ST+I ) = ZERO 30941 10 CONTINUE 30942 CTMP = DCONJG( A( OFDPOS, ST ) ) 30943 CALL ZLARFG( LM, CTMP, V( VPOS+1 ), 1, 30944 $ TAU( TAUPOS ) ) 30945 A( OFDPOS, ST ) = CTMP 30946 LM = ED - ST + 1 30947 CALL ZLARFY( UPLO, LM, V( VPOS ), 1, 30948 $ DCONJG( TAU( TAUPOS ) ), 30949 $ A( DPOS, ST ), LDA-1, WORK) 30950 ENDIF 30951 IF( TTYPE.EQ.3 ) THEN 30952 LM = ED - ST + 1 30953 CALL ZLARFY( UPLO, LM, V( VPOS ), 1, 30954 $ DCONJG( TAU( TAUPOS ) ), 30955 $ A( DPOS, ST ), LDA-1, WORK) 30956 ENDIF 30957 IF( TTYPE.EQ.2 ) THEN 30958 J1 = ED+1 30959 J2 = MIN( ED+NB, N ) 30960 LN = ED-ST+1 30961 LM = J2-J1+1 30962 IF( LM.GT.0) THEN 30963 CALL ZLARFX( 'Left', LN, LM, V( VPOS ), 30964 $ DCONJG( TAU( TAUPOS ) ), 30965 $ A( DPOS-NB, J1 ), LDA-1, WORK) 30966 IF( WANTZ ) THEN 30967 VPOS = MOD( SWEEP-1, 2 ) * N + J1 30968 TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 30969 ELSE 30970 VPOS = MOD( SWEEP-1, 2 ) * N + J1 30971 TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 30972 ENDIF 30973 V( VPOS ) = ONE 30974 DO 30 I = 1, LM-1 30975 V( VPOS+I ) = 30976 $ DCONJG( A( DPOS-NB-I, J1+I ) ) 30977 A( DPOS-NB-I, J1+I ) = ZERO 30978 30 CONTINUE 30979 CTMP = DCONJG( A( DPOS-NB, J1 ) ) 30980 CALL ZLARFG( LM, CTMP, V( VPOS+1 ), 1, TAU( TAUPOS ) ) 30981 A( DPOS-NB, J1 ) = CTMP 30982 CALL ZLARFX( 'Right', LN-1, LM, V( VPOS ), 30983 $ TAU( TAUPOS ), 30984 $ A( DPOS-NB+1, J1 ), LDA-1, WORK) 30985 ENDIF 30986 ENDIF 30987 ELSE 30988 IF( WANTZ ) THEN 30989 VPOS = MOD( SWEEP-1, 2 ) * N + ST 30990 TAUPOS = MOD( SWEEP-1, 2 ) * N + ST 30991 ELSE 30992 VPOS = MOD( SWEEP-1, 2 ) * N + ST 30993 TAUPOS = MOD( SWEEP-1, 2 ) * N + ST 30994 ENDIF 30995 IF( TTYPE.EQ.1 ) THEN 30996 LM = ED - ST + 1 30997 V( VPOS ) = ONE 30998 DO 20 I = 1, LM-1 30999 V( VPOS+I ) = A( OFDPOS+I, ST-1 ) 31000 A( OFDPOS+I, ST-1 ) = ZERO 31001 20 CONTINUE 31002 CALL ZLARFG( LM, A( OFDPOS, ST-1 ), V( VPOS+1 ), 1, 31003 $ TAU( TAUPOS ) ) 31004 LM = ED - ST + 1 31005 CALL ZLARFY( UPLO, LM, V( VPOS ), 1, 31006 $ DCONJG( TAU( TAUPOS ) ), 31007 $ A( DPOS, ST ), LDA-1, WORK) 31008 ENDIF 31009 IF( TTYPE.EQ.3 ) THEN 31010 LM = ED - ST + 1 31011 CALL ZLARFY( UPLO, LM, V( VPOS ), 1, 31012 $ DCONJG( TAU( TAUPOS ) ), 31013 $ A( DPOS, ST ), LDA-1, WORK) 31014 ENDIF 31015 IF( TTYPE.EQ.2 ) THEN 31016 J1 = ED+1 31017 J2 = MIN( ED+NB, N ) 31018 LN = ED-ST+1 31019 LM = J2-J1+1 31020 IF( LM.GT.0) THEN 31021 CALL ZLARFX( 'Right', LM, LN, V( VPOS ), 31022 $ TAU( TAUPOS ), A( DPOS+NB, ST ), 31023 $ LDA-1, WORK) 31024 IF( WANTZ ) THEN 31025 VPOS = MOD( SWEEP-1, 2 ) * N + J1 31026 TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 31027 ELSE 31028 VPOS = MOD( SWEEP-1, 2 ) * N + J1 31029 TAUPOS = MOD( SWEEP-1, 2 ) * N + J1 31030 ENDIF 31031 V( VPOS ) = ONE 31032 DO 40 I = 1, LM-1 31033 V( VPOS+I ) = A( DPOS+NB+I, ST ) 31034 A( DPOS+NB+I, ST ) = ZERO 31035 40 CONTINUE 31036 CALL ZLARFG( LM, A( DPOS+NB, ST ), V( VPOS+1 ), 1, 31037 $ TAU( TAUPOS ) ) 31038 CALL ZLARFX( 'Left', LM, LN-1, V( VPOS ), 31039 $ DCONJG( TAU( TAUPOS ) ), 31040 $ A( DPOS+NB-1, ST+1 ), LDA-1, WORK) 31041 ENDIF 31042 ENDIF 31043 ENDIF 31044 RETURN 31045 END 31046! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zheev.f 31047 SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, 31048 $ INFO ) 31049 CHARACTER JOBZ, UPLO 31050 INTEGER INFO, LDA, LWORK, N 31051 DOUBLE PRECISION RWORK( * ), W( * ) 31052 COMPLEX*16 A( LDA, * ), WORK( * ) 31053 DOUBLE PRECISION ZERO, ONE 31054 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 31055 COMPLEX*16 CONE 31056 PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) 31057 LOGICAL LOWER, LQUERY, WANTZ 31058 INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, 31059 $ LLWORK, LWKOPT, NB 31060 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 31061 $ SMLNUM 31062 LOGICAL LSAME 31063 INTEGER ILAENV 31064 DOUBLE PRECISION DLAMCH, ZLANHE 31065 EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE 31066 EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR, 31067 $ ZUNGTR 31068 INTRINSIC MAX, SQRT 31069 WANTZ = LSAME( JOBZ, 'V' ) 31070 LOWER = LSAME( UPLO, 'L' ) 31071 LQUERY = ( LWORK.EQ.-1 ) 31072 INFO = 0 31073 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 31074 INFO = -1 31075 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 31076 INFO = -2 31077 ELSE IF( N.LT.0 ) THEN 31078 INFO = -3 31079 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 31080 INFO = -5 31081 END IF 31082 IF( INFO.EQ.0 ) THEN 31083 NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) 31084 LWKOPT = MAX( 1, ( NB+1 )*N ) 31085 WORK( 1 ) = LWKOPT 31086 IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) 31087 $ INFO = -8 31088 END IF 31089 IF( INFO.NE.0 ) THEN 31090 CALL XERBLA( 'ZHEEV ', -INFO ) 31091 RETURN 31092 ELSE IF( LQUERY ) THEN 31093 RETURN 31094 END IF 31095 IF( N.EQ.0 ) THEN 31096 RETURN 31097 END IF 31098 IF( N.EQ.1 ) THEN 31099 W( 1 ) = A( 1, 1 ) 31100 WORK( 1 ) = 1 31101 IF( WANTZ ) 31102 $ A( 1, 1 ) = CONE 31103 RETURN 31104 END IF 31105 SAFMIN = DLAMCH( 'Safe minimum' ) 31106 EPS = DLAMCH( 'Precision' ) 31107 SMLNUM = SAFMIN / EPS 31108 BIGNUM = ONE / SMLNUM 31109 RMIN = SQRT( SMLNUM ) 31110 RMAX = SQRT( BIGNUM ) 31111 ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) 31112 ISCALE = 0 31113 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 31114 ISCALE = 1 31115 SIGMA = RMIN / ANRM 31116 ELSE IF( ANRM.GT.RMAX ) THEN 31117 ISCALE = 1 31118 SIGMA = RMAX / ANRM 31119 END IF 31120 IF( ISCALE.EQ.1 ) 31121 $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) 31122 INDE = 1 31123 INDTAU = 1 31124 INDWRK = INDTAU + N 31125 LLWORK = LWORK - INDWRK + 1 31126 CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ), 31127 $ WORK( INDWRK ), LLWORK, IINFO ) 31128 IF( .NOT.WANTZ ) THEN 31129 CALL DSTERF( N, W, RWORK( INDE ), INFO ) 31130 ELSE 31131 CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), 31132 $ LLWORK, IINFO ) 31133 INDWRK = INDE + N 31134 CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA, 31135 $ RWORK( INDWRK ), INFO ) 31136 END IF 31137 IF( ISCALE.EQ.1 ) THEN 31138 IF( INFO.EQ.0 ) THEN 31139 IMAX = N 31140 ELSE 31141 IMAX = INFO - 1 31142 END IF 31143 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 31144 END IF 31145 WORK( 1 ) = LWKOPT 31146 RETURN 31147 END 31148! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zheev_2stage.f 31149 SUBROUTINE ZHEEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, 31150 $ RWORK, INFO ) 31151 IMPLICIT NONE 31152 CHARACTER JOBZ, UPLO 31153 INTEGER INFO, LDA, LWORK, N 31154 DOUBLE PRECISION RWORK( * ), W( * ) 31155 COMPLEX*16 A( LDA, * ), WORK( * ) 31156 DOUBLE PRECISION ZERO, ONE 31157 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 31158 COMPLEX*16 CONE 31159 PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) 31160 LOGICAL LOWER, LQUERY, WANTZ 31161 INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, 31162 $ LLWORK, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS 31163 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 31164 $ SMLNUM 31165 LOGICAL LSAME 31166 INTEGER ILAENV2STAGE 31167 DOUBLE PRECISION DLAMCH, ZLANHE 31168 EXTERNAL LSAME, DLAMCH, ZLANHE, ILAENV2STAGE 31169 EXTERNAL DSCAL, DSTERF, XERBLA, ZLASCL, ZSTEQR, 31170 $ ZUNGTR, ZHETRD_2STAGE 31171 INTRINSIC DBLE, MAX, SQRT 31172 WANTZ = LSAME( JOBZ, 'V' ) 31173 LOWER = LSAME( UPLO, 'L' ) 31174 LQUERY = ( LWORK.EQ.-1 ) 31175 INFO = 0 31176 IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN 31177 INFO = -1 31178 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 31179 INFO = -2 31180 ELSE IF( N.LT.0 ) THEN 31181 INFO = -3 31182 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 31183 INFO = -5 31184 END IF 31185 IF( INFO.EQ.0 ) THEN 31186 KD = ILAENV2STAGE( 1, 'ZHETRD_2STAGE', JOBZ, N, -1, -1, -1 ) 31187 IB = ILAENV2STAGE( 2, 'ZHETRD_2STAGE', JOBZ, N, KD, -1, -1 ) 31188 LHTRD = ILAENV2STAGE( 3, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) 31189 LWTRD = ILAENV2STAGE( 4, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) 31190 LWMIN = N + LHTRD + LWTRD 31191 WORK( 1 ) = LWMIN 31192 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) 31193 $ INFO = -8 31194 END IF 31195 IF( INFO.NE.0 ) THEN 31196 CALL XERBLA( 'ZHEEV_2STAGE ', -INFO ) 31197 RETURN 31198 ELSE IF( LQUERY ) THEN 31199 RETURN 31200 END IF 31201 IF( N.EQ.0 ) THEN 31202 RETURN 31203 END IF 31204 IF( N.EQ.1 ) THEN 31205 W( 1 ) = DBLE( A( 1, 1 ) ) 31206 WORK( 1 ) = 1 31207 IF( WANTZ ) 31208 $ A( 1, 1 ) = CONE 31209 RETURN 31210 END IF 31211 SAFMIN = DLAMCH( 'Safe minimum' ) 31212 EPS = DLAMCH( 'Precision' ) 31213 SMLNUM = SAFMIN / EPS 31214 BIGNUM = ONE / SMLNUM 31215 RMIN = SQRT( SMLNUM ) 31216 RMAX = SQRT( BIGNUM ) 31217 ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) 31218 ISCALE = 0 31219 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 31220 ISCALE = 1 31221 SIGMA = RMIN / ANRM 31222 ELSE IF( ANRM.GT.RMAX ) THEN 31223 ISCALE = 1 31224 SIGMA = RMAX / ANRM 31225 END IF 31226 IF( ISCALE.EQ.1 ) 31227 $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) 31228 INDE = 1 31229 INDTAU = 1 31230 INDHOUS = INDTAU + N 31231 INDWRK = INDHOUS + LHTRD 31232 LLWORK = LWORK - INDWRK + 1 31233 CALL ZHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, RWORK( INDE ), 31234 $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, 31235 $ WORK( INDWRK ), LLWORK, IINFO ) 31236 IF( .NOT.WANTZ ) THEN 31237 CALL DSTERF( N, W, RWORK( INDE ), INFO ) 31238 ELSE 31239 CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), 31240 $ LLWORK, IINFO ) 31241 INDWRK = INDE + N 31242 CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA, 31243 $ RWORK( INDWRK ), INFO ) 31244 END IF 31245 IF( ISCALE.EQ.1 ) THEN 31246 IF( INFO.EQ.0 ) THEN 31247 IMAX = N 31248 ELSE 31249 IMAX = INFO - 1 31250 END IF 31251 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 31252 END IF 31253 WORK( 1 ) = LWMIN 31254 RETURN 31255 END 31256! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zheevd.f 31257 SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, 31258 $ LRWORK, IWORK, LIWORK, INFO ) 31259 CHARACTER JOBZ, UPLO 31260 INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N 31261 INTEGER IWORK( * ) 31262 DOUBLE PRECISION RWORK( * ), W( * ) 31263 COMPLEX*16 A( LDA, * ), WORK( * ) 31264 DOUBLE PRECISION ZERO, ONE 31265 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 31266 COMPLEX*16 CONE 31267 PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) 31268 LOGICAL LOWER, LQUERY, WANTZ 31269 INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWK2, 31270 $ INDWRK, ISCALE, LIOPT, LIWMIN, LLRWK, LLWORK, 31271 $ LLWRK2, LOPT, LROPT, LRWMIN, LWMIN 31272 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 31273 $ SMLNUM 31274 LOGICAL LSAME 31275 INTEGER ILAENV 31276 DOUBLE PRECISION DLAMCH, ZLANHE 31277 EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE 31278 EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLACPY, ZLASCL, 31279 $ ZSTEDC, ZUNMTR 31280 INTRINSIC MAX, SQRT 31281 WANTZ = LSAME( JOBZ, 'V' ) 31282 LOWER = LSAME( UPLO, 'L' ) 31283 LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 31284 INFO = 0 31285 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 31286 INFO = -1 31287 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 31288 INFO = -2 31289 ELSE IF( N.LT.0 ) THEN 31290 INFO = -3 31291 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 31292 INFO = -5 31293 END IF 31294 IF( INFO.EQ.0 ) THEN 31295 IF( N.LE.1 ) THEN 31296 LWMIN = 1 31297 LRWMIN = 1 31298 LIWMIN = 1 31299 LOPT = LWMIN 31300 LROPT = LRWMIN 31301 LIOPT = LIWMIN 31302 ELSE 31303 IF( WANTZ ) THEN 31304 LWMIN = 2*N + N*N 31305 LRWMIN = 1 + 5*N + 2*N**2 31306 LIWMIN = 3 + 5*N 31307 ELSE 31308 LWMIN = N + 1 31309 LRWMIN = N 31310 LIWMIN = 1 31311 END IF 31312 LOPT = MAX( LWMIN, N + 31313 $ ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) ) 31314 LROPT = LRWMIN 31315 LIOPT = LIWMIN 31316 END IF 31317 WORK( 1 ) = LOPT 31318 RWORK( 1 ) = LROPT 31319 IWORK( 1 ) = LIOPT 31320 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 31321 INFO = -8 31322 ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN 31323 INFO = -10 31324 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 31325 INFO = -12 31326 END IF 31327 END IF 31328 IF( INFO.NE.0 ) THEN 31329 CALL XERBLA( 'ZHEEVD', -INFO ) 31330 RETURN 31331 ELSE IF( LQUERY ) THEN 31332 RETURN 31333 END IF 31334 IF( N.EQ.0 ) 31335 $ RETURN 31336 IF( N.EQ.1 ) THEN 31337 W( 1 ) = A( 1, 1 ) 31338 IF( WANTZ ) 31339 $ A( 1, 1 ) = CONE 31340 RETURN 31341 END IF 31342 SAFMIN = DLAMCH( 'Safe minimum' ) 31343 EPS = DLAMCH( 'Precision' ) 31344 SMLNUM = SAFMIN / EPS 31345 BIGNUM = ONE / SMLNUM 31346 RMIN = SQRT( SMLNUM ) 31347 RMAX = SQRT( BIGNUM ) 31348 ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) 31349 ISCALE = 0 31350 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 31351 ISCALE = 1 31352 SIGMA = RMIN / ANRM 31353 ELSE IF( ANRM.GT.RMAX ) THEN 31354 ISCALE = 1 31355 SIGMA = RMAX / ANRM 31356 END IF 31357 IF( ISCALE.EQ.1 ) 31358 $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) 31359 INDE = 1 31360 INDTAU = 1 31361 INDWRK = INDTAU + N 31362 INDRWK = INDE + N 31363 INDWK2 = INDWRK + N*N 31364 LLWORK = LWORK - INDWRK + 1 31365 LLWRK2 = LWORK - INDWK2 + 1 31366 LLRWK = LRWORK - INDRWK + 1 31367 CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ), 31368 $ WORK( INDWRK ), LLWORK, IINFO ) 31369 IF( .NOT.WANTZ ) THEN 31370 CALL DSTERF( N, W, RWORK( INDE ), INFO ) 31371 ELSE 31372 CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N, 31373 $ WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK, 31374 $ IWORK, LIWORK, INFO ) 31375 CALL ZUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), 31376 $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) 31377 CALL ZLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) 31378 END IF 31379 IF( ISCALE.EQ.1 ) THEN 31380 IF( INFO.EQ.0 ) THEN 31381 IMAX = N 31382 ELSE 31383 IMAX = INFO - 1 31384 END IF 31385 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 31386 END IF 31387 WORK( 1 ) = LOPT 31388 RWORK( 1 ) = LROPT 31389 IWORK( 1 ) = LIOPT 31390 RETURN 31391 END 31392! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zheevd_2stage.f 31393 SUBROUTINE ZHEEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, 31394 $ RWORK, LRWORK, IWORK, LIWORK, INFO ) 31395 IMPLICIT NONE 31396 CHARACTER JOBZ, UPLO 31397 INTEGER INFO, LDA, LIWORK, LRWORK, LWORK, N 31398 INTEGER IWORK( * ) 31399 DOUBLE PRECISION RWORK( * ), W( * ) 31400 COMPLEX*16 A( LDA, * ), WORK( * ) 31401 DOUBLE PRECISION ZERO, ONE 31402 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 31403 COMPLEX*16 CONE 31404 PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) 31405 LOGICAL LOWER, LQUERY, WANTZ 31406 INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWK2, 31407 $ INDWRK, ISCALE, LIWMIN, LLRWK, LLWORK, 31408 $ LLWRK2, LRWMIN, LWMIN, 31409 $ LHTRD, LWTRD, KD, IB, INDHOUS 31410 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 31411 $ SMLNUM 31412 LOGICAL LSAME 31413 INTEGER ILAENV2STAGE 31414 DOUBLE PRECISION DLAMCH, ZLANHE 31415 EXTERNAL LSAME, DLAMCH, ZLANHE, ILAENV2STAGE 31416 EXTERNAL DSCAL, DSTERF, XERBLA, ZLACPY, ZLASCL, 31417 $ ZSTEDC, ZUNMTR, ZHETRD_2STAGE 31418 INTRINSIC DBLE, MAX, SQRT 31419 WANTZ = LSAME( JOBZ, 'V' ) 31420 LOWER = LSAME( UPLO, 'L' ) 31421 LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 31422 INFO = 0 31423 IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN 31424 INFO = -1 31425 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 31426 INFO = -2 31427 ELSE IF( N.LT.0 ) THEN 31428 INFO = -3 31429 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 31430 INFO = -5 31431 END IF 31432 IF( INFO.EQ.0 ) THEN 31433 IF( N.LE.1 ) THEN 31434 LWMIN = 1 31435 LRWMIN = 1 31436 LIWMIN = 1 31437 ELSE 31438 KD = ILAENV2STAGE( 1, 'ZHETRD_2STAGE', JOBZ, 31439 $ N, -1, -1, -1 ) 31440 IB = ILAENV2STAGE( 2, 'ZHETRD_2STAGE', JOBZ, 31441 $ N, KD, -1, -1 ) 31442 LHTRD = ILAENV2STAGE( 3, 'ZHETRD_2STAGE', JOBZ, 31443 $ N, KD, IB, -1 ) 31444 LWTRD = ILAENV2STAGE( 4, 'ZHETRD_2STAGE', JOBZ, 31445 $ N, KD, IB, -1 ) 31446 IF( WANTZ ) THEN 31447 LWMIN = 2*N + N*N 31448 LRWMIN = 1 + 5*N + 2*N**2 31449 LIWMIN = 3 + 5*N 31450 ELSE 31451 LWMIN = N + 1 + LHTRD + LWTRD 31452 LRWMIN = N 31453 LIWMIN = 1 31454 END IF 31455 END IF 31456 WORK( 1 ) = LWMIN 31457 RWORK( 1 ) = LRWMIN 31458 IWORK( 1 ) = LIWMIN 31459 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 31460 INFO = -8 31461 ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN 31462 INFO = -10 31463 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 31464 INFO = -12 31465 END IF 31466 END IF 31467 IF( INFO.NE.0 ) THEN 31468 CALL XERBLA( 'ZHEEVD_2STAGE', -INFO ) 31469 RETURN 31470 ELSE IF( LQUERY ) THEN 31471 RETURN 31472 END IF 31473 IF( N.EQ.0 ) 31474 $ RETURN 31475 IF( N.EQ.1 ) THEN 31476 W( 1 ) = DBLE( A( 1, 1 ) ) 31477 IF( WANTZ ) 31478 $ A( 1, 1 ) = CONE 31479 RETURN 31480 END IF 31481 SAFMIN = DLAMCH( 'Safe minimum' ) 31482 EPS = DLAMCH( 'Precision' ) 31483 SMLNUM = SAFMIN / EPS 31484 BIGNUM = ONE / SMLNUM 31485 RMIN = SQRT( SMLNUM ) 31486 RMAX = SQRT( BIGNUM ) 31487 ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) 31488 ISCALE = 0 31489 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 31490 ISCALE = 1 31491 SIGMA = RMIN / ANRM 31492 ELSE IF( ANRM.GT.RMAX ) THEN 31493 ISCALE = 1 31494 SIGMA = RMAX / ANRM 31495 END IF 31496 IF( ISCALE.EQ.1 ) 31497 $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) 31498 INDE = 1 31499 INDRWK = INDE + N 31500 LLRWK = LRWORK - INDRWK + 1 31501 INDTAU = 1 31502 INDHOUS = INDTAU + N 31503 INDWRK = INDHOUS + LHTRD 31504 LLWORK = LWORK - INDWRK + 1 31505 INDWK2 = INDWRK + N*N 31506 LLWRK2 = LWORK - INDWK2 + 1 31507 CALL ZHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, W, RWORK( INDE ), 31508 $ WORK( INDTAU ), WORK( INDHOUS ), LHTRD, 31509 $ WORK( INDWRK ), LLWORK, IINFO ) 31510 IF( .NOT.WANTZ ) THEN 31511 CALL DSTERF( N, W, RWORK( INDE ), INFO ) 31512 ELSE 31513 CALL ZSTEDC( 'I', N, W, RWORK( INDE ), WORK( INDWRK ), N, 31514 $ WORK( INDWK2 ), LLWRK2, RWORK( INDRWK ), LLRWK, 31515 $ IWORK, LIWORK, INFO ) 31516 CALL ZUNMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ), 31517 $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO ) 31518 CALL ZLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA ) 31519 END IF 31520 IF( ISCALE.EQ.1 ) THEN 31521 IF( INFO.EQ.0 ) THEN 31522 IMAX = N 31523 ELSE 31524 IMAX = INFO - 1 31525 END IF 31526 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 31527 END IF 31528 WORK( 1 ) = LWMIN 31529 RWORK( 1 ) = LRWMIN 31530 IWORK( 1 ) = LIWMIN 31531 RETURN 31532 END 31533! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zheevr.f 31534 SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, 31535 $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, 31536 $ RWORK, LRWORK, IWORK, LIWORK, INFO ) 31537 CHARACTER JOBZ, RANGE, UPLO 31538 INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK, 31539 $ M, N 31540 DOUBLE PRECISION ABSTOL, VL, VU 31541 INTEGER ISUPPZ( * ), IWORK( * ) 31542 DOUBLE PRECISION RWORK( * ), W( * ) 31543 COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) 31544 DOUBLE PRECISION ZERO, ONE, TWO 31545 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) 31546 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, 31547 $ WANTZ, TRYRAC 31548 CHARACTER ORDER 31549 INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP, 31550 $ INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK, 31551 $ INDTAU, INDWK, INDWKN, ISCALE, ITMP1, J, JJ, 31552 $ LIWMIN, LLWORK, LLRWORK, LLWRKN, LRWMIN, 31553 $ LWKOPT, LWMIN, NB, NSPLIT 31554 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, 31555 $ SIGMA, SMLNUM, TMP1, VLL, VUU 31556 LOGICAL LSAME 31557 INTEGER ILAENV 31558 DOUBLE PRECISION DLAMCH, ZLANSY 31559 EXTERNAL LSAME, ILAENV, DLAMCH, ZLANSY 31560 EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, 31561 $ ZHETRD, ZSTEMR, ZSTEIN, ZSWAP, ZUNMTR 31562 INTRINSIC DBLE, MAX, MIN, SQRT 31563 IEEEOK = ILAENV( 10, 'ZHEEVR', 'N', 1, 2, 3, 4 ) 31564 LOWER = LSAME( UPLO, 'L' ) 31565 WANTZ = LSAME( JOBZ, 'V' ) 31566 ALLEIG = LSAME( RANGE, 'A' ) 31567 VALEIG = LSAME( RANGE, 'V' ) 31568 INDEIG = LSAME( RANGE, 'I' ) 31569 LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LRWORK.EQ.-1 ) .OR. 31570 $ ( LIWORK.EQ.-1 ) ) 31571 LRWMIN = MAX( 1, 24*N ) 31572 LIWMIN = MAX( 1, 10*N ) 31573 LWMIN = MAX( 1, 2*N ) 31574 INFO = 0 31575 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 31576 INFO = -1 31577 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN 31578 INFO = -2 31579 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 31580 INFO = -3 31581 ELSE IF( N.LT.0 ) THEN 31582 INFO = -4 31583 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 31584 INFO = -6 31585 ELSE 31586 IF( VALEIG ) THEN 31587 IF( N.GT.0 .AND. VU.LE.VL ) 31588 $ INFO = -8 31589 ELSE IF( INDEIG ) THEN 31590 IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN 31591 INFO = -9 31592 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN 31593 INFO = -10 31594 END IF 31595 END IF 31596 END IF 31597 IF( INFO.EQ.0 ) THEN 31598 IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 31599 INFO = -15 31600 END IF 31601 END IF 31602 IF( INFO.EQ.0 ) THEN 31603 NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) 31604 NB = MAX( NB, ILAENV( 1, 'ZUNMTR', UPLO, N, -1, -1, -1 ) ) 31605 LWKOPT = MAX( ( NB+1 )*N, LWMIN ) 31606 WORK( 1 ) = LWKOPT 31607 RWORK( 1 ) = LRWMIN 31608 IWORK( 1 ) = LIWMIN 31609 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 31610 INFO = -18 31611 ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN 31612 INFO = -20 31613 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 31614 INFO = -22 31615 END IF 31616 END IF 31617 IF( INFO.NE.0 ) THEN 31618 CALL XERBLA( 'ZHEEVR', -INFO ) 31619 RETURN 31620 ELSE IF( LQUERY ) THEN 31621 RETURN 31622 END IF 31623 M = 0 31624 IF( N.EQ.0 ) THEN 31625 WORK( 1 ) = 1 31626 RETURN 31627 END IF 31628 IF( N.EQ.1 ) THEN 31629 WORK( 1 ) = 2 31630 IF( ALLEIG .OR. INDEIG ) THEN 31631 M = 1 31632 W( 1 ) = DBLE( A( 1, 1 ) ) 31633 ELSE 31634 IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) ) 31635 $ THEN 31636 M = 1 31637 W( 1 ) = DBLE( A( 1, 1 ) ) 31638 END IF 31639 END IF 31640 IF( WANTZ ) THEN 31641 Z( 1, 1 ) = ONE 31642 ISUPPZ( 1 ) = 1 31643 ISUPPZ( 2 ) = 1 31644 END IF 31645 RETURN 31646 END IF 31647 SAFMIN = DLAMCH( 'Safe minimum' ) 31648 EPS = DLAMCH( 'Precision' ) 31649 SMLNUM = SAFMIN / EPS 31650 BIGNUM = ONE / SMLNUM 31651 RMIN = SQRT( SMLNUM ) 31652 RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) 31653 ISCALE = 0 31654 ABSTLL = ABSTOL 31655 IF (VALEIG) THEN 31656 VLL = VL 31657 VUU = VU 31658 END IF 31659 ANRM = ZLANSY( 'M', UPLO, N, A, LDA, RWORK ) 31660 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 31661 ISCALE = 1 31662 SIGMA = RMIN / ANRM 31663 ELSE IF( ANRM.GT.RMAX ) THEN 31664 ISCALE = 1 31665 SIGMA = RMAX / ANRM 31666 END IF 31667 IF( ISCALE.EQ.1 ) THEN 31668 IF( LOWER ) THEN 31669 DO 10 J = 1, N 31670 CALL ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 31671 10 CONTINUE 31672 ELSE 31673 DO 20 J = 1, N 31674 CALL ZDSCAL( J, SIGMA, A( 1, J ), 1 ) 31675 20 CONTINUE 31676 END IF 31677 IF( ABSTOL.GT.0 ) 31678 $ ABSTLL = ABSTOL*SIGMA 31679 IF( VALEIG ) THEN 31680 VLL = VL*SIGMA 31681 VUU = VU*SIGMA 31682 END IF 31683 END IF 31684 INDTAU = 1 31685 INDWK = INDTAU + N 31686 LLWORK = LWORK - INDWK + 1 31687 INDRD = 1 31688 INDRE = INDRD + N 31689 INDRDD = INDRE + N 31690 INDREE = INDRDD + N 31691 INDRWK = INDREE + N 31692 LLRWORK = LRWORK - INDRWK + 1 31693 INDIBL = 1 31694 INDISP = INDIBL + N 31695 INDIFL = INDISP + N 31696 INDIWO = INDIFL + N 31697 CALL ZHETRD( UPLO, N, A, LDA, RWORK( INDRD ), RWORK( INDRE ), 31698 $ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO ) 31699 TEST = .FALSE. 31700 IF( INDEIG ) THEN 31701 IF( IL.EQ.1 .AND. IU.EQ.N ) THEN 31702 TEST = .TRUE. 31703 END IF 31704 END IF 31705 IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN 31706 IF( .NOT.WANTZ ) THEN 31707 CALL DCOPY( N, RWORK( INDRD ), 1, W, 1 ) 31708 CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) 31709 CALL DSTERF( N, W, RWORK( INDREE ), INFO ) 31710 ELSE 31711 CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) 31712 CALL DCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 ) 31713 IF (ABSTOL .LE. TWO*N*EPS) THEN 31714 TRYRAC = .TRUE. 31715 ELSE 31716 TRYRAC = .FALSE. 31717 END IF 31718 CALL ZSTEMR( JOBZ, 'A', N, RWORK( INDRDD ), 31719 $ RWORK( INDREE ), VL, VU, IL, IU, M, W, 31720 $ Z, LDZ, N, ISUPPZ, TRYRAC, 31721 $ RWORK( INDRWK ), LLRWORK, 31722 $ IWORK, LIWORK, INFO ) 31723 IF( WANTZ .AND. INFO.EQ.0 ) THEN 31724 INDWKN = INDWK 31725 LLWRKN = LWORK - INDWKN + 1 31726 CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, 31727 $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), 31728 $ LLWRKN, IINFO ) 31729 END IF 31730 END IF 31731 IF( INFO.EQ.0 ) THEN 31732 M = N 31733 GO TO 30 31734 END IF 31735 INFO = 0 31736 END IF 31737 IF( WANTZ ) THEN 31738 ORDER = 'B' 31739 ELSE 31740 ORDER = 'E' 31741 END IF 31742 CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, 31743 $ RWORK( INDRD ), RWORK( INDRE ), M, NSPLIT, W, 31744 $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), 31745 $ IWORK( INDIWO ), INFO ) 31746 IF( WANTZ ) THEN 31747 CALL ZSTEIN( N, RWORK( INDRD ), RWORK( INDRE ), M, W, 31748 $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, 31749 $ RWORK( INDRWK ), IWORK( INDIWO ), IWORK( INDIFL ), 31750 $ INFO ) 31751 INDWKN = INDWK 31752 LLWRKN = LWORK - INDWKN + 1 31753 CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, 31754 $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) 31755 END IF 31756 30 CONTINUE 31757 IF( ISCALE.EQ.1 ) THEN 31758 IF( INFO.EQ.0 ) THEN 31759 IMAX = M 31760 ELSE 31761 IMAX = INFO - 1 31762 END IF 31763 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 31764 END IF 31765 IF( WANTZ ) THEN 31766 DO 50 J = 1, M - 1 31767 I = 0 31768 TMP1 = W( J ) 31769 DO 40 JJ = J + 1, M 31770 IF( W( JJ ).LT.TMP1 ) THEN 31771 I = JJ 31772 TMP1 = W( JJ ) 31773 END IF 31774 40 CONTINUE 31775 IF( I.NE.0 ) THEN 31776 ITMP1 = IWORK( INDIBL+I-1 ) 31777 W( I ) = W( J ) 31778 IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) 31779 W( J ) = TMP1 31780 IWORK( INDIBL+J-1 ) = ITMP1 31781 CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) 31782 END IF 31783 50 CONTINUE 31784 END IF 31785 WORK( 1 ) = LWKOPT 31786 RWORK( 1 ) = LRWMIN 31787 IWORK( 1 ) = LIWMIN 31788 RETURN 31789 END 31790! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zheevr_2stage.f 31791 SUBROUTINE ZHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, 31792 $ IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, 31793 $ WORK, LWORK, RWORK, LRWORK, IWORK, 31794 $ LIWORK, INFO ) 31795 IMPLICIT NONE 31796 CHARACTER JOBZ, RANGE, UPLO 31797 INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK, 31798 $ M, N 31799 DOUBLE PRECISION ABSTOL, VL, VU 31800 INTEGER ISUPPZ( * ), IWORK( * ) 31801 DOUBLE PRECISION RWORK( * ), W( * ) 31802 COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) 31803 DOUBLE PRECISION ZERO, ONE, TWO 31804 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) 31805 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, 31806 $ WANTZ, TRYRAC 31807 CHARACTER ORDER 31808 INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP, 31809 $ INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK, 31810 $ INDTAU, INDWK, INDWKN, ISCALE, ITMP1, J, JJ, 31811 $ LIWMIN, LLWORK, LLRWORK, LLWRKN, LRWMIN, 31812 $ LWMIN, NSPLIT, LHTRD, LWTRD, KD, IB, INDHOUS 31813 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, 31814 $ SIGMA, SMLNUM, TMP1, VLL, VUU 31815 LOGICAL LSAME 31816 INTEGER ILAENV, ILAENV2STAGE 31817 DOUBLE PRECISION DLAMCH, ZLANSY 31818 EXTERNAL LSAME, DLAMCH, ZLANSY, ILAENV, ILAENV2STAGE 31819 EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, 31820 $ ZHETRD_2STAGE, ZSTEMR, ZSTEIN, ZSWAP, ZUNMTR 31821 INTRINSIC DBLE, MAX, MIN, SQRT 31822 IEEEOK = ILAENV( 10, 'ZHEEVR', 'N', 1, 2, 3, 4 ) 31823 LOWER = LSAME( UPLO, 'L' ) 31824 WANTZ = LSAME( JOBZ, 'V' ) 31825 ALLEIG = LSAME( RANGE, 'A' ) 31826 VALEIG = LSAME( RANGE, 'V' ) 31827 INDEIG = LSAME( RANGE, 'I' ) 31828 LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LRWORK.EQ.-1 ) .OR. 31829 $ ( LIWORK.EQ.-1 ) ) 31830 KD = ILAENV2STAGE( 1, 'ZHETRD_2STAGE', JOBZ, N, -1, -1, -1 ) 31831 IB = ILAENV2STAGE( 2, 'ZHETRD_2STAGE', JOBZ, N, KD, -1, -1 ) 31832 LHTRD = ILAENV2STAGE( 3, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) 31833 LWTRD = ILAENV2STAGE( 4, 'ZHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) 31834 LWMIN = N + LHTRD + LWTRD 31835 LRWMIN = MAX( 1, 24*N ) 31836 LIWMIN = MAX( 1, 10*N ) 31837 INFO = 0 31838 IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN 31839 INFO = -1 31840 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN 31841 INFO = -2 31842 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 31843 INFO = -3 31844 ELSE IF( N.LT.0 ) THEN 31845 INFO = -4 31846 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 31847 INFO = -6 31848 ELSE 31849 IF( VALEIG ) THEN 31850 IF( N.GT.0 .AND. VU.LE.VL ) 31851 $ INFO = -8 31852 ELSE IF( INDEIG ) THEN 31853 IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN 31854 INFO = -9 31855 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN 31856 INFO = -10 31857 END IF 31858 END IF 31859 END IF 31860 IF( INFO.EQ.0 ) THEN 31861 IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 31862 INFO = -15 31863 END IF 31864 END IF 31865 IF( INFO.EQ.0 ) THEN 31866 WORK( 1 ) = LWMIN 31867 RWORK( 1 ) = LRWMIN 31868 IWORK( 1 ) = LIWMIN 31869 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 31870 INFO = -18 31871 ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN 31872 INFO = -20 31873 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 31874 INFO = -22 31875 END IF 31876 END IF 31877 IF( INFO.NE.0 ) THEN 31878 CALL XERBLA( 'ZHEEVR_2STAGE', -INFO ) 31879 RETURN 31880 ELSE IF( LQUERY ) THEN 31881 RETURN 31882 END IF 31883 M = 0 31884 IF( N.EQ.0 ) THEN 31885 WORK( 1 ) = 1 31886 RETURN 31887 END IF 31888 IF( N.EQ.1 ) THEN 31889 WORK( 1 ) = 2 31890 IF( ALLEIG .OR. INDEIG ) THEN 31891 M = 1 31892 W( 1 ) = DBLE( A( 1, 1 ) ) 31893 ELSE 31894 IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) ) 31895 $ THEN 31896 M = 1 31897 W( 1 ) = DBLE( A( 1, 1 ) ) 31898 END IF 31899 END IF 31900 IF( WANTZ ) THEN 31901 Z( 1, 1 ) = ONE 31902 ISUPPZ( 1 ) = 1 31903 ISUPPZ( 2 ) = 1 31904 END IF 31905 RETURN 31906 END IF 31907 SAFMIN = DLAMCH( 'Safe minimum' ) 31908 EPS = DLAMCH( 'Precision' ) 31909 SMLNUM = SAFMIN / EPS 31910 BIGNUM = ONE / SMLNUM 31911 RMIN = SQRT( SMLNUM ) 31912 RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) 31913 ISCALE = 0 31914 ABSTLL = ABSTOL 31915 IF (VALEIG) THEN 31916 VLL = VL 31917 VUU = VU 31918 END IF 31919 ANRM = ZLANSY( 'M', UPLO, N, A, LDA, RWORK ) 31920 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 31921 ISCALE = 1 31922 SIGMA = RMIN / ANRM 31923 ELSE IF( ANRM.GT.RMAX ) THEN 31924 ISCALE = 1 31925 SIGMA = RMAX / ANRM 31926 END IF 31927 IF( ISCALE.EQ.1 ) THEN 31928 IF( LOWER ) THEN 31929 DO 10 J = 1, N 31930 CALL ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 31931 10 CONTINUE 31932 ELSE 31933 DO 20 J = 1, N 31934 CALL ZDSCAL( J, SIGMA, A( 1, J ), 1 ) 31935 20 CONTINUE 31936 END IF 31937 IF( ABSTOL.GT.0 ) 31938 $ ABSTLL = ABSTOL*SIGMA 31939 IF( VALEIG ) THEN 31940 VLL = VL*SIGMA 31941 VUU = VU*SIGMA 31942 END IF 31943 END IF 31944 INDTAU = 1 31945 INDHOUS = INDTAU + N 31946 INDWK = INDHOUS + LHTRD 31947 LLWORK = LWORK - INDWK + 1 31948 INDRD = 1 31949 INDRE = INDRD + N 31950 INDRDD = INDRE + N 31951 INDREE = INDRDD + N 31952 INDRWK = INDREE + N 31953 LLRWORK = LRWORK - INDRWK + 1 31954 INDIBL = 1 31955 INDISP = INDIBL + N 31956 INDIFL = INDISP + N 31957 INDIWO = INDIFL + N 31958 CALL ZHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, RWORK( INDRD ), 31959 $ RWORK( INDRE ), WORK( INDTAU ), 31960 $ WORK( INDHOUS ), LHTRD, 31961 $ WORK( INDWK ), LLWORK, IINFO ) 31962 TEST = .FALSE. 31963 IF( INDEIG ) THEN 31964 IF( IL.EQ.1 .AND. IU.EQ.N ) THEN 31965 TEST = .TRUE. 31966 END IF 31967 END IF 31968 IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN 31969 IF( .NOT.WANTZ ) THEN 31970 CALL DCOPY( N, RWORK( INDRD ), 1, W, 1 ) 31971 CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) 31972 CALL DSTERF( N, W, RWORK( INDREE ), INFO ) 31973 ELSE 31974 CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) 31975 CALL DCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 ) 31976 IF (ABSTOL .LE. TWO*N*EPS) THEN 31977 TRYRAC = .TRUE. 31978 ELSE 31979 TRYRAC = .FALSE. 31980 END IF 31981 CALL ZSTEMR( JOBZ, 'A', N, RWORK( INDRDD ), 31982 $ RWORK( INDREE ), VL, VU, IL, IU, M, W, 31983 $ Z, LDZ, N, ISUPPZ, TRYRAC, 31984 $ RWORK( INDRWK ), LLRWORK, 31985 $ IWORK, LIWORK, INFO ) 31986 IF( WANTZ .AND. INFO.EQ.0 ) THEN 31987 INDWKN = INDWK 31988 LLWRKN = LWORK - INDWKN + 1 31989 CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, 31990 $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), 31991 $ LLWRKN, IINFO ) 31992 END IF 31993 END IF 31994 IF( INFO.EQ.0 ) THEN 31995 M = N 31996 GO TO 30 31997 END IF 31998 INFO = 0 31999 END IF 32000 IF( WANTZ ) THEN 32001 ORDER = 'B' 32002 ELSE 32003 ORDER = 'E' 32004 END IF 32005 CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, 32006 $ RWORK( INDRD ), RWORK( INDRE ), M, NSPLIT, W, 32007 $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), 32008 $ IWORK( INDIWO ), INFO ) 32009 IF( WANTZ ) THEN 32010 CALL ZSTEIN( N, RWORK( INDRD ), RWORK( INDRE ), M, W, 32011 $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, 32012 $ RWORK( INDRWK ), IWORK( INDIWO ), IWORK( INDIFL ), 32013 $ INFO ) 32014 INDWKN = INDWK 32015 LLWRKN = LWORK - INDWKN + 1 32016 CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, 32017 $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) 32018 END IF 32019 30 CONTINUE 32020 IF( ISCALE.EQ.1 ) THEN 32021 IF( INFO.EQ.0 ) THEN 32022 IMAX = M 32023 ELSE 32024 IMAX = INFO - 1 32025 END IF 32026 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 32027 END IF 32028 IF( WANTZ ) THEN 32029 DO 50 J = 1, M - 1 32030 I = 0 32031 TMP1 = W( J ) 32032 DO 40 JJ = J + 1, M 32033 IF( W( JJ ).LT.TMP1 ) THEN 32034 I = JJ 32035 TMP1 = W( JJ ) 32036 END IF 32037 40 CONTINUE 32038 IF( I.NE.0 ) THEN 32039 ITMP1 = IWORK( INDIBL+I-1 ) 32040 W( I ) = W( J ) 32041 IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) 32042 W( J ) = TMP1 32043 IWORK( INDIBL+J-1 ) = ITMP1 32044 CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) 32045 END IF 32046 50 CONTINUE 32047 END IF 32048 WORK( 1 ) = LWMIN 32049 RWORK( 1 ) = LRWMIN 32050 IWORK( 1 ) = LIWMIN 32051 RETURN 32052 END 32053! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zheevx.f 32054 SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, 32055 $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, 32056 $ IWORK, IFAIL, INFO ) 32057 CHARACTER JOBZ, RANGE, UPLO 32058 INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N 32059 DOUBLE PRECISION ABSTOL, VL, VU 32060 INTEGER IFAIL( * ), IWORK( * ) 32061 DOUBLE PRECISION RWORK( * ), W( * ) 32062 COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) 32063 DOUBLE PRECISION ZERO, ONE 32064 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 32065 COMPLEX*16 CONE 32066 PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) 32067 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, 32068 $ WANTZ 32069 CHARACTER ORDER 32070 INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, 32071 $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, 32072 $ ITMP1, J, JJ, LLWORK, LWKMIN, LWKOPT, NB, 32073 $ NSPLIT 32074 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, 32075 $ SIGMA, SMLNUM, TMP1, VLL, VUU 32076 LOGICAL LSAME 32077 INTEGER ILAENV 32078 DOUBLE PRECISION DLAMCH, ZLANHE 32079 EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE 32080 EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, 32081 $ ZHETRD, ZLACPY, ZSTEIN, ZSTEQR, ZSWAP, ZUNGTR, 32082 $ ZUNMTR 32083 INTRINSIC DBLE, MAX, MIN, SQRT 32084 LOWER = LSAME( UPLO, 'L' ) 32085 WANTZ = LSAME( JOBZ, 'V' ) 32086 ALLEIG = LSAME( RANGE, 'A' ) 32087 VALEIG = LSAME( RANGE, 'V' ) 32088 INDEIG = LSAME( RANGE, 'I' ) 32089 LQUERY = ( LWORK.EQ.-1 ) 32090 INFO = 0 32091 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 32092 INFO = -1 32093 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN 32094 INFO = -2 32095 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 32096 INFO = -3 32097 ELSE IF( N.LT.0 ) THEN 32098 INFO = -4 32099 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 32100 INFO = -6 32101 ELSE 32102 IF( VALEIG ) THEN 32103 IF( N.GT.0 .AND. VU.LE.VL ) 32104 $ INFO = -8 32105 ELSE IF( INDEIG ) THEN 32106 IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN 32107 INFO = -9 32108 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN 32109 INFO = -10 32110 END IF 32111 END IF 32112 END IF 32113 IF( INFO.EQ.0 ) THEN 32114 IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 32115 INFO = -15 32116 END IF 32117 END IF 32118 IF( INFO.EQ.0 ) THEN 32119 IF( N.LE.1 ) THEN 32120 LWKMIN = 1 32121 WORK( 1 ) = LWKMIN 32122 ELSE 32123 LWKMIN = 2*N 32124 NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) 32125 NB = MAX( NB, ILAENV( 1, 'ZUNMTR', UPLO, N, -1, -1, -1 ) ) 32126 LWKOPT = MAX( 1, ( NB + 1 )*N ) 32127 WORK( 1 ) = LWKOPT 32128 END IF 32129 IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) 32130 $ INFO = -17 32131 END IF 32132 IF( INFO.NE.0 ) THEN 32133 CALL XERBLA( 'ZHEEVX', -INFO ) 32134 RETURN 32135 ELSE IF( LQUERY ) THEN 32136 RETURN 32137 END IF 32138 M = 0 32139 IF( N.EQ.0 ) THEN 32140 RETURN 32141 END IF 32142 IF( N.EQ.1 ) THEN 32143 IF( ALLEIG .OR. INDEIG ) THEN 32144 M = 1 32145 W( 1 ) = A( 1, 1 ) 32146 ELSE IF( VALEIG ) THEN 32147 IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) ) 32148 $ THEN 32149 M = 1 32150 W( 1 ) = A( 1, 1 ) 32151 END IF 32152 END IF 32153 IF( WANTZ ) 32154 $ Z( 1, 1 ) = CONE 32155 RETURN 32156 END IF 32157 SAFMIN = DLAMCH( 'Safe minimum' ) 32158 EPS = DLAMCH( 'Precision' ) 32159 SMLNUM = SAFMIN / EPS 32160 BIGNUM = ONE / SMLNUM 32161 RMIN = SQRT( SMLNUM ) 32162 RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) 32163 ISCALE = 0 32164 ABSTLL = ABSTOL 32165 IF( VALEIG ) THEN 32166 VLL = VL 32167 VUU = VU 32168 END IF 32169 ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) 32170 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 32171 ISCALE = 1 32172 SIGMA = RMIN / ANRM 32173 ELSE IF( ANRM.GT.RMAX ) THEN 32174 ISCALE = 1 32175 SIGMA = RMAX / ANRM 32176 END IF 32177 IF( ISCALE.EQ.1 ) THEN 32178 IF( LOWER ) THEN 32179 DO 10 J = 1, N 32180 CALL ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 32181 10 CONTINUE 32182 ELSE 32183 DO 20 J = 1, N 32184 CALL ZDSCAL( J, SIGMA, A( 1, J ), 1 ) 32185 20 CONTINUE 32186 END IF 32187 IF( ABSTOL.GT.0 ) 32188 $ ABSTLL = ABSTOL*SIGMA 32189 IF( VALEIG ) THEN 32190 VLL = VL*SIGMA 32191 VUU = VU*SIGMA 32192 END IF 32193 END IF 32194 INDD = 1 32195 INDE = INDD + N 32196 INDRWK = INDE + N 32197 INDTAU = 1 32198 INDWRK = INDTAU + N 32199 LLWORK = LWORK - INDWRK + 1 32200 CALL ZHETRD( UPLO, N, A, LDA, RWORK( INDD ), RWORK( INDE ), 32201 $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO ) 32202 TEST = .FALSE. 32203 IF( INDEIG ) THEN 32204 IF( IL.EQ.1 .AND. IU.EQ.N ) THEN 32205 TEST = .TRUE. 32206 END IF 32207 END IF 32208 IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN 32209 CALL DCOPY( N, RWORK( INDD ), 1, W, 1 ) 32210 INDEE = INDRWK + 2*N 32211 IF( .NOT.WANTZ ) THEN 32212 CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) 32213 CALL DSTERF( N, W, RWORK( INDEE ), INFO ) 32214 ELSE 32215 CALL ZLACPY( 'A', N, N, A, LDA, Z, LDZ ) 32216 CALL ZUNGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), 32217 $ WORK( INDWRK ), LLWORK, IINFO ) 32218 CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) 32219 CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ, 32220 $ RWORK( INDRWK ), INFO ) 32221 IF( INFO.EQ.0 ) THEN 32222 DO 30 I = 1, N 32223 IFAIL( I ) = 0 32224 30 CONTINUE 32225 END IF 32226 END IF 32227 IF( INFO.EQ.0 ) THEN 32228 M = N 32229 GO TO 40 32230 END IF 32231 INFO = 0 32232 END IF 32233 IF( WANTZ ) THEN 32234 ORDER = 'B' 32235 ELSE 32236 ORDER = 'E' 32237 END IF 32238 INDIBL = 1 32239 INDISP = INDIBL + N 32240 INDIWK = INDISP + N 32241 CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, 32242 $ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W, 32243 $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), 32244 $ IWORK( INDIWK ), INFO ) 32245 IF( WANTZ ) THEN 32246 CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W, 32247 $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, 32248 $ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO ) 32249 CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, 32250 $ LDZ, WORK( INDWRK ), LLWORK, IINFO ) 32251 END IF 32252 40 CONTINUE 32253 IF( ISCALE.EQ.1 ) THEN 32254 IF( INFO.EQ.0 ) THEN 32255 IMAX = M 32256 ELSE 32257 IMAX = INFO - 1 32258 END IF 32259 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 32260 END IF 32261 IF( WANTZ ) THEN 32262 DO 60 J = 1, M - 1 32263 I = 0 32264 TMP1 = W( J ) 32265 DO 50 JJ = J + 1, M 32266 IF( W( JJ ).LT.TMP1 ) THEN 32267 I = JJ 32268 TMP1 = W( JJ ) 32269 END IF 32270 50 CONTINUE 32271 IF( I.NE.0 ) THEN 32272 ITMP1 = IWORK( INDIBL+I-1 ) 32273 W( I ) = W( J ) 32274 IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) 32275 W( J ) = TMP1 32276 IWORK( INDIBL+J-1 ) = ITMP1 32277 CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) 32278 IF( INFO.NE.0 ) THEN 32279 ITMP1 = IFAIL( I ) 32280 IFAIL( I ) = IFAIL( J ) 32281 IFAIL( J ) = ITMP1 32282 END IF 32283 END IF 32284 60 CONTINUE 32285 END IF 32286 WORK( 1 ) = LWKOPT 32287 RETURN 32288 END 32289! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zheevx_2stage.f 32290 SUBROUTINE ZHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, 32291 $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, 32292 $ LWORK, RWORK, IWORK, IFAIL, INFO ) 32293 IMPLICIT NONE 32294 CHARACTER JOBZ, RANGE, UPLO 32295 INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N 32296 DOUBLE PRECISION ABSTOL, VL, VU 32297 INTEGER IFAIL( * ), IWORK( * ) 32298 DOUBLE PRECISION RWORK( * ), W( * ) 32299 COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) 32300 DOUBLE PRECISION ZERO, ONE 32301 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 32302 COMPLEX*16 CONE 32303 PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) 32304 LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, 32305 $ WANTZ 32306 CHARACTER ORDER 32307 INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, 32308 $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, 32309 $ ITMP1, J, JJ, LLWORK, 32310 $ NSPLIT, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS 32311 DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, 32312 $ SIGMA, SMLNUM, TMP1, VLL, VUU 32313 LOGICAL LSAME 32314 INTEGER ILAENV2STAGE 32315 DOUBLE PRECISION DLAMCH, ZLANHE 32316 EXTERNAL LSAME, DLAMCH, ZLANHE, ILAENV2STAGE 32317 EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, 32318 $ ZLACPY, ZSTEIN, ZSTEQR, ZSWAP, ZUNGTR, ZUNMTR, 32319 $ ZHETRD_2STAGE 32320 INTRINSIC DBLE, MAX, MIN, SQRT 32321 LOWER = LSAME( UPLO, 'L' ) 32322 WANTZ = LSAME( JOBZ, 'V' ) 32323 ALLEIG = LSAME( RANGE, 'A' ) 32324 VALEIG = LSAME( RANGE, 'V' ) 32325 INDEIG = LSAME( RANGE, 'I' ) 32326 LQUERY = ( LWORK.EQ.-1 ) 32327 INFO = 0 32328 IF( .NOT.( LSAME( JOBZ, 'N' ) ) ) THEN 32329 INFO = -1 32330 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN 32331 INFO = -2 32332 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN 32333 INFO = -3 32334 ELSE IF( N.LT.0 ) THEN 32335 INFO = -4 32336 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 32337 INFO = -6 32338 ELSE 32339 IF( VALEIG ) THEN 32340 IF( N.GT.0 .AND. VU.LE.VL ) 32341 $ INFO = -8 32342 ELSE IF( INDEIG ) THEN 32343 IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN 32344 INFO = -9 32345 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN 32346 INFO = -10 32347 END IF 32348 END IF 32349 END IF 32350 IF( INFO.EQ.0 ) THEN 32351 IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 32352 INFO = -15 32353 END IF 32354 END IF 32355 IF( INFO.EQ.0 ) THEN 32356 IF( N.LE.1 ) THEN 32357 LWMIN = 1 32358 WORK( 1 ) = LWMIN 32359 ELSE 32360 KD = ILAENV2STAGE( 1, 'ZHETRD_2STAGE', JOBZ, 32361 $ N, -1, -1, -1 ) 32362 IB = ILAENV2STAGE( 2, 'ZHETRD_2STAGE', JOBZ, 32363 $ N, KD, -1, -1 ) 32364 LHTRD = ILAENV2STAGE( 3, 'ZHETRD_2STAGE', JOBZ, 32365 $ N, KD, IB, -1 ) 32366 LWTRD = ILAENV2STAGE( 4, 'ZHETRD_2STAGE', JOBZ, 32367 $ N, KD, IB, -1 ) 32368 LWMIN = N + LHTRD + LWTRD 32369 WORK( 1 ) = LWMIN 32370 END IF 32371 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) 32372 $ INFO = -17 32373 END IF 32374 IF( INFO.NE.0 ) THEN 32375 CALL XERBLA( 'ZHEEVX_2STAGE', -INFO ) 32376 RETURN 32377 ELSE IF( LQUERY ) THEN 32378 RETURN 32379 END IF 32380 M = 0 32381 IF( N.EQ.0 ) THEN 32382 RETURN 32383 END IF 32384 IF( N.EQ.1 ) THEN 32385 IF( ALLEIG .OR. INDEIG ) THEN 32386 M = 1 32387 W( 1 ) = DBLE( A( 1, 1 ) ) 32388 ELSE IF( VALEIG ) THEN 32389 IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) ) 32390 $ THEN 32391 M = 1 32392 W( 1 ) = DBLE( A( 1, 1 ) ) 32393 END IF 32394 END IF 32395 IF( WANTZ ) 32396 $ Z( 1, 1 ) = CONE 32397 RETURN 32398 END IF 32399 SAFMIN = DLAMCH( 'Safe minimum' ) 32400 EPS = DLAMCH( 'Precision' ) 32401 SMLNUM = SAFMIN / EPS 32402 BIGNUM = ONE / SMLNUM 32403 RMIN = SQRT( SMLNUM ) 32404 RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) 32405 ISCALE = 0 32406 ABSTLL = ABSTOL 32407 IF( VALEIG ) THEN 32408 VLL = VL 32409 VUU = VU 32410 END IF 32411 ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) 32412 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 32413 ISCALE = 1 32414 SIGMA = RMIN / ANRM 32415 ELSE IF( ANRM.GT.RMAX ) THEN 32416 ISCALE = 1 32417 SIGMA = RMAX / ANRM 32418 END IF 32419 IF( ISCALE.EQ.1 ) THEN 32420 IF( LOWER ) THEN 32421 DO 10 J = 1, N 32422 CALL ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 32423 10 CONTINUE 32424 ELSE 32425 DO 20 J = 1, N 32426 CALL ZDSCAL( J, SIGMA, A( 1, J ), 1 ) 32427 20 CONTINUE 32428 END IF 32429 IF( ABSTOL.GT.0 ) 32430 $ ABSTLL = ABSTOL*SIGMA 32431 IF( VALEIG ) THEN 32432 VLL = VL*SIGMA 32433 VUU = VU*SIGMA 32434 END IF 32435 END IF 32436 INDD = 1 32437 INDE = INDD + N 32438 INDRWK = INDE + N 32439 INDTAU = 1 32440 INDHOUS = INDTAU + N 32441 INDWRK = INDHOUS + LHTRD 32442 LLWORK = LWORK - INDWRK + 1 32443 CALL ZHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, RWORK( INDD ), 32444 $ RWORK( INDE ), WORK( INDTAU ), 32445 $ WORK( INDHOUS ), LHTRD, WORK( INDWRK ), 32446 $ LLWORK, IINFO ) 32447 TEST = .FALSE. 32448 IF( INDEIG ) THEN 32449 IF( IL.EQ.1 .AND. IU.EQ.N ) THEN 32450 TEST = .TRUE. 32451 END IF 32452 END IF 32453 IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN 32454 CALL DCOPY( N, RWORK( INDD ), 1, W, 1 ) 32455 INDEE = INDRWK + 2*N 32456 IF( .NOT.WANTZ ) THEN 32457 CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) 32458 CALL DSTERF( N, W, RWORK( INDEE ), INFO ) 32459 ELSE 32460 CALL ZLACPY( 'A', N, N, A, LDA, Z, LDZ ) 32461 CALL ZUNGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), 32462 $ WORK( INDWRK ), LLWORK, IINFO ) 32463 CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) 32464 CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ, 32465 $ RWORK( INDRWK ), INFO ) 32466 IF( INFO.EQ.0 ) THEN 32467 DO 30 I = 1, N 32468 IFAIL( I ) = 0 32469 30 CONTINUE 32470 END IF 32471 END IF 32472 IF( INFO.EQ.0 ) THEN 32473 M = N 32474 GO TO 40 32475 END IF 32476 INFO = 0 32477 END IF 32478 IF( WANTZ ) THEN 32479 ORDER = 'B' 32480 ELSE 32481 ORDER = 'E' 32482 END IF 32483 INDIBL = 1 32484 INDISP = INDIBL + N 32485 INDIWK = INDISP + N 32486 CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, 32487 $ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W, 32488 $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), 32489 $ IWORK( INDIWK ), INFO ) 32490 IF( WANTZ ) THEN 32491 CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W, 32492 $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, 32493 $ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO ) 32494 CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, 32495 $ LDZ, WORK( INDWRK ), LLWORK, IINFO ) 32496 END IF 32497 40 CONTINUE 32498 IF( ISCALE.EQ.1 ) THEN 32499 IF( INFO.EQ.0 ) THEN 32500 IMAX = M 32501 ELSE 32502 IMAX = INFO - 1 32503 END IF 32504 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 32505 END IF 32506 IF( WANTZ ) THEN 32507 DO 60 J = 1, M - 1 32508 I = 0 32509 TMP1 = W( J ) 32510 DO 50 JJ = J + 1, M 32511 IF( W( JJ ).LT.TMP1 ) THEN 32512 I = JJ 32513 TMP1 = W( JJ ) 32514 END IF 32515 50 CONTINUE 32516 IF( I.NE.0 ) THEN 32517 ITMP1 = IWORK( INDIBL+I-1 ) 32518 W( I ) = W( J ) 32519 IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) 32520 W( J ) = TMP1 32521 IWORK( INDIBL+J-1 ) = ITMP1 32522 CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) 32523 IF( INFO.NE.0 ) THEN 32524 ITMP1 = IFAIL( I ) 32525 IFAIL( I ) = IFAIL( J ) 32526 IFAIL( J ) = ITMP1 32527 END IF 32528 END IF 32529 60 CONTINUE 32530 END IF 32531 WORK( 1 ) = LWMIN 32532 RETURN 32533 END 32534! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhegs2.f 32535 SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) 32536 CHARACTER UPLO 32537 INTEGER INFO, ITYPE, LDA, LDB, N 32538 COMPLEX*16 A( LDA, * ), B( LDB, * ) 32539 DOUBLE PRECISION ONE, HALF 32540 PARAMETER ( ONE = 1.0D+0, HALF = 0.5D+0 ) 32541 COMPLEX*16 CONE 32542 PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) 32543 LOGICAL UPPER 32544 INTEGER K 32545 DOUBLE PRECISION AKK, BKK 32546 COMPLEX*16 CT 32547 EXTERNAL XERBLA, ZAXPY, ZDSCAL, ZHER2, ZLACGV, ZTRMV, 32548 $ ZTRSV 32549 INTRINSIC MAX 32550 LOGICAL LSAME 32551 EXTERNAL LSAME 32552 INFO = 0 32553 UPPER = LSAME( UPLO, 'U' ) 32554 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN 32555 INFO = -1 32556 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 32557 INFO = -2 32558 ELSE IF( N.LT.0 ) THEN 32559 INFO = -3 32560 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 32561 INFO = -5 32562 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 32563 INFO = -7 32564 END IF 32565 IF( INFO.NE.0 ) THEN 32566 CALL XERBLA( 'ZHEGS2', -INFO ) 32567 RETURN 32568 END IF 32569 IF( ITYPE.EQ.1 ) THEN 32570 IF( UPPER ) THEN 32571 DO 10 K = 1, N 32572 AKK = A( K, K ) 32573 BKK = B( K, K ) 32574 AKK = AKK / BKK**2 32575 A( K, K ) = AKK 32576 IF( K.LT.N ) THEN 32577 CALL ZDSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) 32578 CT = -HALF*AKK 32579 CALL ZLACGV( N-K, A( K, K+1 ), LDA ) 32580 CALL ZLACGV( N-K, B( K, K+1 ), LDB ) 32581 CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), 32582 $ LDA ) 32583 CALL ZHER2( UPLO, N-K, -CONE, A( K, K+1 ), LDA, 32584 $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) 32585 CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), 32586 $ LDA ) 32587 CALL ZLACGV( N-K, B( K, K+1 ), LDB ) 32588 CALL ZTRSV( UPLO, 'Conjugate transpose', 'Non-unit', 32589 $ N-K, B( K+1, K+1 ), LDB, A( K, K+1 ), 32590 $ LDA ) 32591 CALL ZLACGV( N-K, A( K, K+1 ), LDA ) 32592 END IF 32593 10 CONTINUE 32594 ELSE 32595 DO 20 K = 1, N 32596 AKK = A( K, K ) 32597 BKK = B( K, K ) 32598 AKK = AKK / BKK**2 32599 A( K, K ) = AKK 32600 IF( K.LT.N ) THEN 32601 CALL ZDSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) 32602 CT = -HALF*AKK 32603 CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) 32604 CALL ZHER2( UPLO, N-K, -CONE, A( K+1, K ), 1, 32605 $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) 32606 CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) 32607 CALL ZTRSV( UPLO, 'No transpose', 'Non-unit', N-K, 32608 $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) 32609 END IF 32610 20 CONTINUE 32611 END IF 32612 ELSE 32613 IF( UPPER ) THEN 32614 DO 30 K = 1, N 32615 AKK = A( K, K ) 32616 BKK = B( K, K ) 32617 CALL ZTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, 32618 $ LDB, A( 1, K ), 1 ) 32619 CT = HALF*AKK 32620 CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) 32621 CALL ZHER2( UPLO, K-1, CONE, A( 1, K ), 1, B( 1, K ), 1, 32622 $ A, LDA ) 32623 CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) 32624 CALL ZDSCAL( K-1, BKK, A( 1, K ), 1 ) 32625 A( K, K ) = AKK*BKK**2 32626 30 CONTINUE 32627 ELSE 32628 DO 40 K = 1, N 32629 AKK = A( K, K ) 32630 BKK = B( K, K ) 32631 CALL ZLACGV( K-1, A( K, 1 ), LDA ) 32632 CALL ZTRMV( UPLO, 'Conjugate transpose', 'Non-unit', K-1, 32633 $ B, LDB, A( K, 1 ), LDA ) 32634 CT = HALF*AKK 32635 CALL ZLACGV( K-1, B( K, 1 ), LDB ) 32636 CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) 32637 CALL ZHER2( UPLO, K-1, CONE, A( K, 1 ), LDA, B( K, 1 ), 32638 $ LDB, A, LDA ) 32639 CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) 32640 CALL ZLACGV( K-1, B( K, 1 ), LDB ) 32641 CALL ZDSCAL( K-1, BKK, A( K, 1 ), LDA ) 32642 CALL ZLACGV( K-1, A( K, 1 ), LDA ) 32643 A( K, K ) = AKK*BKK**2 32644 40 CONTINUE 32645 END IF 32646 END IF 32647 RETURN 32648 END 32649! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhegst.f 32650 SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) 32651 CHARACTER UPLO 32652 INTEGER INFO, ITYPE, LDA, LDB, N 32653 COMPLEX*16 A( LDA, * ), B( LDB, * ) 32654 DOUBLE PRECISION ONE 32655 PARAMETER ( ONE = 1.0D+0 ) 32656 COMPLEX*16 CONE, HALF 32657 PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), 32658 $ HALF = ( 0.5D+0, 0.0D+0 ) ) 32659 LOGICAL UPPER 32660 INTEGER K, KB, NB 32661 EXTERNAL XERBLA, ZHEGS2, ZHEMM, ZHER2K, ZTRMM, ZTRSM 32662 INTRINSIC MAX, MIN 32663 LOGICAL LSAME 32664 INTEGER ILAENV 32665 EXTERNAL LSAME, ILAENV 32666 INFO = 0 32667 UPPER = LSAME( UPLO, 'U' ) 32668 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN 32669 INFO = -1 32670 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 32671 INFO = -2 32672 ELSE IF( N.LT.0 ) THEN 32673 INFO = -3 32674 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 32675 INFO = -5 32676 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 32677 INFO = -7 32678 END IF 32679 IF( INFO.NE.0 ) THEN 32680 CALL XERBLA( 'ZHEGST', -INFO ) 32681 RETURN 32682 END IF 32683 IF( N.EQ.0 ) 32684 $ RETURN 32685 NB = ILAENV( 1, 'ZHEGST', UPLO, N, -1, -1, -1 ) 32686 IF( NB.LE.1 .OR. NB.GE.N ) THEN 32687 CALL ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) 32688 ELSE 32689 IF( ITYPE.EQ.1 ) THEN 32690 IF( UPPER ) THEN 32691 DO 10 K = 1, N, NB 32692 KB = MIN( N-K+1, NB ) 32693 CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, 32694 $ B( K, K ), LDB, INFO ) 32695 IF( K+KB.LE.N ) THEN 32696 CALL ZTRSM( 'Left', UPLO, 'Conjugate transpose', 32697 $ 'Non-unit', KB, N-K-KB+1, CONE, 32698 $ B( K, K ), LDB, A( K, K+KB ), LDA ) 32699 CALL ZHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, 32700 $ A( K, K ), LDA, B( K, K+KB ), LDB, 32701 $ CONE, A( K, K+KB ), LDA ) 32702 CALL ZHER2K( UPLO, 'Conjugate transpose', N-K-KB+1, 32703 $ KB, -CONE, A( K, K+KB ), LDA, 32704 $ B( K, K+KB ), LDB, ONE, 32705 $ A( K+KB, K+KB ), LDA ) 32706 CALL ZHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, 32707 $ A( K, K ), LDA, B( K, K+KB ), LDB, 32708 $ CONE, A( K, K+KB ), LDA ) 32709 CALL ZTRSM( 'Right', UPLO, 'No transpose', 32710 $ 'Non-unit', KB, N-K-KB+1, CONE, 32711 $ B( K+KB, K+KB ), LDB, A( K, K+KB ), 32712 $ LDA ) 32713 END IF 32714 10 CONTINUE 32715 ELSE 32716 DO 20 K = 1, N, NB 32717 KB = MIN( N-K+1, NB ) 32718 CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, 32719 $ B( K, K ), LDB, INFO ) 32720 IF( K+KB.LE.N ) THEN 32721 CALL ZTRSM( 'Right', UPLO, 'Conjugate transpose', 32722 $ 'Non-unit', N-K-KB+1, KB, CONE, 32723 $ B( K, K ), LDB, A( K+KB, K ), LDA ) 32724 CALL ZHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, 32725 $ A( K, K ), LDA, B( K+KB, K ), LDB, 32726 $ CONE, A( K+KB, K ), LDA ) 32727 CALL ZHER2K( UPLO, 'No transpose', N-K-KB+1, KB, 32728 $ -CONE, A( K+KB, K ), LDA, 32729 $ B( K+KB, K ), LDB, ONE, 32730 $ A( K+KB, K+KB ), LDA ) 32731 CALL ZHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, 32732 $ A( K, K ), LDA, B( K+KB, K ), LDB, 32733 $ CONE, A( K+KB, K ), LDA ) 32734 CALL ZTRSM( 'Left', UPLO, 'No transpose', 32735 $ 'Non-unit', N-K-KB+1, KB, CONE, 32736 $ B( K+KB, K+KB ), LDB, A( K+KB, K ), 32737 $ LDA ) 32738 END IF 32739 20 CONTINUE 32740 END IF 32741 ELSE 32742 IF( UPPER ) THEN 32743 DO 30 K = 1, N, NB 32744 KB = MIN( N-K+1, NB ) 32745 CALL ZTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', 32746 $ K-1, KB, CONE, B, LDB, A( 1, K ), LDA ) 32747 CALL ZHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), 32748 $ LDA, B( 1, K ), LDB, CONE, A( 1, K ), 32749 $ LDA ) 32750 CALL ZHER2K( UPLO, 'No transpose', K-1, KB, CONE, 32751 $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, 32752 $ LDA ) 32753 CALL ZHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), 32754 $ LDA, B( 1, K ), LDB, CONE, A( 1, K ), 32755 $ LDA ) 32756 CALL ZTRMM( 'Right', UPLO, 'Conjugate transpose', 32757 $ 'Non-unit', K-1, KB, CONE, B( K, K ), LDB, 32758 $ A( 1, K ), LDA ) 32759 CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, 32760 $ B( K, K ), LDB, INFO ) 32761 30 CONTINUE 32762 ELSE 32763 DO 40 K = 1, N, NB 32764 KB = MIN( N-K+1, NB ) 32765 CALL ZTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', 32766 $ KB, K-1, CONE, B, LDB, A( K, 1 ), LDA ) 32767 CALL ZHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), 32768 $ LDA, B( K, 1 ), LDB, CONE, A( K, 1 ), 32769 $ LDA ) 32770 CALL ZHER2K( UPLO, 'Conjugate transpose', K-1, KB, 32771 $ CONE, A( K, 1 ), LDA, B( K, 1 ), LDB, 32772 $ ONE, A, LDA ) 32773 CALL ZHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), 32774 $ LDA, B( K, 1 ), LDB, CONE, A( K, 1 ), 32775 $ LDA ) 32776 CALL ZTRMM( 'Left', UPLO, 'Conjugate transpose', 32777 $ 'Non-unit', KB, K-1, CONE, B( K, K ), LDB, 32778 $ A( K, 1 ), LDA ) 32779 CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, 32780 $ B( K, K ), LDB, INFO ) 32781 40 CONTINUE 32782 END IF 32783 END IF 32784 END IF 32785 RETURN 32786 END 32787! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhetd2.f 32788 SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) 32789 CHARACTER UPLO 32790 INTEGER INFO, LDA, N 32791 DOUBLE PRECISION D( * ), E( * ) 32792 COMPLEX*16 A( LDA, * ), TAU( * ) 32793 COMPLEX*16 ONE, ZERO, HALF 32794 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), 32795 $ ZERO = ( 0.0D+0, 0.0D+0 ), 32796 $ HALF = ( 0.5D+0, 0.0D+0 ) ) 32797 LOGICAL UPPER 32798 INTEGER I 32799 COMPLEX*16 ALPHA, TAUI 32800 EXTERNAL XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG 32801 LOGICAL LSAME 32802 COMPLEX*16 ZDOTC 32803 EXTERNAL LSAME, ZDOTC 32804 INTRINSIC DBLE, MAX, MIN 32805 INFO = 0 32806 UPPER = LSAME( UPLO, 'U') 32807 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 32808 INFO = -1 32809 ELSE IF( N.LT.0 ) THEN 32810 INFO = -2 32811 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 32812 INFO = -4 32813 END IF 32814 IF( INFO.NE.0 ) THEN 32815 CALL XERBLA( 'ZHETD2', -INFO ) 32816 RETURN 32817 END IF 32818 IF( N.LE.0 ) 32819 $ RETURN 32820 IF( UPPER ) THEN 32821 A( N, N ) = DBLE( A( N, N ) ) 32822 DO 10 I = N - 1, 1, -1 32823 ALPHA = A( I, I+1 ) 32824 CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI ) 32825 E( I ) = ALPHA 32826 IF( TAUI.NE.ZERO ) THEN 32827 A( I, I+1 ) = ONE 32828 CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, 32829 $ TAU, 1 ) 32830 ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 ) 32831 CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) 32832 CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, 32833 $ LDA ) 32834 ELSE 32835 A( I, I ) = DBLE( A( I, I ) ) 32836 END IF 32837 A( I, I+1 ) = E( I ) 32838 D( I+1 ) = A( I+1, I+1 ) 32839 TAU( I ) = TAUI 32840 10 CONTINUE 32841 D( 1 ) = A( 1, 1 ) 32842 ELSE 32843 A( 1, 1 ) = DBLE( A( 1, 1 ) ) 32844 DO 20 I = 1, N - 1 32845 ALPHA = A( I+1, I ) 32846 CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI ) 32847 E( I ) = ALPHA 32848 IF( TAUI.NE.ZERO ) THEN 32849 A( I+1, I ) = ONE 32850 CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, 32851 $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) 32852 ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ), 32853 $ 1 ) 32854 CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) 32855 CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, 32856 $ A( I+1, I+1 ), LDA ) 32857 ELSE 32858 A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) ) 32859 END IF 32860 A( I+1, I ) = E( I ) 32861 D( I ) = A( I, I ) 32862 TAU( I ) = TAUI 32863 20 CONTINUE 32864 D( N ) = A( N, N ) 32865 END IF 32866 RETURN 32867 END 32868! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhetf2.f 32869 SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) 32870 CHARACTER UPLO 32871 INTEGER INFO, LDA, N 32872 INTEGER IPIV( * ) 32873 COMPLEX*16 A( LDA, * ) 32874 DOUBLE PRECISION ZERO, ONE 32875 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 32876 DOUBLE PRECISION EIGHT, SEVTEN 32877 PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) 32878 LOGICAL UPPER 32879 INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP 32880 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, ROWMAX, 32881 $ TT 32882 COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, ZDUM 32883 LOGICAL LSAME, DISNAN 32884 INTEGER IZAMAX 32885 DOUBLE PRECISION DLAPY2 32886 EXTERNAL LSAME, IZAMAX, DLAPY2, DISNAN 32887 EXTERNAL XERBLA, ZDSCAL, ZHER, ZSWAP 32888 INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT 32889 DOUBLE PRECISION CABS1 32890 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 32891 INFO = 0 32892 UPPER = LSAME( UPLO, 'U' ) 32893 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 32894 INFO = -1 32895 ELSE IF( N.LT.0 ) THEN 32896 INFO = -2 32897 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 32898 INFO = -4 32899 END IF 32900 IF( INFO.NE.0 ) THEN 32901 CALL XERBLA( 'ZHETF2', -INFO ) 32902 RETURN 32903 END IF 32904 ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT 32905 IF( UPPER ) THEN 32906 K = N 32907 10 CONTINUE 32908 IF( K.LT.1 ) 32909 $ GO TO 90 32910 KSTEP = 1 32911 ABSAKK = ABS( DBLE( A( K, K ) ) ) 32912 IF( K.GT.1 ) THEN 32913 IMAX = IZAMAX( K-1, A( 1, K ), 1 ) 32914 COLMAX = CABS1( A( IMAX, K ) ) 32915 ELSE 32916 COLMAX = ZERO 32917 END IF 32918 IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN 32919 IF( INFO.EQ.0 ) 32920 $ INFO = K 32921 KP = K 32922 A( K, K ) = DBLE( A( K, K ) ) 32923 ELSE 32924 IF( ABSAKK.GE.ALPHA*COLMAX ) THEN 32925 KP = K 32926 ELSE 32927 JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA ) 32928 ROWMAX = CABS1( A( IMAX, JMAX ) ) 32929 IF( IMAX.GT.1 ) THEN 32930 JMAX = IZAMAX( IMAX-1, A( 1, IMAX ), 1 ) 32931 ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) ) 32932 END IF 32933 IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN 32934 KP = K 32935 ELSE IF( ABS( DBLE( A( IMAX, IMAX ) ) ).GE.ALPHA*ROWMAX ) 32936 $ THEN 32937 KP = IMAX 32938 ELSE 32939 KP = IMAX 32940 KSTEP = 2 32941 END IF 32942 END IF 32943 KK = K - KSTEP + 1 32944 IF( KP.NE.KK ) THEN 32945 CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) 32946 DO 20 J = KP + 1, KK - 1 32947 T = DCONJG( A( J, KK ) ) 32948 A( J, KK ) = DCONJG( A( KP, J ) ) 32949 A( KP, J ) = T 32950 20 CONTINUE 32951 A( KP, KK ) = DCONJG( A( KP, KK ) ) 32952 R1 = DBLE( A( KK, KK ) ) 32953 A( KK, KK ) = DBLE( A( KP, KP ) ) 32954 A( KP, KP ) = R1 32955 IF( KSTEP.EQ.2 ) THEN 32956 A( K, K ) = DBLE( A( K, K ) ) 32957 T = A( K-1, K ) 32958 A( K-1, K ) = A( KP, K ) 32959 A( KP, K ) = T 32960 END IF 32961 ELSE 32962 A( K, K ) = DBLE( A( K, K ) ) 32963 IF( KSTEP.EQ.2 ) 32964 $ A( K-1, K-1 ) = DBLE( A( K-1, K-1 ) ) 32965 END IF 32966 IF( KSTEP.EQ.1 ) THEN 32967 R1 = ONE / DBLE( A( K, K ) ) 32968 CALL ZHER( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA ) 32969 CALL ZDSCAL( K-1, R1, A( 1, K ), 1 ) 32970 ELSE 32971 IF( K.GT.2 ) THEN 32972 D = DLAPY2( DBLE( A( K-1, K ) ), 32973 $ DIMAG( A( K-1, K ) ) ) 32974 D22 = DBLE( A( K-1, K-1 ) ) / D 32975 D11 = DBLE( A( K, K ) ) / D 32976 TT = ONE / ( D11*D22-ONE ) 32977 D12 = A( K-1, K ) / D 32978 D = TT / D 32979 DO 40 J = K - 2, 1, -1 32980 WKM1 = D*( D11*A( J, K-1 )-DCONJG( D12 )* 32981 $ A( J, K ) ) 32982 WK = D*( D22*A( J, K )-D12*A( J, K-1 ) ) 32983 DO 30 I = J, 1, -1 32984 A( I, J ) = A( I, J ) - A( I, K )*DCONJG( WK ) - 32985 $ A( I, K-1 )*DCONJG( WKM1 ) 32986 30 CONTINUE 32987 A( J, K ) = WK 32988 A( J, K-1 ) = WKM1 32989 A( J, J ) = DCMPLX( DBLE( A( J, J ) ), 0.0D+0 ) 32990 40 CONTINUE 32991 END IF 32992 END IF 32993 END IF 32994 IF( KSTEP.EQ.1 ) THEN 32995 IPIV( K ) = KP 32996 ELSE 32997 IPIV( K ) = -KP 32998 IPIV( K-1 ) = -KP 32999 END IF 33000 K = K - KSTEP 33001 GO TO 10 33002 ELSE 33003 K = 1 33004 50 CONTINUE 33005 IF( K.GT.N ) 33006 $ GO TO 90 33007 KSTEP = 1 33008 ABSAKK = ABS( DBLE( A( K, K ) ) ) 33009 IF( K.LT.N ) THEN 33010 IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 ) 33011 COLMAX = CABS1( A( IMAX, K ) ) 33012 ELSE 33013 COLMAX = ZERO 33014 END IF 33015 IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN 33016 IF( INFO.EQ.0 ) 33017 $ INFO = K 33018 KP = K 33019 A( K, K ) = DBLE( A( K, K ) ) 33020 ELSE 33021 IF( ABSAKK.GE.ALPHA*COLMAX ) THEN 33022 KP = K 33023 ELSE 33024 JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA ) 33025 ROWMAX = CABS1( A( IMAX, JMAX ) ) 33026 IF( IMAX.LT.N ) THEN 33027 JMAX = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) 33028 ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) ) 33029 END IF 33030 IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN 33031 KP = K 33032 ELSE IF( ABS( DBLE( A( IMAX, IMAX ) ) ).GE.ALPHA*ROWMAX ) 33033 $ THEN 33034 KP = IMAX 33035 ELSE 33036 KP = IMAX 33037 KSTEP = 2 33038 END IF 33039 END IF 33040 KK = K + KSTEP - 1 33041 IF( KP.NE.KK ) THEN 33042 IF( KP.LT.N ) 33043 $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) 33044 DO 60 J = KK + 1, KP - 1 33045 T = DCONJG( A( J, KK ) ) 33046 A( J, KK ) = DCONJG( A( KP, J ) ) 33047 A( KP, J ) = T 33048 60 CONTINUE 33049 A( KP, KK ) = DCONJG( A( KP, KK ) ) 33050 R1 = DBLE( A( KK, KK ) ) 33051 A( KK, KK ) = DBLE( A( KP, KP ) ) 33052 A( KP, KP ) = R1 33053 IF( KSTEP.EQ.2 ) THEN 33054 A( K, K ) = DBLE( A( K, K ) ) 33055 T = A( K+1, K ) 33056 A( K+1, K ) = A( KP, K ) 33057 A( KP, K ) = T 33058 END IF 33059 ELSE 33060 A( K, K ) = DBLE( A( K, K ) ) 33061 IF( KSTEP.EQ.2 ) 33062 $ A( K+1, K+1 ) = DBLE( A( K+1, K+1 ) ) 33063 END IF 33064 IF( KSTEP.EQ.1 ) THEN 33065 IF( K.LT.N ) THEN 33066 R1 = ONE / DBLE( A( K, K ) ) 33067 CALL ZHER( UPLO, N-K, -R1, A( K+1, K ), 1, 33068 $ A( K+1, K+1 ), LDA ) 33069 CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 ) 33070 END IF 33071 ELSE 33072 IF( K.LT.N-1 ) THEN 33073 D = DLAPY2( DBLE( A( K+1, K ) ), 33074 $ DIMAG( A( K+1, K ) ) ) 33075 D11 = DBLE( A( K+1, K+1 ) ) / D 33076 D22 = DBLE( A( K, K ) ) / D 33077 TT = ONE / ( D11*D22-ONE ) 33078 D21 = A( K+1, K ) / D 33079 D = TT / D 33080 DO 80 J = K + 2, N 33081 WK = D*( D11*A( J, K )-D21*A( J, K+1 ) ) 33082 WKP1 = D*( D22*A( J, K+1 )-DCONJG( D21 )* 33083 $ A( J, K ) ) 33084 DO 70 I = J, N 33085 A( I, J ) = A( I, J ) - A( I, K )*DCONJG( WK ) - 33086 $ A( I, K+1 )*DCONJG( WKP1 ) 33087 70 CONTINUE 33088 A( J, K ) = WK 33089 A( J, K+1 ) = WKP1 33090 A( J, J ) = DCMPLX( DBLE( A( J, J ) ), 0.0D+0 ) 33091 80 CONTINUE 33092 END IF 33093 END IF 33094 END IF 33095 IF( KSTEP.EQ.1 ) THEN 33096 IPIV( K ) = KP 33097 ELSE 33098 IPIV( K ) = -KP 33099 IPIV( K+1 ) = -KP 33100 END IF 33101 K = K + KSTEP 33102 GO TO 50 33103 END IF 33104 90 CONTINUE 33105 RETURN 33106 END 33107! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhetrd.f 33108 SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) 33109 CHARACTER UPLO 33110 INTEGER INFO, LDA, LWORK, N 33111 DOUBLE PRECISION D( * ), E( * ) 33112 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 33113 DOUBLE PRECISION ONE 33114 PARAMETER ( ONE = 1.0D+0 ) 33115 COMPLEX*16 CONE 33116 PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) 33117 LOGICAL LQUERY, UPPER 33118 INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, 33119 $ NBMIN, NX 33120 EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD 33121 INTRINSIC MAX 33122 LOGICAL LSAME 33123 INTEGER ILAENV 33124 EXTERNAL LSAME, ILAENV 33125 INFO = 0 33126 UPPER = LSAME( UPLO, 'U' ) 33127 LQUERY = ( LWORK.EQ.-1 ) 33128 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 33129 INFO = -1 33130 ELSE IF( N.LT.0 ) THEN 33131 INFO = -2 33132 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 33133 INFO = -4 33134 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN 33135 INFO = -9 33136 END IF 33137 IF( INFO.EQ.0 ) THEN 33138 NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) 33139 LWKOPT = N*NB 33140 WORK( 1 ) = LWKOPT 33141 END IF 33142 IF( INFO.NE.0 ) THEN 33143 CALL XERBLA( 'ZHETRD', -INFO ) 33144 RETURN 33145 ELSE IF( LQUERY ) THEN 33146 RETURN 33147 END IF 33148 IF( N.EQ.0 ) THEN 33149 WORK( 1 ) = 1 33150 RETURN 33151 END IF 33152 NX = N 33153 IWS = 1 33154 IF( NB.GT.1 .AND. NB.LT.N ) THEN 33155 NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) ) 33156 IF( NX.LT.N ) THEN 33157 LDWORK = N 33158 IWS = LDWORK*NB 33159 IF( LWORK.LT.IWS ) THEN 33160 NB = MAX( LWORK / LDWORK, 1 ) 33161 NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 ) 33162 IF( NB.LT.NBMIN ) 33163 $ NX = N 33164 END IF 33165 ELSE 33166 NX = N 33167 END IF 33168 ELSE 33169 NB = 1 33170 END IF 33171 IF( UPPER ) THEN 33172 KK = N - ( ( N-NX+NB-1 ) / NB )*NB 33173 DO 20 I = N - NB + 1, KK + 1, -NB 33174 CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, 33175 $ LDWORK ) 33176 CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE, 33177 $ A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA ) 33178 DO 10 J = I, I + NB - 1 33179 A( J-1, J ) = E( J-1 ) 33180 D( J ) = A( J, J ) 33181 10 CONTINUE 33182 20 CONTINUE 33183 CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) 33184 ELSE 33185 DO 40 I = 1, N - NX, NB 33186 CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), 33187 $ TAU( I ), WORK, LDWORK ) 33188 CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE, 33189 $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, 33190 $ A( I+NB, I+NB ), LDA ) 33191 DO 30 J = I, I + NB - 1 33192 A( J+1, J ) = E( J ) 33193 D( J ) = A( J, J ) 33194 30 CONTINUE 33195 40 CONTINUE 33196 CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), 33197 $ TAU( I ), IINFO ) 33198 END IF 33199 WORK( 1 ) = LWKOPT 33200 RETURN 33201 END 33202! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhetrd_2stage.f 33203 SUBROUTINE ZHETRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, 33204 $ HOUS2, LHOUS2, WORK, LWORK, INFO ) 33205 IMPLICIT NONE 33206 CHARACTER VECT, UPLO 33207 INTEGER N, LDA, LWORK, LHOUS2, INFO 33208 DOUBLE PRECISION D( * ), E( * ) 33209 COMPLEX*16 A( LDA, * ), TAU( * ), 33210 $ HOUS2( * ), WORK( * ) 33211 LOGICAL LQUERY, UPPER, WANTQ 33212 INTEGER KD, IB, LWMIN, LHMIN, LWRK, LDAB, WPOS, ABPOS 33213 EXTERNAL XERBLA, ZHETRD_HE2HB, ZHETRD_HB2ST 33214 LOGICAL LSAME 33215 INTEGER ILAENV2STAGE 33216 EXTERNAL LSAME, ILAENV2STAGE 33217 INFO = 0 33218 WANTQ = LSAME( VECT, 'V' ) 33219 UPPER = LSAME( UPLO, 'U' ) 33220 LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS2.EQ.-1 ) 33221 KD = ILAENV2STAGE( 1, 'ZHETRD_2STAGE', VECT, N, -1, -1, -1 ) 33222 IB = ILAENV2STAGE( 2, 'ZHETRD_2STAGE', VECT, N, KD, -1, -1 ) 33223 LHMIN = ILAENV2STAGE( 3, 'ZHETRD_2STAGE', VECT, N, KD, IB, -1 ) 33224 LWMIN = ILAENV2STAGE( 4, 'ZHETRD_2STAGE', VECT, N, KD, IB, -1 ) 33225 IF( .NOT.LSAME( VECT, 'N' ) ) THEN 33226 INFO = -1 33227 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 33228 INFO = -2 33229 ELSE IF( N.LT.0 ) THEN 33230 INFO = -3 33231 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 33232 INFO = -5 33233 ELSE IF( LHOUS2.LT.LHMIN .AND. .NOT.LQUERY ) THEN 33234 INFO = -10 33235 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 33236 INFO = -12 33237 END IF 33238 IF( INFO.EQ.0 ) THEN 33239 HOUS2( 1 ) = LHMIN 33240 WORK( 1 ) = LWMIN 33241 END IF 33242 IF( INFO.NE.0 ) THEN 33243 CALL XERBLA( 'ZHETRD_2STAGE', -INFO ) 33244 RETURN 33245 ELSE IF( LQUERY ) THEN 33246 RETURN 33247 END IF 33248 IF( N.EQ.0 ) THEN 33249 WORK( 1 ) = 1 33250 RETURN 33251 END IF 33252 LDAB = KD+1 33253 LWRK = LWORK-LDAB*N 33254 ABPOS = 1 33255 WPOS = ABPOS + LDAB*N 33256 CALL ZHETRD_HE2HB( UPLO, N, KD, A, LDA, WORK( ABPOS ), LDAB, 33257 $ TAU, WORK( WPOS ), LWRK, INFO ) 33258 IF( INFO.NE.0 ) THEN 33259 CALL XERBLA( 'ZHETRD_HE2HB', -INFO ) 33260 RETURN 33261 END IF 33262 CALL ZHETRD_HB2ST( 'Y', VECT, UPLO, N, KD, 33263 $ WORK( ABPOS ), LDAB, D, E, 33264 $ HOUS2, LHOUS2, WORK( WPOS ), LWRK, INFO ) 33265 IF( INFO.NE.0 ) THEN 33266 CALL XERBLA( 'ZHETRD_HB2ST', -INFO ) 33267 RETURN 33268 END IF 33269 HOUS2( 1 ) = LHMIN 33270 WORK( 1 ) = LWMIN 33271 RETURN 33272 END 33273! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhetrd_hb2st.F 33274 SUBROUTINE ZHETRD_HB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, 33275 $ D, E, HOUS, LHOUS, WORK, LWORK, INFO ) 33276#if defined(_OPENMP) 33277 use omp_lib 33278#endif 33279 IMPLICIT NONE 33280 CHARACTER STAGE1, UPLO, VECT 33281 INTEGER N, KD, LDAB, LHOUS, LWORK, INFO 33282 DOUBLE PRECISION D( * ), E( * ) 33283 COMPLEX*16 AB( LDAB, * ), HOUS( * ), WORK( * ) 33284 DOUBLE PRECISION RZERO 33285 COMPLEX*16 ZERO, ONE 33286 PARAMETER ( RZERO = 0.0D+0, 33287 $ ZERO = ( 0.0D+0, 0.0D+0 ), 33288 $ ONE = ( 1.0D+0, 0.0D+0 ) ) 33289 LOGICAL LQUERY, WANTQ, UPPER, AFTERS1 33290 INTEGER I, M, K, IB, SWEEPID, MYID, SHIFT, STT, ST, 33291 $ ED, STIND, EDIND, BLKLASTIND, COLPT, THED, 33292 $ STEPERCOL, GRSIZ, THGRSIZ, THGRNB, THGRID, 33293 $ NBTILES, TTYPE, TID, NTHREADS, DEBUG, 33294 $ ABDPOS, ABOFDPOS, DPOS, OFDPOS, AWPOS, 33295 $ INDA, INDW, APOS, SIZEA, LDA, INDV, INDTAU, 33296 $ SIZEV, SIZETAU, LDV, LHMIN, LWMIN 33297 DOUBLE PRECISION ABSTMP 33298 COMPLEX*16 TMP 33299 EXTERNAL ZHB2ST_KERNELS, ZLACPY, ZLASET, XERBLA 33300 INTRINSIC MIN, MAX, CEILING, DBLE, REAL 33301 LOGICAL LSAME 33302 INTEGER ILAENV2STAGE 33303 EXTERNAL LSAME, ILAENV2STAGE 33304 DEBUG = 0 33305 INFO = 0 33306 AFTERS1 = LSAME( STAGE1, 'Y' ) 33307 WANTQ = LSAME( VECT, 'V' ) 33308 UPPER = LSAME( UPLO, 'U' ) 33309 LQUERY = ( LWORK.EQ.-1 ) .OR. ( LHOUS.EQ.-1 ) 33310 IB = ILAENV2STAGE( 2, 'ZHETRD_HB2ST', VECT, N, KD, -1, -1 ) 33311 LHMIN = ILAENV2STAGE( 3, 'ZHETRD_HB2ST', VECT, N, KD, IB, -1 ) 33312 LWMIN = ILAENV2STAGE( 4, 'ZHETRD_HB2ST', VECT, N, KD, IB, -1 ) 33313 IF( .NOT.AFTERS1 .AND. .NOT.LSAME( STAGE1, 'N' ) ) THEN 33314 INFO = -1 33315 ELSE IF( .NOT.LSAME( VECT, 'N' ) ) THEN 33316 INFO = -2 33317 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 33318 INFO = -3 33319 ELSE IF( N.LT.0 ) THEN 33320 INFO = -4 33321 ELSE IF( KD.LT.0 ) THEN 33322 INFO = -5 33323 ELSE IF( LDAB.LT.(KD+1) ) THEN 33324 INFO = -7 33325 ELSE IF( LHOUS.LT.LHMIN .AND. .NOT.LQUERY ) THEN 33326 INFO = -11 33327 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 33328 INFO = -13 33329 END IF 33330 IF( INFO.EQ.0 ) THEN 33331 HOUS( 1 ) = LHMIN 33332 WORK( 1 ) = LWMIN 33333 END IF 33334 IF( INFO.NE.0 ) THEN 33335 CALL XERBLA( 'ZHETRD_HB2ST', -INFO ) 33336 RETURN 33337 ELSE IF( LQUERY ) THEN 33338 RETURN 33339 END IF 33340 IF( N.EQ.0 ) THEN 33341 HOUS( 1 ) = 1 33342 WORK( 1 ) = 1 33343 RETURN 33344 END IF 33345 LDV = KD + IB 33346 SIZETAU = 2 * N 33347 SIZEV = 2 * N 33348 INDTAU = 1 33349 INDV = INDTAU + SIZETAU 33350 LDA = 2 * KD + 1 33351 SIZEA = LDA * N 33352 INDA = 1 33353 INDW = INDA + SIZEA 33354 NTHREADS = 1 33355 TID = 0 33356 IF( UPPER ) THEN 33357 APOS = INDA + KD 33358 AWPOS = INDA 33359 DPOS = APOS + KD 33360 OFDPOS = DPOS - 1 33361 ABDPOS = KD + 1 33362 ABOFDPOS = KD 33363 ELSE 33364 APOS = INDA 33365 AWPOS = INDA + KD + 1 33366 DPOS = APOS 33367 OFDPOS = DPOS + 1 33368 ABDPOS = 1 33369 ABOFDPOS = 2 33370 ENDIF 33371 IF( KD.EQ.0 ) THEN 33372 DO 30 I = 1, N 33373 D( I ) = DBLE( AB( ABDPOS, I ) ) 33374 30 CONTINUE 33375 DO 40 I = 1, N-1 33376 E( I ) = RZERO 33377 40 CONTINUE 33378 HOUS( 1 ) = 1 33379 WORK( 1 ) = 1 33380 RETURN 33381 END IF 33382 IF( KD.EQ.1 ) THEN 33383 DO 50 I = 1, N 33384 D( I ) = DBLE( AB( ABDPOS, I ) ) 33385 50 CONTINUE 33386 IF( UPPER ) THEN 33387 DO 60 I = 1, N - 1 33388 TMP = AB( ABOFDPOS, I+1 ) 33389 ABSTMP = ABS( TMP ) 33390 AB( ABOFDPOS, I+1 ) = ABSTMP 33391 E( I ) = ABSTMP 33392 IF( ABSTMP.NE.RZERO ) THEN 33393 TMP = TMP / ABSTMP 33394 ELSE 33395 TMP = ONE 33396 END IF 33397 IF( I.LT.N-1 ) 33398 $ AB( ABOFDPOS, I+2 ) = AB( ABOFDPOS, I+2 )*TMP 33399 60 CONTINUE 33400 ELSE 33401 DO 70 I = 1, N - 1 33402 TMP = AB( ABOFDPOS, I ) 33403 ABSTMP = ABS( TMP ) 33404 AB( ABOFDPOS, I ) = ABSTMP 33405 E( I ) = ABSTMP 33406 IF( ABSTMP.NE.RZERO ) THEN 33407 TMP = TMP / ABSTMP 33408 ELSE 33409 TMP = ONE 33410 END IF 33411 IF( I.LT.N-1 ) 33412 $ AB( ABOFDPOS, I+1 ) = AB( ABOFDPOS, I+1 )*TMP 33413 70 CONTINUE 33414 ENDIF 33415 HOUS( 1 ) = 1 33416 WORK( 1 ) = 1 33417 RETURN 33418 END IF 33419 THGRSIZ = N 33420 GRSIZ = 1 33421 SHIFT = 3 33422 NBTILES = CEILING( REAL(N)/REAL(KD) ) 33423 STEPERCOL = CEILING( REAL(SHIFT)/REAL(GRSIZ) ) 33424 THGRNB = CEILING( REAL(N-1)/REAL(THGRSIZ) ) 33425 CALL ZLACPY( "A", KD+1, N, AB, LDAB, WORK( APOS ), LDA ) 33426 CALL ZLASET( "A", KD, N, ZERO, ZERO, WORK( AWPOS ), LDA ) 33427#if defined(_OPENMP) 33428#endif 33429 DO 100 THGRID = 1, THGRNB 33430 STT = (THGRID-1)*THGRSIZ+1 33431 THED = MIN( (STT + THGRSIZ -1), (N-1)) 33432 DO 110 I = STT, N-1 33433 ED = MIN( I, THED ) 33434 IF( STT.GT.ED ) EXIT 33435 DO 120 M = 1, STEPERCOL 33436 ST = STT 33437 DO 130 SWEEPID = ST, ED 33438 DO 140 K = 1, GRSIZ 33439 MYID = (I-SWEEPID)*(STEPERCOL*GRSIZ) 33440 $ + (M-1)*GRSIZ + K 33441 IF ( MYID.EQ.1 ) THEN 33442 TTYPE = 1 33443 ELSE 33444 TTYPE = MOD( MYID, 2 ) + 2 33445 ENDIF 33446 IF( TTYPE.EQ.2 ) THEN 33447 COLPT = (MYID/2)*KD + SWEEPID 33448 STIND = COLPT-KD+1 33449 EDIND = MIN(COLPT,N) 33450 BLKLASTIND = COLPT 33451 ELSE 33452 COLPT = ((MYID+1)/2)*KD + SWEEPID 33453 STIND = COLPT-KD+1 33454 EDIND = MIN(COLPT,N) 33455 IF( ( STIND.GE.EDIND-1 ).AND. 33456 $ ( EDIND.EQ.N ) ) THEN 33457 BLKLASTIND = N 33458 ELSE 33459 BLKLASTIND = 0 33460 ENDIF 33461 ENDIF 33462#if defined(_OPENMP) 33463 IF( TTYPE.NE.1 ) THEN 33464 TID = OMP_GET_THREAD_NUM() 33465 CALL ZHB2ST_KERNELS( UPLO, WANTQ, TTYPE, 33466 $ STIND, EDIND, SWEEPID, N, KD, IB, 33467 $ WORK ( INDA ), LDA, 33468 $ HOUS( INDV ), HOUS( INDTAU ), LDV, 33469 $ WORK( INDW + TID*KD ) ) 33470 ELSE 33471 TID = OMP_GET_THREAD_NUM() 33472 CALL ZHB2ST_KERNELS( UPLO, WANTQ, TTYPE, 33473 $ STIND, EDIND, SWEEPID, N, KD, IB, 33474 $ WORK ( INDA ), LDA, 33475 $ HOUS( INDV ), HOUS( INDTAU ), LDV, 33476 $ WORK( INDW + TID*KD ) ) 33477 ENDIF 33478#else 33479 CALL ZHB2ST_KERNELS( UPLO, WANTQ, TTYPE, 33480 $ STIND, EDIND, SWEEPID, N, KD, IB, 33481 $ WORK ( INDA ), LDA, 33482 $ HOUS( INDV ), HOUS( INDTAU ), LDV, 33483 $ WORK( INDW + TID*KD ) ) 33484#endif 33485 IF ( BLKLASTIND.GE.(N-1) ) THEN 33486 STT = STT + 1 33487 EXIT 33488 ENDIF 33489 140 CONTINUE 33490 130 CONTINUE 33491 120 CONTINUE 33492 110 CONTINUE 33493 100 CONTINUE 33494#if defined(_OPENMP) 33495#endif 33496 DO 150 I = 1, N 33497 D( I ) = DBLE( WORK( DPOS+(I-1)*LDA ) ) 33498 150 CONTINUE 33499 IF( UPPER ) THEN 33500 DO 160 I = 1, N-1 33501 E( I ) = DBLE( WORK( OFDPOS+I*LDA ) ) 33502 160 CONTINUE 33503 ELSE 33504 DO 170 I = 1, N-1 33505 E( I ) = DBLE( WORK( OFDPOS+(I-1)*LDA ) ) 33506 170 CONTINUE 33507 ENDIF 33508 HOUS( 1 ) = LHMIN 33509 WORK( 1 ) = LWMIN 33510 RETURN 33511 END 33512 33513! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhetrd_he2hb.f 33514 SUBROUTINE ZHETRD_HE2HB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, 33515 $ WORK, LWORK, INFO ) 33516 IMPLICIT NONE 33517 CHARACTER UPLO 33518 INTEGER INFO, LDA, LDAB, LWORK, N, KD 33519 COMPLEX*16 A( LDA, * ), AB( LDAB, * ), 33520 $ TAU( * ), WORK( * ) 33521 DOUBLE PRECISION RONE 33522 COMPLEX*16 ZERO, ONE, HALF 33523 PARAMETER ( RONE = 1.0D+0, 33524 $ ZERO = ( 0.0D+0, 0.0D+0 ), 33525 $ ONE = ( 1.0D+0, 0.0D+0 ), 33526 $ HALF = ( 0.5D+0, 0.0D+0 ) ) 33527 LOGICAL LQUERY, UPPER 33528 INTEGER I, J, IINFO, LWMIN, PN, PK, LK, 33529 $ LDT, LDW, LDS2, LDS1, 33530 $ LS2, LS1, LW, LT, 33531 $ TPOS, WPOS, S2POS, S1POS 33532 EXTERNAL XERBLA, ZHER2K, ZHEMM, ZGEMM, ZCOPY, 33533 $ ZLARFT, ZGELQF, ZGEQRF, ZLASET 33534 INTRINSIC MIN, MAX 33535 LOGICAL LSAME 33536 INTEGER ILAENV2STAGE 33537 EXTERNAL LSAME, ILAENV2STAGE 33538 INFO = 0 33539 UPPER = LSAME( UPLO, 'U' ) 33540 LQUERY = ( LWORK.EQ.-1 ) 33541 LWMIN = ILAENV2STAGE( 4, 'ZHETRD_HE2HB', '', N, KD, -1, -1 ) 33542 33543 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 33544 INFO = -1 33545 ELSE IF( N.LT.0 ) THEN 33546 INFO = -2 33547 ELSE IF( KD.LT.0 ) THEN 33548 INFO = -3 33549 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 33550 INFO = -5 33551 ELSE IF( LDAB.LT.MAX( 1, KD+1 ) ) THEN 33552 INFO = -7 33553 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 33554 INFO = -10 33555 END IF 33556 IF( INFO.NE.0 ) THEN 33557 CALL XERBLA( 'ZHETRD_HE2HB', -INFO ) 33558 RETURN 33559 ELSE IF( LQUERY ) THEN 33560 WORK( 1 ) = LWMIN 33561 RETURN 33562 END IF 33563 IF( N.LE.KD+1 ) THEN 33564 IF( UPPER ) THEN 33565 DO 100 I = 1, N 33566 LK = MIN( KD+1, I ) 33567 CALL ZCOPY( LK, A( I-LK+1, I ), 1, 33568 $ AB( KD+1-LK+1, I ), 1 ) 33569 100 CONTINUE 33570 ELSE 33571 DO 110 I = 1, N 33572 LK = MIN( KD+1, N-I+1 ) 33573 CALL ZCOPY( LK, A( I, I ), 1, AB( 1, I ), 1 ) 33574 110 CONTINUE 33575 ENDIF 33576 WORK( 1 ) = 1 33577 RETURN 33578 END IF 33579 LDT = KD 33580 LDS1 = KD 33581 LT = LDT*KD 33582 LW = N*KD 33583 LS1 = LDS1*KD 33584 LS2 = LWMIN - LT - LW - LS1 33585 TPOS = 1 33586 WPOS = TPOS + LT 33587 S1POS = WPOS + LW 33588 S2POS = S1POS + LS1 33589 IF( UPPER ) THEN 33590 LDW = KD 33591 LDS2 = KD 33592 ELSE 33593 LDW = N 33594 LDS2 = N 33595 ENDIF 33596 CALL ZLASET( "A", LDT, KD, ZERO, ZERO, WORK( TPOS ), LDT ) 33597 IF( UPPER ) THEN 33598 DO 10 I = 1, N - KD, KD 33599 PN = N-I-KD+1 33600 PK = MIN( N-I-KD+1, KD ) 33601 CALL ZGELQF( KD, PN, A( I, I+KD ), LDA, 33602 $ TAU( I ), WORK( S2POS ), LS2, IINFO ) 33603 DO 20 J = I, I+PK-1 33604 LK = MIN( KD, N-J ) + 1 33605 CALL ZCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) 33606 20 CONTINUE 33607 CALL ZLASET( 'Lower', PK, PK, ZERO, ONE, 33608 $ A( I, I+KD ), LDA ) 33609 CALL ZLARFT( 'Forward', 'Rowwise', PN, PK, 33610 $ A( I, I+KD ), LDA, TAU( I ), 33611 $ WORK( TPOS ), LDT ) 33612 CALL ZGEMM( 'Conjugate', 'No transpose', PK, PN, PK, 33613 $ ONE, WORK( TPOS ), LDT, 33614 $ A( I, I+KD ), LDA, 33615 $ ZERO, WORK( S2POS ), LDS2 ) 33616 CALL ZHEMM( 'Right', UPLO, PK, PN, 33617 $ ONE, A( I+KD, I+KD ), LDA, 33618 $ WORK( S2POS ), LDS2, 33619 $ ZERO, WORK( WPOS ), LDW ) 33620 CALL ZGEMM( 'No transpose', 'Conjugate', PK, PK, PN, 33621 $ ONE, WORK( WPOS ), LDW, 33622 $ WORK( S2POS ), LDS2, 33623 $ ZERO, WORK( S1POS ), LDS1 ) 33624 CALL ZGEMM( 'No transpose', 'No transpose', PK, PN, PK, 33625 $ -HALF, WORK( S1POS ), LDS1, 33626 $ A( I, I+KD ), LDA, 33627 $ ONE, WORK( WPOS ), LDW ) 33628 CALL ZHER2K( UPLO, 'Conjugate', PN, PK, 33629 $ -ONE, A( I, I+KD ), LDA, 33630 $ WORK( WPOS ), LDW, 33631 $ RONE, A( I+KD, I+KD ), LDA ) 33632 10 CONTINUE 33633 DO 30 J = N-KD+1, N 33634 LK = MIN(KD, N-J) + 1 33635 CALL ZCOPY( LK, A( J, J ), LDA, AB( KD+1, J ), LDAB-1 ) 33636 30 CONTINUE 33637 ELSE 33638 DO 40 I = 1, N - KD, KD 33639 PN = N-I-KD+1 33640 PK = MIN( N-I-KD+1, KD ) 33641 CALL ZGEQRF( PN, KD, A( I+KD, I ), LDA, 33642 $ TAU( I ), WORK( S2POS ), LS2, IINFO ) 33643 DO 50 J = I, I+PK-1 33644 LK = MIN( KD, N-J ) + 1 33645 CALL ZCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) 33646 50 CONTINUE 33647 CALL ZLASET( 'Upper', PK, PK, ZERO, ONE, 33648 $ A( I+KD, I ), LDA ) 33649 CALL ZLARFT( 'Forward', 'Columnwise', PN, PK, 33650 $ A( I+KD, I ), LDA, TAU( I ), 33651 $ WORK( TPOS ), LDT ) 33652 CALL ZGEMM( 'No transpose', 'No transpose', PN, PK, PK, 33653 $ ONE, A( I+KD, I ), LDA, 33654 $ WORK( TPOS ), LDT, 33655 $ ZERO, WORK( S2POS ), LDS2 ) 33656 CALL ZHEMM( 'Left', UPLO, PN, PK, 33657 $ ONE, A( I+KD, I+KD ), LDA, 33658 $ WORK( S2POS ), LDS2, 33659 $ ZERO, WORK( WPOS ), LDW ) 33660 CALL ZGEMM( 'Conjugate', 'No transpose', PK, PK, PN, 33661 $ ONE, WORK( S2POS ), LDS2, 33662 $ WORK( WPOS ), LDW, 33663 $ ZERO, WORK( S1POS ), LDS1 ) 33664 CALL ZGEMM( 'No transpose', 'No transpose', PN, PK, PK, 33665 $ -HALF, A( I+KD, I ), LDA, 33666 $ WORK( S1POS ), LDS1, 33667 $ ONE, WORK( WPOS ), LDW ) 33668 CALL ZHER2K( UPLO, 'No transpose', PN, PK, 33669 $ -ONE, A( I+KD, I ), LDA, 33670 $ WORK( WPOS ), LDW, 33671 $ RONE, A( I+KD, I+KD ), LDA ) 33672 40 CONTINUE 33673 DO 60 J = N-KD+1, N 33674 LK = MIN(KD, N-J) + 1 33675 CALL ZCOPY( LK, A( J, J ), 1, AB( 1, J ), 1 ) 33676 60 CONTINUE 33677 END IF 33678 WORK( 1 ) = LWMIN 33679 RETURN 33680 END 33681! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhetrf.f 33682 SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) 33683 CHARACTER UPLO 33684 INTEGER INFO, LDA, LWORK, N 33685 INTEGER IPIV( * ) 33686 COMPLEX*16 A( LDA, * ), WORK( * ) 33687 LOGICAL LQUERY, UPPER 33688 INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN 33689 LOGICAL LSAME 33690 INTEGER ILAENV 33691 EXTERNAL LSAME, ILAENV 33692 EXTERNAL XERBLA, ZHETF2, ZLAHEF 33693 INTRINSIC MAX 33694 INFO = 0 33695 UPPER = LSAME( UPLO, 'U' ) 33696 LQUERY = ( LWORK.EQ.-1 ) 33697 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 33698 INFO = -1 33699 ELSE IF( N.LT.0 ) THEN 33700 INFO = -2 33701 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 33702 INFO = -4 33703 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN 33704 INFO = -7 33705 END IF 33706 IF( INFO.EQ.0 ) THEN 33707 NB = ILAENV( 1, 'ZHETRF', UPLO, N, -1, -1, -1 ) 33708 LWKOPT = N*NB 33709 WORK( 1 ) = LWKOPT 33710 END IF 33711 IF( INFO.NE.0 ) THEN 33712 CALL XERBLA( 'ZHETRF', -INFO ) 33713 RETURN 33714 ELSE IF( LQUERY ) THEN 33715 RETURN 33716 END IF 33717 NBMIN = 2 33718 LDWORK = N 33719 IF( NB.GT.1 .AND. NB.LT.N ) THEN 33720 IWS = LDWORK*NB 33721 IF( LWORK.LT.IWS ) THEN 33722 NB = MAX( LWORK / LDWORK, 1 ) 33723 NBMIN = MAX( 2, ILAENV( 2, 'ZHETRF', UPLO, N, -1, -1, -1 ) ) 33724 END IF 33725 ELSE 33726 IWS = 1 33727 END IF 33728 IF( NB.LT.NBMIN ) 33729 $ NB = N 33730 IF( UPPER ) THEN 33731 K = N 33732 10 CONTINUE 33733 IF( K.LT.1 ) 33734 $ GO TO 40 33735 IF( K.GT.NB ) THEN 33736 CALL ZLAHEF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, N, IINFO ) 33737 ELSE 33738 CALL ZHETF2( UPLO, K, A, LDA, IPIV, IINFO ) 33739 KB = K 33740 END IF 33741 IF( INFO.EQ.0 .AND. IINFO.GT.0 ) 33742 $ INFO = IINFO 33743 K = K - KB 33744 GO TO 10 33745 ELSE 33746 K = 1 33747 20 CONTINUE 33748 IF( K.GT.N ) 33749 $ GO TO 40 33750 IF( K.LE.N-NB ) THEN 33751 CALL ZLAHEF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ), 33752 $ WORK, N, IINFO ) 33753 ELSE 33754 CALL ZHETF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO ) 33755 KB = N - K + 1 33756 END IF 33757 IF( INFO.EQ.0 .AND. IINFO.GT.0 ) 33758 $ INFO = IINFO + K - 1 33759 DO 30 J = K, K + KB - 1 33760 IF( IPIV( J ).GT.0 ) THEN 33761 IPIV( J ) = IPIV( J ) + K - 1 33762 ELSE 33763 IPIV( J ) = IPIV( J ) - K + 1 33764 END IF 33765 30 CONTINUE 33766 K = K + KB 33767 GO TO 20 33768 END IF 33769 40 CONTINUE 33770 WORK( 1 ) = LWKOPT 33771 RETURN 33772 END 33773! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhetri.f 33774 SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) 33775 CHARACTER UPLO 33776 INTEGER INFO, LDA, N 33777 INTEGER IPIV( * ) 33778 COMPLEX*16 A( LDA, * ), WORK( * ) 33779 DOUBLE PRECISION ONE 33780 COMPLEX*16 CONE, ZERO 33781 PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ), 33782 $ ZERO = ( 0.0D+0, 0.0D+0 ) ) 33783 LOGICAL UPPER 33784 INTEGER J, K, KP, KSTEP 33785 DOUBLE PRECISION AK, AKP1, D, T 33786 COMPLEX*16 AKKP1, TEMP 33787 LOGICAL LSAME 33788 COMPLEX*16 ZDOTC 33789 EXTERNAL LSAME, ZDOTC 33790 EXTERNAL XERBLA, ZCOPY, ZHEMV, ZSWAP 33791 INTRINSIC ABS, DBLE, DCONJG, MAX 33792 INFO = 0 33793 UPPER = LSAME( UPLO, 'U' ) 33794 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 33795 INFO = -1 33796 ELSE IF( N.LT.0 ) THEN 33797 INFO = -2 33798 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 33799 INFO = -4 33800 END IF 33801 IF( INFO.NE.0 ) THEN 33802 CALL XERBLA( 'ZHETRI', -INFO ) 33803 RETURN 33804 END IF 33805 IF( N.EQ.0 ) 33806 $ RETURN 33807 IF( UPPER ) THEN 33808 DO 10 INFO = N, 1, -1 33809 IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) 33810 $ RETURN 33811 10 CONTINUE 33812 ELSE 33813 DO 20 INFO = 1, N 33814 IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) 33815 $ RETURN 33816 20 CONTINUE 33817 END IF 33818 INFO = 0 33819 IF( UPPER ) THEN 33820 K = 1 33821 30 CONTINUE 33822 IF( K.GT.N ) 33823 $ GO TO 50 33824 IF( IPIV( K ).GT.0 ) THEN 33825 A( K, K ) = ONE / DBLE( A( K, K ) ) 33826 IF( K.GT.1 ) THEN 33827 CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 ) 33828 CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO, 33829 $ A( 1, K ), 1 ) 33830 A( K, K ) = A( K, K ) - DBLE( ZDOTC( K-1, WORK, 1, A( 1, 33831 $ K ), 1 ) ) 33832 END IF 33833 KSTEP = 1 33834 ELSE 33835 T = ABS( A( K, K+1 ) ) 33836 AK = DBLE( A( K, K ) ) / T 33837 AKP1 = DBLE( A( K+1, K+1 ) ) / T 33838 AKKP1 = A( K, K+1 ) / T 33839 D = T*( AK*AKP1-ONE ) 33840 A( K, K ) = AKP1 / D 33841 A( K+1, K+1 ) = AK / D 33842 A( K, K+1 ) = -AKKP1 / D 33843 IF( K.GT.1 ) THEN 33844 CALL ZCOPY( K-1, A( 1, K ), 1, WORK, 1 ) 33845 CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO, 33846 $ A( 1, K ), 1 ) 33847 A( K, K ) = A( K, K ) - DBLE( ZDOTC( K-1, WORK, 1, A( 1, 33848 $ K ), 1 ) ) 33849 A( K, K+1 ) = A( K, K+1 ) - 33850 $ ZDOTC( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) 33851 CALL ZCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) 33852 CALL ZHEMV( UPLO, K-1, -CONE, A, LDA, WORK, 1, ZERO, 33853 $ A( 1, K+1 ), 1 ) 33854 A( K+1, K+1 ) = A( K+1, K+1 ) - 33855 $ DBLE( ZDOTC( K-1, WORK, 1, A( 1, K+1 ), 33856 $ 1 ) ) 33857 END IF 33858 KSTEP = 2 33859 END IF 33860 KP = ABS( IPIV( K ) ) 33861 IF( KP.NE.K ) THEN 33862 CALL ZSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) 33863 DO 40 J = KP + 1, K - 1 33864 TEMP = DCONJG( A( J, K ) ) 33865 A( J, K ) = DCONJG( A( KP, J ) ) 33866 A( KP, J ) = TEMP 33867 40 CONTINUE 33868 A( KP, K ) = DCONJG( A( KP, K ) ) 33869 TEMP = A( K, K ) 33870 A( K, K ) = A( KP, KP ) 33871 A( KP, KP ) = TEMP 33872 IF( KSTEP.EQ.2 ) THEN 33873 TEMP = A( K, K+1 ) 33874 A( K, K+1 ) = A( KP, K+1 ) 33875 A( KP, K+1 ) = TEMP 33876 END IF 33877 END IF 33878 K = K + KSTEP 33879 GO TO 30 33880 50 CONTINUE 33881 ELSE 33882 K = N 33883 60 CONTINUE 33884 IF( K.LT.1 ) 33885 $ GO TO 80 33886 IF( IPIV( K ).GT.0 ) THEN 33887 A( K, K ) = ONE / DBLE( A( K, K ) ) 33888 IF( K.LT.N ) THEN 33889 CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) 33890 CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK, 33891 $ 1, ZERO, A( K+1, K ), 1 ) 33892 A( K, K ) = A( K, K ) - DBLE( ZDOTC( N-K, WORK, 1, 33893 $ A( K+1, K ), 1 ) ) 33894 END IF 33895 KSTEP = 1 33896 ELSE 33897 T = ABS( A( K, K-1 ) ) 33898 AK = DBLE( A( K-1, K-1 ) ) / T 33899 AKP1 = DBLE( A( K, K ) ) / T 33900 AKKP1 = A( K, K-1 ) / T 33901 D = T*( AK*AKP1-ONE ) 33902 A( K-1, K-1 ) = AKP1 / D 33903 A( K, K ) = AK / D 33904 A( K, K-1 ) = -AKKP1 / D 33905 IF( K.LT.N ) THEN 33906 CALL ZCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) 33907 CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK, 33908 $ 1, ZERO, A( K+1, K ), 1 ) 33909 A( K, K ) = A( K, K ) - DBLE( ZDOTC( N-K, WORK, 1, 33910 $ A( K+1, K ), 1 ) ) 33911 A( K, K-1 ) = A( K, K-1 ) - 33912 $ ZDOTC( N-K, A( K+1, K ), 1, A( K+1, K-1 ), 33913 $ 1 ) 33914 CALL ZCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) 33915 CALL ZHEMV( UPLO, N-K, -CONE, A( K+1, K+1 ), LDA, WORK, 33916 $ 1, ZERO, A( K+1, K-1 ), 1 ) 33917 A( K-1, K-1 ) = A( K-1, K-1 ) - 33918 $ DBLE( ZDOTC( N-K, WORK, 1, A( K+1, K-1 ), 33919 $ 1 ) ) 33920 END IF 33921 KSTEP = 2 33922 END IF 33923 KP = ABS( IPIV( K ) ) 33924 IF( KP.NE.K ) THEN 33925 IF( KP.LT.N ) 33926 $ CALL ZSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) 33927 DO 70 J = K + 1, KP - 1 33928 TEMP = DCONJG( A( J, K ) ) 33929 A( J, K ) = DCONJG( A( KP, J ) ) 33930 A( KP, J ) = TEMP 33931 70 CONTINUE 33932 A( KP, K ) = DCONJG( A( KP, K ) ) 33933 TEMP = A( K, K ) 33934 A( K, K ) = A( KP, KP ) 33935 A( KP, KP ) = TEMP 33936 IF( KSTEP.EQ.2 ) THEN 33937 TEMP = A( K, K-1 ) 33938 A( K, K-1 ) = A( KP, K-1 ) 33939 A( KP, K-1 ) = TEMP 33940 END IF 33941 END IF 33942 K = K - KSTEP 33943 GO TO 60 33944 80 CONTINUE 33945 END IF 33946 RETURN 33947 END 33948! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhetrs.f 33949 SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 33950 CHARACTER UPLO 33951 INTEGER INFO, LDA, LDB, N, NRHS 33952 INTEGER IPIV( * ) 33953 COMPLEX*16 A( LDA, * ), B( LDB, * ) 33954 COMPLEX*16 ONE 33955 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 33956 LOGICAL UPPER 33957 INTEGER J, K, KP 33958 DOUBLE PRECISION S 33959 COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM 33960 LOGICAL LSAME 33961 EXTERNAL LSAME 33962 EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZGERU, ZLACGV, ZSWAP 33963 INTRINSIC DBLE, DCONJG, MAX 33964 INFO = 0 33965 UPPER = LSAME( UPLO, 'U' ) 33966 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 33967 INFO = -1 33968 ELSE IF( N.LT.0 ) THEN 33969 INFO = -2 33970 ELSE IF( NRHS.LT.0 ) THEN 33971 INFO = -3 33972 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 33973 INFO = -5 33974 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 33975 INFO = -8 33976 END IF 33977 IF( INFO.NE.0 ) THEN 33978 CALL XERBLA( 'ZHETRS', -INFO ) 33979 RETURN 33980 END IF 33981 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 33982 $ RETURN 33983 IF( UPPER ) THEN 33984 K = N 33985 10 CONTINUE 33986 IF( K.LT.1 ) 33987 $ GO TO 30 33988 IF( IPIV( K ).GT.0 ) THEN 33989 KP = IPIV( K ) 33990 IF( KP.NE.K ) 33991 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 33992 CALL ZGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 33993 $ B( 1, 1 ), LDB ) 33994 S = DBLE( ONE ) / DBLE( A( K, K ) ) 33995 CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB ) 33996 K = K - 1 33997 ELSE 33998 KP = -IPIV( K ) 33999 IF( KP.NE.K-1 ) 34000 $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) 34001 CALL ZGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 34002 $ B( 1, 1 ), LDB ) 34003 CALL ZGERU( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), 34004 $ LDB, B( 1, 1 ), LDB ) 34005 AKM1K = A( K-1, K ) 34006 AKM1 = A( K-1, K-1 ) / AKM1K 34007 AK = A( K, K ) / DCONJG( AKM1K ) 34008 DENOM = AKM1*AK - ONE 34009 DO 20 J = 1, NRHS 34010 BKM1 = B( K-1, J ) / AKM1K 34011 BK = B( K, J ) / DCONJG( AKM1K ) 34012 B( K-1, J ) = ( AK*BKM1-BK ) / DENOM 34013 B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM 34014 20 CONTINUE 34015 K = K - 2 34016 END IF 34017 GO TO 10 34018 30 CONTINUE 34019 K = 1 34020 40 CONTINUE 34021 IF( K.GT.N ) 34022 $ GO TO 50 34023 IF( IPIV( K ).GT.0 ) THEN 34024 IF( K.GT.1 ) THEN 34025 CALL ZLACGV( NRHS, B( K, 1 ), LDB ) 34026 CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, 34027 $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) 34028 CALL ZLACGV( NRHS, B( K, 1 ), LDB ) 34029 END IF 34030 KP = IPIV( K ) 34031 IF( KP.NE.K ) 34032 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 34033 K = K + 1 34034 ELSE 34035 IF( K.GT.1 ) THEN 34036 CALL ZLACGV( NRHS, B( K, 1 ), LDB ) 34037 CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, 34038 $ LDB, A( 1, K ), 1, ONE, B( K, 1 ), LDB ) 34039 CALL ZLACGV( NRHS, B( K, 1 ), LDB ) 34040 CALL ZLACGV( NRHS, B( K+1, 1 ), LDB ) 34041 CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, 34042 $ LDB, A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) 34043 CALL ZLACGV( NRHS, B( K+1, 1 ), LDB ) 34044 END IF 34045 KP = -IPIV( K ) 34046 IF( KP.NE.K ) 34047 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 34048 K = K + 2 34049 END IF 34050 GO TO 40 34051 50 CONTINUE 34052 ELSE 34053 K = 1 34054 60 CONTINUE 34055 IF( K.GT.N ) 34056 $ GO TO 80 34057 IF( IPIV( K ).GT.0 ) THEN 34058 KP = IPIV( K ) 34059 IF( KP.NE.K ) 34060 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 34061 IF( K.LT.N ) 34062 $ CALL ZGERU( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), 34063 $ LDB, B( K+1, 1 ), LDB ) 34064 S = DBLE( ONE ) / DBLE( A( K, K ) ) 34065 CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB ) 34066 K = K + 1 34067 ELSE 34068 KP = -IPIV( K ) 34069 IF( KP.NE.K+1 ) 34070 $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) 34071 IF( K.LT.N-1 ) THEN 34072 CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), 34073 $ LDB, B( K+2, 1 ), LDB ) 34074 CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, 34075 $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) 34076 END IF 34077 AKM1K = A( K+1, K ) 34078 AKM1 = A( K, K ) / DCONJG( AKM1K ) 34079 AK = A( K+1, K+1 ) / AKM1K 34080 DENOM = AKM1*AK - ONE 34081 DO 70 J = 1, NRHS 34082 BKM1 = B( K, J ) / DCONJG( AKM1K ) 34083 BK = B( K+1, J ) / AKM1K 34084 B( K, J ) = ( AK*BKM1-BK ) / DENOM 34085 B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM 34086 70 CONTINUE 34087 K = K + 2 34088 END IF 34089 GO TO 60 34090 80 CONTINUE 34091 K = N 34092 90 CONTINUE 34093 IF( K.LT.1 ) 34094 $ GO TO 100 34095 IF( IPIV( K ).GT.0 ) THEN 34096 IF( K.LT.N ) THEN 34097 CALL ZLACGV( NRHS, B( K, 1 ), LDB ) 34098 CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, 34099 $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE, 34100 $ B( K, 1 ), LDB ) 34101 CALL ZLACGV( NRHS, B( K, 1 ), LDB ) 34102 END IF 34103 KP = IPIV( K ) 34104 IF( KP.NE.K ) 34105 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 34106 K = K - 1 34107 ELSE 34108 IF( K.LT.N ) THEN 34109 CALL ZLACGV( NRHS, B( K, 1 ), LDB ) 34110 CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, 34111 $ B( K+1, 1 ), LDB, A( K+1, K ), 1, ONE, 34112 $ B( K, 1 ), LDB ) 34113 CALL ZLACGV( NRHS, B( K, 1 ), LDB ) 34114 CALL ZLACGV( NRHS, B( K-1, 1 ), LDB ) 34115 CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, 34116 $ B( K+1, 1 ), LDB, A( K+1, K-1 ), 1, ONE, 34117 $ B( K-1, 1 ), LDB ) 34118 CALL ZLACGV( NRHS, B( K-1, 1 ), LDB ) 34119 END IF 34120 KP = -IPIV( K ) 34121 IF( KP.NE.K ) 34122 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 34123 K = K - 2 34124 END IF 34125 GO TO 90 34126 100 CONTINUE 34127 END IF 34128 RETURN 34129 END 34130! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhpev.f 34131 SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, 34132 $ INFO ) 34133 CHARACTER JOBZ, UPLO 34134 INTEGER INFO, LDZ, N 34135 DOUBLE PRECISION RWORK( * ), W( * ) 34136 COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * ) 34137 DOUBLE PRECISION ZERO, ONE 34138 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 34139 LOGICAL WANTZ 34140 INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK, 34141 $ ISCALE 34142 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 34143 $ SMLNUM 34144 LOGICAL LSAME 34145 DOUBLE PRECISION DLAMCH, ZLANHP 34146 EXTERNAL LSAME, DLAMCH, ZLANHP 34147 EXTERNAL DSCAL, DSTERF, XERBLA, ZDSCAL, ZHPTRD, ZSTEQR, 34148 $ ZUPGTR 34149 INTRINSIC SQRT 34150 WANTZ = LSAME( JOBZ, 'V' ) 34151 INFO = 0 34152 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 34153 INFO = -1 34154 ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) 34155 $ THEN 34156 INFO = -2 34157 ELSE IF( N.LT.0 ) THEN 34158 INFO = -3 34159 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 34160 INFO = -7 34161 END IF 34162 IF( INFO.NE.0 ) THEN 34163 CALL XERBLA( 'ZHPEV ', -INFO ) 34164 RETURN 34165 END IF 34166 IF( N.EQ.0 ) 34167 $ RETURN 34168 IF( N.EQ.1 ) THEN 34169 W( 1 ) = AP( 1 ) 34170 RWORK( 1 ) = 1 34171 IF( WANTZ ) 34172 $ Z( 1, 1 ) = ONE 34173 RETURN 34174 END IF 34175 SAFMIN = DLAMCH( 'Safe minimum' ) 34176 EPS = DLAMCH( 'Precision' ) 34177 SMLNUM = SAFMIN / EPS 34178 BIGNUM = ONE / SMLNUM 34179 RMIN = SQRT( SMLNUM ) 34180 RMAX = SQRT( BIGNUM ) 34181 ANRM = ZLANHP( 'M', UPLO, N, AP, RWORK ) 34182 ISCALE = 0 34183 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 34184 ISCALE = 1 34185 SIGMA = RMIN / ANRM 34186 ELSE IF( ANRM.GT.RMAX ) THEN 34187 ISCALE = 1 34188 SIGMA = RMAX / ANRM 34189 END IF 34190 IF( ISCALE.EQ.1 ) THEN 34191 CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) 34192 END IF 34193 INDE = 1 34194 INDTAU = 1 34195 CALL ZHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ), 34196 $ IINFO ) 34197 IF( .NOT.WANTZ ) THEN 34198 CALL DSTERF( N, W, RWORK( INDE ), INFO ) 34199 ELSE 34200 INDWRK = INDTAU + N 34201 CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, 34202 $ WORK( INDWRK ), IINFO ) 34203 INDRWK = INDE + N 34204 CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ, 34205 $ RWORK( INDRWK ), INFO ) 34206 END IF 34207 IF( ISCALE.EQ.1 ) THEN 34208 IF( INFO.EQ.0 ) THEN 34209 IMAX = N 34210 ELSE 34211 IMAX = INFO - 1 34212 END IF 34213 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 34214 END IF 34215 RETURN 34216 END 34217! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhpevd.f 34218 SUBROUTINE ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, 34219 $ RWORK, LRWORK, IWORK, LIWORK, INFO ) 34220 CHARACTER JOBZ, UPLO 34221 INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N 34222 INTEGER IWORK( * ) 34223 DOUBLE PRECISION RWORK( * ), W( * ) 34224 COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * ) 34225 DOUBLE PRECISION ZERO, ONE 34226 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 34227 COMPLEX*16 CONE 34228 PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) 34229 LOGICAL LQUERY, WANTZ 34230 INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK, 34231 $ ISCALE, LIWMIN, LLRWK, LLWRK, LRWMIN, LWMIN 34232 DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, 34233 $ SMLNUM 34234 LOGICAL LSAME 34235 DOUBLE PRECISION DLAMCH, ZLANHP 34236 EXTERNAL LSAME, DLAMCH, ZLANHP 34237 EXTERNAL DSCAL, DSTERF, XERBLA, ZDSCAL, ZHPTRD, ZSTEDC, 34238 $ ZUPMTR 34239 INTRINSIC SQRT 34240 WANTZ = LSAME( JOBZ, 'V' ) 34241 LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 34242 INFO = 0 34243 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 34244 INFO = -1 34245 ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) 34246 $ THEN 34247 INFO = -2 34248 ELSE IF( N.LT.0 ) THEN 34249 INFO = -3 34250 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 34251 INFO = -7 34252 END IF 34253 IF( INFO.EQ.0 ) THEN 34254 IF( N.LE.1 ) THEN 34255 LWMIN = 1 34256 LIWMIN = 1 34257 LRWMIN = 1 34258 ELSE 34259 IF( WANTZ ) THEN 34260 LWMIN = 2*N 34261 LRWMIN = 1 + 5*N + 2*N**2 34262 LIWMIN = 3 + 5*N 34263 ELSE 34264 LWMIN = N 34265 LRWMIN = N 34266 LIWMIN = 1 34267 END IF 34268 END IF 34269 WORK( 1 ) = LWMIN 34270 RWORK( 1 ) = LRWMIN 34271 IWORK( 1 ) = LIWMIN 34272 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 34273 INFO = -9 34274 ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN 34275 INFO = -11 34276 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 34277 INFO = -13 34278 END IF 34279 END IF 34280 IF( INFO.NE.0 ) THEN 34281 CALL XERBLA( 'ZHPEVD', -INFO ) 34282 RETURN 34283 ELSE IF( LQUERY ) THEN 34284 RETURN 34285 END IF 34286 IF( N.EQ.0 ) 34287 $ RETURN 34288 IF( N.EQ.1 ) THEN 34289 W( 1 ) = AP( 1 ) 34290 IF( WANTZ ) 34291 $ Z( 1, 1 ) = CONE 34292 RETURN 34293 END IF 34294 SAFMIN = DLAMCH( 'Safe minimum' ) 34295 EPS = DLAMCH( 'Precision' ) 34296 SMLNUM = SAFMIN / EPS 34297 BIGNUM = ONE / SMLNUM 34298 RMIN = SQRT( SMLNUM ) 34299 RMAX = SQRT( BIGNUM ) 34300 ANRM = ZLANHP( 'M', UPLO, N, AP, RWORK ) 34301 ISCALE = 0 34302 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN 34303 ISCALE = 1 34304 SIGMA = RMIN / ANRM 34305 ELSE IF( ANRM.GT.RMAX ) THEN 34306 ISCALE = 1 34307 SIGMA = RMAX / ANRM 34308 END IF 34309 IF( ISCALE.EQ.1 ) THEN 34310 CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) 34311 END IF 34312 INDE = 1 34313 INDTAU = 1 34314 INDRWK = INDE + N 34315 INDWRK = INDTAU + N 34316 LLWRK = LWORK - INDWRK + 1 34317 LLRWK = LRWORK - INDRWK + 1 34318 CALL ZHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ), 34319 $ IINFO ) 34320 IF( .NOT.WANTZ ) THEN 34321 CALL DSTERF( N, W, RWORK( INDE ), INFO ) 34322 ELSE 34323 CALL ZSTEDC( 'I', N, W, RWORK( INDE ), Z, LDZ, WORK( INDWRK ), 34324 $ LLWRK, RWORK( INDRWK ), LLRWK, IWORK, LIWORK, 34325 $ INFO ) 34326 CALL ZUPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ, 34327 $ WORK( INDWRK ), IINFO ) 34328 END IF 34329 IF( ISCALE.EQ.1 ) THEN 34330 IF( INFO.EQ.0 ) THEN 34331 IMAX = N 34332 ELSE 34333 IMAX = INFO - 1 34334 END IF 34335 CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) 34336 END IF 34337 WORK( 1 ) = LWMIN 34338 RWORK( 1 ) = LRWMIN 34339 IWORK( 1 ) = LIWMIN 34340 RETURN 34341 END 34342! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhpgst.f 34343 SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, INFO ) 34344 CHARACTER UPLO 34345 INTEGER INFO, ITYPE, N 34346 COMPLEX*16 AP( * ), BP( * ) 34347 DOUBLE PRECISION ONE, HALF 34348 PARAMETER ( ONE = 1.0D+0, HALF = 0.5D+0 ) 34349 COMPLEX*16 CONE 34350 PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) 34351 LOGICAL UPPER 34352 INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK 34353 DOUBLE PRECISION AJJ, AKK, BJJ, BKK 34354 COMPLEX*16 CT 34355 EXTERNAL XERBLA, ZAXPY, ZDSCAL, ZHPMV, ZHPR2, ZTPMV, 34356 $ ZTPSV 34357 INTRINSIC DBLE 34358 LOGICAL LSAME 34359 COMPLEX*16 ZDOTC 34360 EXTERNAL LSAME, ZDOTC 34361 INFO = 0 34362 UPPER = LSAME( UPLO, 'U' ) 34363 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN 34364 INFO = -1 34365 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 34366 INFO = -2 34367 ELSE IF( N.LT.0 ) THEN 34368 INFO = -3 34369 END IF 34370 IF( INFO.NE.0 ) THEN 34371 CALL XERBLA( 'ZHPGST', -INFO ) 34372 RETURN 34373 END IF 34374 IF( ITYPE.EQ.1 ) THEN 34375 IF( UPPER ) THEN 34376 JJ = 0 34377 DO 10 J = 1, N 34378 J1 = JJ + 1 34379 JJ = JJ + J 34380 AP( JJ ) = DBLE( AP( JJ ) ) 34381 BJJ = BP( JJ ) 34382 CALL ZTPSV( UPLO, 'Conjugate transpose', 'Non-unit', J, 34383 $ BP, AP( J1 ), 1 ) 34384 CALL ZHPMV( UPLO, J-1, -CONE, AP, BP( J1 ), 1, CONE, 34385 $ AP( J1 ), 1 ) 34386 CALL ZDSCAL( J-1, ONE / BJJ, AP( J1 ), 1 ) 34387 AP( JJ ) = ( AP( JJ )-ZDOTC( J-1, AP( J1 ), 1, BP( J1 ), 34388 $ 1 ) ) / BJJ 34389 10 CONTINUE 34390 ELSE 34391 KK = 1 34392 DO 20 K = 1, N 34393 K1K1 = KK + N - K + 1 34394 AKK = AP( KK ) 34395 BKK = BP( KK ) 34396 AKK = AKK / BKK**2 34397 AP( KK ) = AKK 34398 IF( K.LT.N ) THEN 34399 CALL ZDSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 ) 34400 CT = -HALF*AKK 34401 CALL ZAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 ) 34402 CALL ZHPR2( UPLO, N-K, -CONE, AP( KK+1 ), 1, 34403 $ BP( KK+1 ), 1, AP( K1K1 ) ) 34404 CALL ZAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 ) 34405 CALL ZTPSV( UPLO, 'No transpose', 'Non-unit', N-K, 34406 $ BP( K1K1 ), AP( KK+1 ), 1 ) 34407 END IF 34408 KK = K1K1 34409 20 CONTINUE 34410 END IF 34411 ELSE 34412 IF( UPPER ) THEN 34413 KK = 0 34414 DO 30 K = 1, N 34415 K1 = KK + 1 34416 KK = KK + K 34417 AKK = AP( KK ) 34418 BKK = BP( KK ) 34419 CALL ZTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP, 34420 $ AP( K1 ), 1 ) 34421 CT = HALF*AKK 34422 CALL ZAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 ) 34423 CALL ZHPR2( UPLO, K-1, CONE, AP( K1 ), 1, BP( K1 ), 1, 34424 $ AP ) 34425 CALL ZAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 ) 34426 CALL ZDSCAL( K-1, BKK, AP( K1 ), 1 ) 34427 AP( KK ) = AKK*BKK**2 34428 30 CONTINUE 34429 ELSE 34430 JJ = 1 34431 DO 40 J = 1, N 34432 J1J1 = JJ + N - J + 1 34433 AJJ = AP( JJ ) 34434 BJJ = BP( JJ ) 34435 AP( JJ ) = AJJ*BJJ + ZDOTC( N-J, AP( JJ+1 ), 1, 34436 $ BP( JJ+1 ), 1 ) 34437 CALL ZDSCAL( N-J, BJJ, AP( JJ+1 ), 1 ) 34438 CALL ZHPMV( UPLO, N-J, CONE, AP( J1J1 ), BP( JJ+1 ), 1, 34439 $ CONE, AP( JJ+1 ), 1 ) 34440 CALL ZTPMV( UPLO, 'Conjugate transpose', 'Non-unit', 34441 $ N-J+1, BP( JJ ), AP( JJ ), 1 ) 34442 JJ = J1J1 34443 40 CONTINUE 34444 END IF 34445 END IF 34446 RETURN 34447 END 34448! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhpgv.f 34449 SUBROUTINE ZHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, 34450 $ RWORK, INFO ) 34451 CHARACTER JOBZ, UPLO 34452 INTEGER INFO, ITYPE, LDZ, N 34453 DOUBLE PRECISION RWORK( * ), W( * ) 34454 COMPLEX*16 AP( * ), BP( * ), WORK( * ), Z( LDZ, * ) 34455 LOGICAL UPPER, WANTZ 34456 CHARACTER TRANS 34457 INTEGER J, NEIG 34458 LOGICAL LSAME 34459 EXTERNAL LSAME 34460 EXTERNAL XERBLA, ZHPEV, ZHPGST, ZPPTRF, ZTPMV, ZTPSV 34461 WANTZ = LSAME( JOBZ, 'V' ) 34462 UPPER = LSAME( UPLO, 'U' ) 34463 INFO = 0 34464 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN 34465 INFO = -1 34466 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 34467 INFO = -2 34468 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN 34469 INFO = -3 34470 ELSE IF( N.LT.0 ) THEN 34471 INFO = -4 34472 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 34473 INFO = -9 34474 END IF 34475 IF( INFO.NE.0 ) THEN 34476 CALL XERBLA( 'ZHPGV ', -INFO ) 34477 RETURN 34478 END IF 34479 IF( N.EQ.0 ) 34480 $ RETURN 34481 CALL ZPPTRF( UPLO, N, BP, INFO ) 34482 IF( INFO.NE.0 ) THEN 34483 INFO = N + INFO 34484 RETURN 34485 END IF 34486 CALL ZHPGST( ITYPE, UPLO, N, AP, BP, INFO ) 34487 CALL ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, INFO ) 34488 IF( WANTZ ) THEN 34489 NEIG = N 34490 IF( INFO.GT.0 ) 34491 $ NEIG = INFO - 1 34492 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN 34493 IF( UPPER ) THEN 34494 TRANS = 'N' 34495 ELSE 34496 TRANS = 'C' 34497 END IF 34498 DO 10 J = 1, NEIG 34499 CALL ZTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), 34500 $ 1 ) 34501 10 CONTINUE 34502 ELSE IF( ITYPE.EQ.3 ) THEN 34503 IF( UPPER ) THEN 34504 TRANS = 'C' 34505 ELSE 34506 TRANS = 'N' 34507 END IF 34508 DO 20 J = 1, NEIG 34509 CALL ZTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), 34510 $ 1 ) 34511 20 CONTINUE 34512 END IF 34513 END IF 34514 RETURN 34515 END 34516! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhpgvd.f 34517 SUBROUTINE ZHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, 34518 $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) 34519 CHARACTER JOBZ, UPLO 34520 INTEGER INFO, ITYPE, LDZ, LIWORK, LRWORK, LWORK, N 34521 INTEGER IWORK( * ) 34522 DOUBLE PRECISION RWORK( * ), W( * ) 34523 COMPLEX*16 AP( * ), BP( * ), WORK( * ), Z( LDZ, * ) 34524 LOGICAL LQUERY, UPPER, WANTZ 34525 CHARACTER TRANS 34526 INTEGER J, LIWMIN, LRWMIN, LWMIN, NEIG 34527 LOGICAL LSAME 34528 EXTERNAL LSAME 34529 EXTERNAL XERBLA, ZHPEVD, ZHPGST, ZPPTRF, ZTPMV, ZTPSV 34530 INTRINSIC DBLE, MAX 34531 WANTZ = LSAME( JOBZ, 'V' ) 34532 UPPER = LSAME( UPLO, 'U' ) 34533 LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 34534 INFO = 0 34535 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN 34536 INFO = -1 34537 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 34538 INFO = -2 34539 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN 34540 INFO = -3 34541 ELSE IF( N.LT.0 ) THEN 34542 INFO = -4 34543 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 34544 INFO = -9 34545 END IF 34546 IF( INFO.EQ.0 ) THEN 34547 IF( N.LE.1 ) THEN 34548 LWMIN = 1 34549 LIWMIN = 1 34550 LRWMIN = 1 34551 ELSE 34552 IF( WANTZ ) THEN 34553 LWMIN = 2*N 34554 LRWMIN = 1 + 5*N + 2*N**2 34555 LIWMIN = 3 + 5*N 34556 ELSE 34557 LWMIN = N 34558 LRWMIN = N 34559 LIWMIN = 1 34560 END IF 34561 END IF 34562 WORK( 1 ) = LWMIN 34563 RWORK( 1 ) = LRWMIN 34564 IWORK( 1 ) = LIWMIN 34565 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 34566 INFO = -11 34567 ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN 34568 INFO = -13 34569 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 34570 INFO = -15 34571 END IF 34572 END IF 34573 IF( INFO.NE.0 ) THEN 34574 CALL XERBLA( 'ZHPGVD', -INFO ) 34575 RETURN 34576 ELSE IF( LQUERY ) THEN 34577 RETURN 34578 END IF 34579 IF( N.EQ.0 ) 34580 $ RETURN 34581 CALL ZPPTRF( UPLO, N, BP, INFO ) 34582 IF( INFO.NE.0 ) THEN 34583 INFO = N + INFO 34584 RETURN 34585 END IF 34586 CALL ZHPGST( ITYPE, UPLO, N, AP, BP, INFO ) 34587 CALL ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK, 34588 $ LRWORK, IWORK, LIWORK, INFO ) 34589 LWMIN = MAX( DBLE( LWMIN ), DBLE( WORK( 1 ) ) ) 34590 LRWMIN = MAX( DBLE( LRWMIN ), DBLE( RWORK( 1 ) ) ) 34591 LIWMIN = MAX( DBLE( LIWMIN ), DBLE( IWORK( 1 ) ) ) 34592 IF( WANTZ ) THEN 34593 NEIG = N 34594 IF( INFO.GT.0 ) 34595 $ NEIG = INFO - 1 34596 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN 34597 IF( UPPER ) THEN 34598 TRANS = 'N' 34599 ELSE 34600 TRANS = 'C' 34601 END IF 34602 DO 10 J = 1, NEIG 34603 CALL ZTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), 34604 $ 1 ) 34605 10 CONTINUE 34606 ELSE IF( ITYPE.EQ.3 ) THEN 34607 IF( UPPER ) THEN 34608 TRANS = 'C' 34609 ELSE 34610 TRANS = 'N' 34611 END IF 34612 DO 20 J = 1, NEIG 34613 CALL ZTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ), 34614 $ 1 ) 34615 20 CONTINUE 34616 END IF 34617 END IF 34618 WORK( 1 ) = LWMIN 34619 RWORK( 1 ) = LRWMIN 34620 IWORK( 1 ) = LIWMIN 34621 RETURN 34622 END 34623! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhptrd.f 34624 SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO ) 34625 CHARACTER UPLO 34626 INTEGER INFO, N 34627 DOUBLE PRECISION D( * ), E( * ) 34628 COMPLEX*16 AP( * ), TAU( * ) 34629 COMPLEX*16 ONE, ZERO, HALF 34630 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), 34631 $ ZERO = ( 0.0D+0, 0.0D+0 ), 34632 $ HALF = ( 0.5D+0, 0.0D+0 ) ) 34633 LOGICAL UPPER 34634 INTEGER I, I1, I1I1, II 34635 COMPLEX*16 ALPHA, TAUI 34636 EXTERNAL XERBLA, ZAXPY, ZHPMV, ZHPR2, ZLARFG 34637 LOGICAL LSAME 34638 COMPLEX*16 ZDOTC 34639 EXTERNAL LSAME, ZDOTC 34640 INTRINSIC DBLE 34641 INFO = 0 34642 UPPER = LSAME( UPLO, 'U' ) 34643 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 34644 INFO = -1 34645 ELSE IF( N.LT.0 ) THEN 34646 INFO = -2 34647 END IF 34648 IF( INFO.NE.0 ) THEN 34649 CALL XERBLA( 'ZHPTRD', -INFO ) 34650 RETURN 34651 END IF 34652 IF( N.LE.0 ) 34653 $ RETURN 34654 IF( UPPER ) THEN 34655 I1 = N*( N-1 ) / 2 + 1 34656 AP( I1+N-1 ) = DBLE( AP( I1+N-1 ) ) 34657 DO 10 I = N - 1, 1, -1 34658 ALPHA = AP( I1+I-1 ) 34659 CALL ZLARFG( I, ALPHA, AP( I1 ), 1, TAUI ) 34660 E( I ) = ALPHA 34661 IF( TAUI.NE.ZERO ) THEN 34662 AP( I1+I-1 ) = ONE 34663 CALL ZHPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, 34664 $ 1 ) 34665 ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, AP( I1 ), 1 ) 34666 CALL ZAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 ) 34667 CALL ZHPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP ) 34668 END IF 34669 AP( I1+I-1 ) = E( I ) 34670 D( I+1 ) = AP( I1+I ) 34671 TAU( I ) = TAUI 34672 I1 = I1 - I 34673 10 CONTINUE 34674 D( 1 ) = AP( 1 ) 34675 ELSE 34676 II = 1 34677 AP( 1 ) = DBLE( AP( 1 ) ) 34678 DO 20 I = 1, N - 1 34679 I1I1 = II + N - I + 1 34680 ALPHA = AP( II+1 ) 34681 CALL ZLARFG( N-I, ALPHA, AP( II+2 ), 1, TAUI ) 34682 E( I ) = ALPHA 34683 IF( TAUI.NE.ZERO ) THEN 34684 AP( II+1 ) = ONE 34685 CALL ZHPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1, 34686 $ ZERO, TAU( I ), 1 ) 34687 ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, AP( II+1 ), 34688 $ 1 ) 34689 CALL ZAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 ) 34690 CALL ZHPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1, 34691 $ AP( I1I1 ) ) 34692 END IF 34693 AP( II+1 ) = E( I ) 34694 D( I ) = AP( II ) 34695 TAU( I ) = TAUI 34696 II = I1I1 34697 20 CONTINUE 34698 D( N ) = AP( II ) 34699 END IF 34700 RETURN 34701 END 34702! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zhseqr.f 34703 SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, 34704 $ WORK, LWORK, INFO ) 34705 INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N 34706 CHARACTER COMPZ, JOB 34707 COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) 34708 INTEGER NTINY 34709 PARAMETER ( NTINY = 11 ) 34710 INTEGER NL 34711 PARAMETER ( NL = 49 ) 34712 COMPLEX*16 ZERO, ONE 34713 PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), 34714 $ ONE = ( 1.0d0, 0.0d0 ) ) 34715 DOUBLE PRECISION RZERO 34716 PARAMETER ( RZERO = 0.0d0 ) 34717 COMPLEX*16 HL( NL, NL ), WORKL( NL ) 34718 INTEGER KBOT, NMIN 34719 LOGICAL INITZ, LQUERY, WANTT, WANTZ 34720 INTEGER ILAENV 34721 LOGICAL LSAME 34722 EXTERNAL ILAENV, LSAME 34723 EXTERNAL XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET 34724 INTRINSIC DBLE, DCMPLX, MAX, MIN 34725 WANTT = LSAME( JOB, 'S' ) 34726 INITZ = LSAME( COMPZ, 'I' ) 34727 WANTZ = INITZ .OR. LSAME( COMPZ, 'V' ) 34728 WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO ) 34729 LQUERY = LWORK.EQ.-1 34730 INFO = 0 34731 IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN 34732 INFO = -1 34733 ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN 34734 INFO = -2 34735 ELSE IF( N.LT.0 ) THEN 34736 INFO = -3 34737 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN 34738 INFO = -4 34739 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN 34740 INFO = -5 34741 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN 34742 INFO = -7 34743 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN 34744 INFO = -10 34745 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 34746 INFO = -12 34747 END IF 34748 IF( INFO.NE.0 ) THEN 34749 CALL XERBLA( 'ZHSEQR', -INFO ) 34750 RETURN 34751 ELSE IF( N.EQ.0 ) THEN 34752 RETURN 34753 ELSE IF( LQUERY ) THEN 34754 CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z, 34755 $ LDZ, WORK, LWORK, INFO ) 34756 WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1, 34757 $ N ) ) ), RZERO ) 34758 RETURN 34759 ELSE 34760 IF( ILO.GT.1 ) 34761 $ CALL ZCOPY( ILO-1, H, LDH+1, W, 1 ) 34762 IF( IHI.LT.N ) 34763 $ CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 ) 34764 IF( INITZ ) 34765 $ CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ ) 34766 IF( ILO.EQ.IHI ) THEN 34767 W( ILO ) = H( ILO, ILO ) 34768 RETURN 34769 END IF 34770 NMIN = ILAENV( 12, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, 34771 $ ILO, IHI, LWORK ) 34772 NMIN = MAX( NTINY, NMIN ) 34773 IF( N.GT.NMIN ) THEN 34774 CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, 34775 $ Z, LDZ, WORK, LWORK, INFO ) 34776 ELSE 34777 CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, 34778 $ Z, LDZ, INFO ) 34779 IF( INFO.GT.0 ) THEN 34780 KBOT = INFO 34781 IF( N.GE.NL ) THEN 34782 CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W, 34783 $ ILO, IHI, Z, LDZ, WORK, LWORK, INFO ) 34784 ELSE 34785 CALL ZLACPY( 'A', N, N, H, LDH, HL, NL ) 34786 HL( N+1, N ) = ZERO 34787 CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ), 34788 $ NL ) 34789 CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W, 34790 $ ILO, IHI, Z, LDZ, WORKL, NL, INFO ) 34791 IF( WANTT .OR. INFO.NE.0 ) 34792 $ CALL ZLACPY( 'A', N, N, HL, NL, H, LDH ) 34793 END IF 34794 END IF 34795 END IF 34796 IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 ) 34797 $ CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH ) 34798 WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ), 34799 $ DBLE( WORK( 1 ) ) ), RZERO ) 34800 END IF 34801 END 34802! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_gbrcond_c.f 34803 DOUBLE PRECISION FUNCTION ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, 34804 $ LDAB, AFB, LDAFB, IPIV, 34805 $ C, CAPPLY, INFO, WORK, 34806 $ RWORK ) 34807 CHARACTER TRANS 34808 LOGICAL CAPPLY 34809 INTEGER N, KL, KU, KD, KE, LDAB, LDAFB, INFO 34810 INTEGER IPIV( * ) 34811 COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ) 34812 DOUBLE PRECISION C( * ), RWORK( * ) 34813 LOGICAL NOTRANS 34814 INTEGER KASE, I, J 34815 DOUBLE PRECISION AINVNM, ANORM, TMP 34816 COMPLEX*16 ZDUM 34817 INTEGER ISAVE( 3 ) 34818 LOGICAL LSAME 34819 EXTERNAL LSAME 34820 EXTERNAL ZLACN2, ZGBTRS, XERBLA 34821 INTRINSIC ABS, MAX 34822 DOUBLE PRECISION CABS1 34823 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 34824 ZLA_GBRCOND_C = 0.0D+0 34825 INFO = 0 34826 NOTRANS = LSAME( TRANS, 'N' ) 34827 IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. 34828 $ LSAME( TRANS, 'C' ) ) THEN 34829 INFO = -1 34830 ELSE IF( N.LT.0 ) THEN 34831 INFO = -2 34832 ELSE IF( KL.LT.0 .OR. KL.GT.N-1 ) THEN 34833 INFO = -3 34834 ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN 34835 INFO = -4 34836 ELSE IF( LDAB.LT.KL+KU+1 ) THEN 34837 INFO = -6 34838 ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN 34839 INFO = -8 34840 END IF 34841 IF( INFO.NE.0 ) THEN 34842 CALL XERBLA( 'ZLA_GBRCOND_C', -INFO ) 34843 RETURN 34844 END IF 34845 ANORM = 0.0D+0 34846 KD = KU + 1 34847 KE = KL + 1 34848 IF ( NOTRANS ) THEN 34849 DO I = 1, N 34850 TMP = 0.0D+0 34851 IF ( CAPPLY ) THEN 34852 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 34853 TMP = TMP + CABS1( AB( KD+I-J, J ) ) / C( J ) 34854 END DO 34855 ELSE 34856 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 34857 TMP = TMP + CABS1( AB( KD+I-J, J ) ) 34858 END DO 34859 END IF 34860 RWORK( I ) = TMP 34861 ANORM = MAX( ANORM, TMP ) 34862 END DO 34863 ELSE 34864 DO I = 1, N 34865 TMP = 0.0D+0 34866 IF ( CAPPLY ) THEN 34867 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 34868 TMP = TMP + CABS1( AB( KE-I+J, I ) ) / C( J ) 34869 END DO 34870 ELSE 34871 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 34872 TMP = TMP + CABS1( AB( KE-I+J, I ) ) 34873 END DO 34874 END IF 34875 RWORK( I ) = TMP 34876 ANORM = MAX( ANORM, TMP ) 34877 END DO 34878 END IF 34879 IF( N.EQ.0 ) THEN 34880 ZLA_GBRCOND_C = 1.0D+0 34881 RETURN 34882 ELSE IF( ANORM .EQ. 0.0D+0 ) THEN 34883 RETURN 34884 END IF 34885 AINVNM = 0.0D+0 34886 KASE = 0 34887 10 CONTINUE 34888 CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 34889 IF( KASE.NE.0 ) THEN 34890 IF( KASE.EQ.2 ) THEN 34891 DO I = 1, N 34892 WORK( I ) = WORK( I ) * RWORK( I ) 34893 END DO 34894 IF ( NOTRANS ) THEN 34895 CALL ZGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 34896 $ IPIV, WORK, N, INFO ) 34897 ELSE 34898 CALL ZGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, 34899 $ LDAFB, IPIV, WORK, N, INFO ) 34900 ENDIF 34901 IF ( CAPPLY ) THEN 34902 DO I = 1, N 34903 WORK( I ) = WORK( I ) * C( I ) 34904 END DO 34905 END IF 34906 ELSE 34907 IF ( CAPPLY ) THEN 34908 DO I = 1, N 34909 WORK( I ) = WORK( I ) * C( I ) 34910 END DO 34911 END IF 34912 IF ( NOTRANS ) THEN 34913 CALL ZGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, 34914 $ LDAFB, IPIV, WORK, N, INFO ) 34915 ELSE 34916 CALL ZGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 34917 $ IPIV, WORK, N, INFO ) 34918 END IF 34919 DO I = 1, N 34920 WORK( I ) = WORK( I ) * RWORK( I ) 34921 END DO 34922 END IF 34923 GO TO 10 34924 END IF 34925 IF( AINVNM .NE. 0.0D+0 ) 34926 $ ZLA_GBRCOND_C = 1.0D+0 / AINVNM 34927 RETURN 34928 END 34929! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_gbrcond_x.f 34930 DOUBLE PRECISION FUNCTION ZLA_GBRCOND_X( TRANS, N, KL, KU, AB, 34931 $ LDAB, AFB, LDAFB, IPIV, 34932 $ X, INFO, WORK, RWORK ) 34933 CHARACTER TRANS 34934 INTEGER N, KL, KU, KD, KE, LDAB, LDAFB, INFO 34935 INTEGER IPIV( * ) 34936 COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), 34937 $ X( * ) 34938 DOUBLE PRECISION RWORK( * ) 34939 LOGICAL NOTRANS 34940 INTEGER KASE, I, J 34941 DOUBLE PRECISION AINVNM, ANORM, TMP 34942 COMPLEX*16 ZDUM 34943 INTEGER ISAVE( 3 ) 34944 LOGICAL LSAME 34945 EXTERNAL LSAME 34946 EXTERNAL ZLACN2, ZGBTRS, XERBLA 34947 INTRINSIC ABS, MAX 34948 DOUBLE PRECISION CABS1 34949 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 34950 ZLA_GBRCOND_X = 0.0D+0 34951 INFO = 0 34952 NOTRANS = LSAME( TRANS, 'N' ) 34953 IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') .AND. .NOT. 34954 $ LSAME( TRANS, 'C' ) ) THEN 34955 INFO = -1 34956 ELSE IF( N.LT.0 ) THEN 34957 INFO = -2 34958 ELSE IF( KL.LT.0 .OR. KL.GT.N-1 ) THEN 34959 INFO = -3 34960 ELSE IF( KU.LT.0 .OR. KU.GT.N-1 ) THEN 34961 INFO = -4 34962 ELSE IF( LDAB.LT.KL+KU+1 ) THEN 34963 INFO = -6 34964 ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN 34965 INFO = -8 34966 END IF 34967 IF( INFO.NE.0 ) THEN 34968 CALL XERBLA( 'ZLA_GBRCOND_X', -INFO ) 34969 RETURN 34970 END IF 34971 KD = KU + 1 34972 KE = KL + 1 34973 ANORM = 0.0D+0 34974 IF ( NOTRANS ) THEN 34975 DO I = 1, N 34976 TMP = 0.0D+0 34977 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 34978 TMP = TMP + CABS1( AB( KD+I-J, J) * X( J ) ) 34979 END DO 34980 RWORK( I ) = TMP 34981 ANORM = MAX( ANORM, TMP ) 34982 END DO 34983 ELSE 34984 DO I = 1, N 34985 TMP = 0.0D+0 34986 DO J = MAX( I-KL, 1 ), MIN( I+KU, N ) 34987 TMP = TMP + CABS1( AB( KE-I+J, I ) * X( J ) ) 34988 END DO 34989 RWORK( I ) = TMP 34990 ANORM = MAX( ANORM, TMP ) 34991 END DO 34992 END IF 34993 IF( N.EQ.0 ) THEN 34994 ZLA_GBRCOND_X = 1.0D+0 34995 RETURN 34996 ELSE IF( ANORM .EQ. 0.0D+0 ) THEN 34997 RETURN 34998 END IF 34999 AINVNM = 0.0D+0 35000 KASE = 0 35001 10 CONTINUE 35002 CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 35003 IF( KASE.NE.0 ) THEN 35004 IF( KASE.EQ.2 ) THEN 35005 DO I = 1, N 35006 WORK( I ) = WORK( I ) * RWORK( I ) 35007 END DO 35008 IF ( NOTRANS ) THEN 35009 CALL ZGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 35010 $ IPIV, WORK, N, INFO ) 35011 ELSE 35012 CALL ZGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, 35013 $ LDAFB, IPIV, WORK, N, INFO ) 35014 ENDIF 35015 DO I = 1, N 35016 WORK( I ) = WORK( I ) / X( I ) 35017 END DO 35018 ELSE 35019 DO I = 1, N 35020 WORK( I ) = WORK( I ) / X( I ) 35021 END DO 35022 IF ( NOTRANS ) THEN 35023 CALL ZGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, 35024 $ LDAFB, IPIV, WORK, N, INFO ) 35025 ELSE 35026 CALL ZGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, 35027 $ IPIV, WORK, N, INFO ) 35028 END IF 35029 DO I = 1, N 35030 WORK( I ) = WORK( I ) * RWORK( I ) 35031 END DO 35032 END IF 35033 GO TO 10 35034 END IF 35035 IF( AINVNM .NE. 0.0D+0 ) 35036 $ ZLA_GBRCOND_X = 1.0D+0 / AINVNM 35037 RETURN 35038 END 35039! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_gbrpvgrw.f 35040 DOUBLE PRECISION FUNCTION ZLA_GBRPVGRW( N, KL, KU, NCOLS, AB, 35041 $ LDAB, AFB, LDAFB ) 35042 INTEGER N, KL, KU, NCOLS, LDAB, LDAFB 35043 COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ) 35044 INTEGER I, J, KD 35045 DOUBLE PRECISION AMAX, UMAX, RPVGRW 35046 COMPLEX*16 ZDUM 35047 INTRINSIC ABS, MAX, MIN, REAL, DIMAG 35048 DOUBLE PRECISION CABS1 35049 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 35050 RPVGRW = 1.0D+0 35051 KD = KU + 1 35052 DO J = 1, NCOLS 35053 AMAX = 0.0D+0 35054 UMAX = 0.0D+0 35055 DO I = MAX( J-KU, 1 ), MIN( J+KL, N ) 35056 AMAX = MAX( CABS1( AB( KD+I-J, J ) ), AMAX ) 35057 END DO 35058 DO I = MAX( J-KU, 1 ), J 35059 UMAX = MAX( CABS1( AFB( KD+I-J, J ) ), UMAX ) 35060 END DO 35061 IF ( UMAX /= 0.0D+0 ) THEN 35062 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 35063 END IF 35064 END DO 35065 ZLA_GBRPVGRW = RPVGRW 35066 END 35067! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_gercond_c.f 35068 DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF, 35069 $ LDAF, IPIV, C, CAPPLY, 35070 $ INFO, WORK, RWORK ) 35071 CHARACTER TRANS 35072 LOGICAL CAPPLY 35073 INTEGER N, LDA, LDAF, INFO 35074 INTEGER IPIV( * ) 35075 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) 35076 DOUBLE PRECISION C( * ), RWORK( * ) 35077 LOGICAL NOTRANS 35078 INTEGER KASE, I, J 35079 DOUBLE PRECISION AINVNM, ANORM, TMP 35080 COMPLEX*16 ZDUM 35081 INTEGER ISAVE( 3 ) 35082 LOGICAL LSAME 35083 EXTERNAL LSAME 35084 EXTERNAL ZLACN2, ZGETRS, XERBLA 35085 INTRINSIC ABS, MAX, REAL, DIMAG 35086 DOUBLE PRECISION CABS1 35087 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 35088 ZLA_GERCOND_C = 0.0D+0 35089 INFO = 0 35090 NOTRANS = LSAME( TRANS, 'N' ) 35091 IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. 35092 $ LSAME( TRANS, 'C' ) ) THEN 35093 INFO = -1 35094 ELSE IF( N.LT.0 ) THEN 35095 INFO = -2 35096 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 35097 INFO = -4 35098 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 35099 INFO = -6 35100 END IF 35101 IF( INFO.NE.0 ) THEN 35102 CALL XERBLA( 'ZLA_GERCOND_C', -INFO ) 35103 RETURN 35104 END IF 35105 ANORM = 0.0D+0 35106 IF ( NOTRANS ) THEN 35107 DO I = 1, N 35108 TMP = 0.0D+0 35109 IF ( CAPPLY ) THEN 35110 DO J = 1, N 35111 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 35112 END DO 35113 ELSE 35114 DO J = 1, N 35115 TMP = TMP + CABS1( A( I, J ) ) 35116 END DO 35117 END IF 35118 RWORK( I ) = TMP 35119 ANORM = MAX( ANORM, TMP ) 35120 END DO 35121 ELSE 35122 DO I = 1, N 35123 TMP = 0.0D+0 35124 IF ( CAPPLY ) THEN 35125 DO J = 1, N 35126 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 35127 END DO 35128 ELSE 35129 DO J = 1, N 35130 TMP = TMP + CABS1( A( J, I ) ) 35131 END DO 35132 END IF 35133 RWORK( I ) = TMP 35134 ANORM = MAX( ANORM, TMP ) 35135 END DO 35136 END IF 35137 IF( N.EQ.0 ) THEN 35138 ZLA_GERCOND_C = 1.0D+0 35139 RETURN 35140 ELSE IF( ANORM .EQ. 0.0D+0 ) THEN 35141 RETURN 35142 END IF 35143 AINVNM = 0.0D+0 35144 KASE = 0 35145 10 CONTINUE 35146 CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 35147 IF( KASE.NE.0 ) THEN 35148 IF( KASE.EQ.2 ) THEN 35149 DO I = 1, N 35150 WORK( I ) = WORK( I ) * RWORK( I ) 35151 END DO 35152 IF (NOTRANS) THEN 35153 CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 35154 $ WORK, N, INFO ) 35155 ELSE 35156 CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, 35157 $ WORK, N, INFO ) 35158 ENDIF 35159 IF ( CAPPLY ) THEN 35160 DO I = 1, N 35161 WORK( I ) = WORK( I ) * C( I ) 35162 END DO 35163 END IF 35164 ELSE 35165 IF ( CAPPLY ) THEN 35166 DO I = 1, N 35167 WORK( I ) = WORK( I ) * C( I ) 35168 END DO 35169 END IF 35170 IF ( NOTRANS ) THEN 35171 CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, 35172 $ WORK, N, INFO ) 35173 ELSE 35174 CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 35175 $ WORK, N, INFO ) 35176 END IF 35177 DO I = 1, N 35178 WORK( I ) = WORK( I ) * RWORK( I ) 35179 END DO 35180 END IF 35181 GO TO 10 35182 END IF 35183 IF( AINVNM .NE. 0.0D+0 ) 35184 $ ZLA_GERCOND_C = 1.0D+0 / AINVNM 35185 RETURN 35186 END 35187! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_gercond_x.f 35188 DOUBLE PRECISION FUNCTION ZLA_GERCOND_X( TRANS, N, A, LDA, AF, 35189 $ LDAF, IPIV, X, INFO, 35190 $ WORK, RWORK ) 35191 CHARACTER TRANS 35192 INTEGER N, LDA, LDAF, INFO 35193 INTEGER IPIV( * ) 35194 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) 35195 DOUBLE PRECISION RWORK( * ) 35196 LOGICAL NOTRANS 35197 INTEGER KASE 35198 DOUBLE PRECISION AINVNM, ANORM, TMP 35199 INTEGER I, J 35200 COMPLEX*16 ZDUM 35201 INTEGER ISAVE( 3 ) 35202 LOGICAL LSAME 35203 EXTERNAL LSAME 35204 EXTERNAL ZLACN2, ZGETRS, XERBLA 35205 INTRINSIC ABS, MAX, REAL, DIMAG 35206 DOUBLE PRECISION CABS1 35207 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 35208 ZLA_GERCOND_X = 0.0D+0 35209 INFO = 0 35210 NOTRANS = LSAME( TRANS, 'N' ) 35211 IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. 35212 $ LSAME( TRANS, 'C' ) ) THEN 35213 INFO = -1 35214 ELSE IF( N.LT.0 ) THEN 35215 INFO = -2 35216 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 35217 INFO = -4 35218 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 35219 INFO = -6 35220 END IF 35221 IF( INFO.NE.0 ) THEN 35222 CALL XERBLA( 'ZLA_GERCOND_X', -INFO ) 35223 RETURN 35224 END IF 35225 ANORM = 0.0D+0 35226 IF ( NOTRANS ) THEN 35227 DO I = 1, N 35228 TMP = 0.0D+0 35229 DO J = 1, N 35230 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 35231 END DO 35232 RWORK( I ) = TMP 35233 ANORM = MAX( ANORM, TMP ) 35234 END DO 35235 ELSE 35236 DO I = 1, N 35237 TMP = 0.0D+0 35238 DO J = 1, N 35239 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 35240 END DO 35241 RWORK( I ) = TMP 35242 ANORM = MAX( ANORM, TMP ) 35243 END DO 35244 END IF 35245 IF( N.EQ.0 ) THEN 35246 ZLA_GERCOND_X = 1.0D+0 35247 RETURN 35248 ELSE IF( ANORM .EQ. 0.0D+0 ) THEN 35249 RETURN 35250 END IF 35251 AINVNM = 0.0D+0 35252 KASE = 0 35253 10 CONTINUE 35254 CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 35255 IF( KASE.NE.0 ) THEN 35256 IF( KASE.EQ.2 ) THEN 35257 DO I = 1, N 35258 WORK( I ) = WORK( I ) * RWORK( I ) 35259 END DO 35260 IF ( NOTRANS ) THEN 35261 CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 35262 $ WORK, N, INFO ) 35263 ELSE 35264 CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, 35265 $ WORK, N, INFO ) 35266 ENDIF 35267 DO I = 1, N 35268 WORK( I ) = WORK( I ) / X( I ) 35269 END DO 35270 ELSE 35271 DO I = 1, N 35272 WORK( I ) = WORK( I ) / X( I ) 35273 END DO 35274 IF ( NOTRANS ) THEN 35275 CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, 35276 $ WORK, N, INFO ) 35277 ELSE 35278 CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, 35279 $ WORK, N, INFO ) 35280 END IF 35281 DO I = 1, N 35282 WORK( I ) = WORK( I ) * RWORK( I ) 35283 END DO 35284 END IF 35285 GO TO 10 35286 END IF 35287 IF( AINVNM .NE. 0.0D+0 ) 35288 $ ZLA_GERCOND_X = 1.0D+0 / AINVNM 35289 RETURN 35290 END 35291! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_gerpvgrw.f 35292 DOUBLE PRECISION FUNCTION ZLA_GERPVGRW( N, NCOLS, A, LDA, AF, 35293 $ LDAF ) 35294 INTEGER N, NCOLS, LDA, LDAF 35295 COMPLEX*16 A( LDA, * ), AF( LDAF, * ) 35296 INTEGER I, J 35297 DOUBLE PRECISION AMAX, UMAX, RPVGRW 35298 COMPLEX*16 ZDUM 35299 INTRINSIC MAX, MIN, ABS, REAL, DIMAG 35300 DOUBLE PRECISION CABS1 35301 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 35302 RPVGRW = 1.0D+0 35303 DO J = 1, NCOLS 35304 AMAX = 0.0D+0 35305 UMAX = 0.0D+0 35306 DO I = 1, N 35307 AMAX = MAX( CABS1( A( I, J ) ), AMAX ) 35308 END DO 35309 DO I = 1, J 35310 UMAX = MAX( CABS1( AF( I, J ) ), UMAX ) 35311 END DO 35312 IF ( UMAX /= 0.0D+0 ) THEN 35313 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 35314 END IF 35315 END DO 35316 ZLA_GERPVGRW = RPVGRW 35317 END 35318! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_hercond_c.f 35319 DOUBLE PRECISION FUNCTION ZLA_HERCOND_C( UPLO, N, A, LDA, AF, 35320 $ LDAF, IPIV, C, CAPPLY, 35321 $ INFO, WORK, RWORK ) 35322 CHARACTER UPLO 35323 LOGICAL CAPPLY 35324 INTEGER N, LDA, LDAF, INFO 35325 INTEGER IPIV( * ) 35326 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) 35327 DOUBLE PRECISION C ( * ), RWORK( * ) 35328 INTEGER KASE, I, J 35329 DOUBLE PRECISION AINVNM, ANORM, TMP 35330 LOGICAL UP, UPPER 35331 COMPLEX*16 ZDUM 35332 INTEGER ISAVE( 3 ) 35333 LOGICAL LSAME 35334 EXTERNAL LSAME 35335 EXTERNAL ZLACN2, ZHETRS, XERBLA 35336 INTRINSIC ABS, MAX 35337 DOUBLE PRECISION CABS1 35338 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 35339 ZLA_HERCOND_C = 0.0D+0 35340 INFO = 0 35341 UPPER = LSAME( UPLO, 'U' ) 35342 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 35343 INFO = -1 35344 ELSE IF( N.LT.0 ) THEN 35345 INFO = -2 35346 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 35347 INFO = -4 35348 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 35349 INFO = -6 35350 END IF 35351 IF( INFO.NE.0 ) THEN 35352 CALL XERBLA( 'ZLA_HERCOND_C', -INFO ) 35353 RETURN 35354 END IF 35355 UP = .FALSE. 35356 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 35357 ANORM = 0.0D+0 35358 IF ( UP ) THEN 35359 DO I = 1, N 35360 TMP = 0.0D+0 35361 IF ( CAPPLY ) THEN 35362 DO J = 1, I 35363 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 35364 END DO 35365 DO J = I+1, N 35366 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 35367 END DO 35368 ELSE 35369 DO J = 1, I 35370 TMP = TMP + CABS1( A( J, I ) ) 35371 END DO 35372 DO J = I+1, N 35373 TMP = TMP + CABS1( A( I, J ) ) 35374 END DO 35375 END IF 35376 RWORK( I ) = TMP 35377 ANORM = MAX( ANORM, TMP ) 35378 END DO 35379 ELSE 35380 DO I = 1, N 35381 TMP = 0.0D+0 35382 IF ( CAPPLY ) THEN 35383 DO J = 1, I 35384 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 35385 END DO 35386 DO J = I+1, N 35387 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 35388 END DO 35389 ELSE 35390 DO J = 1, I 35391 TMP = TMP + CABS1( A( I, J ) ) 35392 END DO 35393 DO J = I+1, N 35394 TMP = TMP + CABS1( A( J, I ) ) 35395 END DO 35396 END IF 35397 RWORK( I ) = TMP 35398 ANORM = MAX( ANORM, TMP ) 35399 END DO 35400 END IF 35401 IF( N.EQ.0 ) THEN 35402 ZLA_HERCOND_C = 1.0D+0 35403 RETURN 35404 ELSE IF( ANORM .EQ. 0.0D+0 ) THEN 35405 RETURN 35406 END IF 35407 AINVNM = 0.0D+0 35408 KASE = 0 35409 10 CONTINUE 35410 CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 35411 IF( KASE.NE.0 ) THEN 35412 IF( KASE.EQ.2 ) THEN 35413 DO I = 1, N 35414 WORK( I ) = WORK( I ) * RWORK( I ) 35415 END DO 35416 IF ( UP ) THEN 35417 CALL ZHETRS( 'U', N, 1, AF, LDAF, IPIV, 35418 $ WORK, N, INFO ) 35419 ELSE 35420 CALL ZHETRS( 'L', N, 1, AF, LDAF, IPIV, 35421 $ WORK, N, INFO ) 35422 ENDIF 35423 IF ( CAPPLY ) THEN 35424 DO I = 1, N 35425 WORK( I ) = WORK( I ) * C( I ) 35426 END DO 35427 END IF 35428 ELSE 35429 IF ( CAPPLY ) THEN 35430 DO I = 1, N 35431 WORK( I ) = WORK( I ) * C( I ) 35432 END DO 35433 END IF 35434 IF ( UP ) THEN 35435 CALL ZHETRS( 'U', N, 1, AF, LDAF, IPIV, 35436 $ WORK, N, INFO ) 35437 ELSE 35438 CALL ZHETRS( 'L', N, 1, AF, LDAF, IPIV, 35439 $ WORK, N, INFO ) 35440 END IF 35441 DO I = 1, N 35442 WORK( I ) = WORK( I ) * RWORK( I ) 35443 END DO 35444 END IF 35445 GO TO 10 35446 END IF 35447 IF( AINVNM .NE. 0.0D+0 ) 35448 $ ZLA_HERCOND_C = 1.0D+0 / AINVNM 35449 RETURN 35450 END 35451! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_hercond_x.f 35452 DOUBLE PRECISION FUNCTION ZLA_HERCOND_X( UPLO, N, A, LDA, AF, 35453 $ LDAF, IPIV, X, INFO, 35454 $ WORK, RWORK ) 35455 CHARACTER UPLO 35456 INTEGER N, LDA, LDAF, INFO 35457 INTEGER IPIV( * ) 35458 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) 35459 DOUBLE PRECISION RWORK( * ) 35460 INTEGER KASE, I, J 35461 DOUBLE PRECISION AINVNM, ANORM, TMP 35462 LOGICAL UP, UPPER 35463 COMPLEX*16 ZDUM 35464 INTEGER ISAVE( 3 ) 35465 LOGICAL LSAME 35466 EXTERNAL LSAME 35467 EXTERNAL ZLACN2, ZHETRS, XERBLA 35468 INTRINSIC ABS, MAX 35469 DOUBLE PRECISION CABS1 35470 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 35471 ZLA_HERCOND_X = 0.0D+0 35472 INFO = 0 35473 UPPER = LSAME( UPLO, 'U' ) 35474 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 35475 INFO = -1 35476 ELSE IF ( N.LT.0 ) THEN 35477 INFO = -2 35478 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 35479 INFO = -4 35480 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 35481 INFO = -6 35482 END IF 35483 IF( INFO.NE.0 ) THEN 35484 CALL XERBLA( 'ZLA_HERCOND_X', -INFO ) 35485 RETURN 35486 END IF 35487 UP = .FALSE. 35488 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 35489 ANORM = 0.0D+0 35490 IF ( UP ) THEN 35491 DO I = 1, N 35492 TMP = 0.0D+0 35493 DO J = 1, I 35494 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 35495 END DO 35496 DO J = I+1, N 35497 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 35498 END DO 35499 RWORK( I ) = TMP 35500 ANORM = MAX( ANORM, TMP ) 35501 END DO 35502 ELSE 35503 DO I = 1, N 35504 TMP = 0.0D+0 35505 DO J = 1, I 35506 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 35507 END DO 35508 DO J = I+1, N 35509 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 35510 END DO 35511 RWORK( I ) = TMP 35512 ANORM = MAX( ANORM, TMP ) 35513 END DO 35514 END IF 35515 IF( N.EQ.0 ) THEN 35516 ZLA_HERCOND_X = 1.0D+0 35517 RETURN 35518 ELSE IF( ANORM .EQ. 0.0D+0 ) THEN 35519 RETURN 35520 END IF 35521 AINVNM = 0.0D+0 35522 KASE = 0 35523 10 CONTINUE 35524 CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 35525 IF( KASE.NE.0 ) THEN 35526 IF( KASE.EQ.2 ) THEN 35527 DO I = 1, N 35528 WORK( I ) = WORK( I ) * RWORK( I ) 35529 END DO 35530 IF ( UP ) THEN 35531 CALL ZHETRS( 'U', N, 1, AF, LDAF, IPIV, 35532 $ WORK, N, INFO ) 35533 ELSE 35534 CALL ZHETRS( 'L', N, 1, AF, LDAF, IPIV, 35535 $ WORK, N, INFO ) 35536 ENDIF 35537 DO I = 1, N 35538 WORK( I ) = WORK( I ) / X( I ) 35539 END DO 35540 ELSE 35541 DO I = 1, N 35542 WORK( I ) = WORK( I ) / X( I ) 35543 END DO 35544 IF ( UP ) THEN 35545 CALL ZHETRS( 'U', N, 1, AF, LDAF, IPIV, 35546 $ WORK, N, INFO ) 35547 ELSE 35548 CALL ZHETRS( 'L', N, 1, AF, LDAF, IPIV, 35549 $ WORK, N, INFO ) 35550 END IF 35551 DO I = 1, N 35552 WORK( I ) = WORK( I ) * RWORK( I ) 35553 END DO 35554 END IF 35555 GO TO 10 35556 END IF 35557 IF( AINVNM .NE. 0.0D+0 ) 35558 $ ZLA_HERCOND_X = 1.0D+0 / AINVNM 35559 RETURN 35560 END 35561! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_herpvgrw.f 35562 DOUBLE PRECISION FUNCTION ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, 35563 $ LDAF, IPIV, WORK ) 35564 CHARACTER*1 UPLO 35565 INTEGER N, INFO, LDA, LDAF 35566 INTEGER IPIV( * ) 35567 COMPLEX*16 A( LDA, * ), AF( LDAF, * ) 35568 DOUBLE PRECISION WORK( * ) 35569 INTEGER NCOLS, I, J, K, KP 35570 DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP 35571 LOGICAL UPPER, LSAME 35572 COMPLEX*16 ZDUM 35573 EXTERNAL LSAME 35574 INTRINSIC ABS, REAL, DIMAG, MAX, MIN 35575 DOUBLE PRECISION CABS1 35576 CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) ) 35577 UPPER = LSAME( 'Upper', UPLO ) 35578 IF ( INFO.EQ.0 ) THEN 35579 IF (UPPER) THEN 35580 NCOLS = 1 35581 ELSE 35582 NCOLS = N 35583 END IF 35584 ELSE 35585 NCOLS = INFO 35586 END IF 35587 RPVGRW = 1.0D+0 35588 DO I = 1, 2*N 35589 WORK( I ) = 0.0D+0 35590 END DO 35591 IF ( UPPER ) THEN 35592 DO J = 1, N 35593 DO I = 1, J 35594 WORK( N+I ) = MAX( CABS1( A( I,J ) ), WORK( N+I ) ) 35595 WORK( N+J ) = MAX( CABS1( A( I,J ) ), WORK( N+J ) ) 35596 END DO 35597 END DO 35598 ELSE 35599 DO J = 1, N 35600 DO I = J, N 35601 WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) 35602 WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) 35603 END DO 35604 END DO 35605 END IF 35606 IF ( UPPER ) THEN 35607 K = N 35608 DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) 35609 IF ( IPIV( K ).GT.0 ) THEN 35610 KP = IPIV( K ) 35611 IF ( KP .NE. K ) THEN 35612 TMP = WORK( N+K ) 35613 WORK( N+K ) = WORK( N+KP ) 35614 WORK( N+KP ) = TMP 35615 END IF 35616 DO I = 1, K 35617 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 35618 END DO 35619 K = K - 1 35620 ELSE 35621 KP = -IPIV( K ) 35622 TMP = WORK( N+K-1 ) 35623 WORK( N+K-1 ) = WORK( N+KP ) 35624 WORK( N+KP ) = TMP 35625 DO I = 1, K-1 35626 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 35627 WORK( K-1 ) = 35628 $ MAX( CABS1( AF( I, K-1 ) ), WORK( K-1 ) ) 35629 END DO 35630 WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) 35631 K = K - 2 35632 END IF 35633 END DO 35634 K = NCOLS 35635 DO WHILE ( K .LE. N ) 35636 IF ( IPIV( K ).GT.0 ) THEN 35637 KP = IPIV( K ) 35638 IF ( KP .NE. K ) THEN 35639 TMP = WORK( N+K ) 35640 WORK( N+K ) = WORK( N+KP ) 35641 WORK( N+KP ) = TMP 35642 END IF 35643 K = K + 1 35644 ELSE 35645 KP = -IPIV( K ) 35646 TMP = WORK( N+K ) 35647 WORK( N+K ) = WORK( N+KP ) 35648 WORK( N+KP ) = TMP 35649 K = K + 2 35650 END IF 35651 END DO 35652 ELSE 35653 K = 1 35654 DO WHILE ( K .LE. NCOLS ) 35655 IF ( IPIV( K ).GT.0 ) THEN 35656 KP = IPIV( K ) 35657 IF ( KP .NE. K ) THEN 35658 TMP = WORK( N+K ) 35659 WORK( N+K ) = WORK( N+KP ) 35660 WORK( N+KP ) = TMP 35661 END IF 35662 DO I = K, N 35663 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 35664 END DO 35665 K = K + 1 35666 ELSE 35667 KP = -IPIV( K ) 35668 TMP = WORK( N+K+1 ) 35669 WORK( N+K+1 ) = WORK( N+KP ) 35670 WORK( N+KP ) = TMP 35671 DO I = K+1, N 35672 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 35673 WORK( K+1 ) = 35674 $ MAX( CABS1( AF( I, K+1 ) ) , WORK( K+1 ) ) 35675 END DO 35676 WORK(K) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) 35677 K = K + 2 35678 END IF 35679 END DO 35680 K = NCOLS 35681 DO WHILE ( K .GE. 1 ) 35682 IF ( IPIV( K ).GT.0 ) THEN 35683 KP = IPIV( K ) 35684 IF ( KP .NE. K ) THEN 35685 TMP = WORK( N+K ) 35686 WORK( N+K ) = WORK( N+KP ) 35687 WORK( N+KP ) = TMP 35688 END IF 35689 K = K - 1 35690 ELSE 35691 KP = -IPIV( K ) 35692 TMP = WORK( N+K ) 35693 WORK( N+K ) = WORK( N+KP ) 35694 WORK( N+KP ) = TMP 35695 K = K - 2 35696 ENDIF 35697 END DO 35698 END IF 35699 IF ( UPPER ) THEN 35700 DO I = NCOLS, N 35701 UMAX = WORK( I ) 35702 AMAX = WORK( N+I ) 35703 IF ( UMAX /= 0.0D+0 ) THEN 35704 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 35705 END IF 35706 END DO 35707 ELSE 35708 DO I = 1, NCOLS 35709 UMAX = WORK( I ) 35710 AMAX = WORK( N+I ) 35711 IF ( UMAX /= 0.0D+0 ) THEN 35712 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 35713 END IF 35714 END DO 35715 END IF 35716 ZLA_HERPVGRW = RPVGRW 35717 END 35718! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_porcond_c.f 35719 DOUBLE PRECISION FUNCTION ZLA_PORCOND_C( UPLO, N, A, LDA, AF, 35720 $ LDAF, C, CAPPLY, INFO, 35721 $ WORK, RWORK ) 35722 CHARACTER UPLO 35723 LOGICAL CAPPLY 35724 INTEGER N, LDA, LDAF, INFO 35725 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) 35726 DOUBLE PRECISION C( * ), RWORK( * ) 35727 INTEGER KASE 35728 DOUBLE PRECISION AINVNM, ANORM, TMP 35729 INTEGER I, J 35730 LOGICAL UP, UPPER 35731 COMPLEX*16 ZDUM 35732 INTEGER ISAVE( 3 ) 35733 LOGICAL LSAME 35734 EXTERNAL LSAME 35735 EXTERNAL ZLACN2, ZPOTRS, XERBLA 35736 INTRINSIC ABS, MAX, REAL, DIMAG 35737 DOUBLE PRECISION CABS1 35738 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 35739 ZLA_PORCOND_C = 0.0D+0 35740 INFO = 0 35741 UPPER = LSAME( UPLO, 'U' ) 35742 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 35743 INFO = -1 35744 ELSE IF( N.LT.0 ) THEN 35745 INFO = -2 35746 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 35747 INFO = -4 35748 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 35749 INFO = -6 35750 END IF 35751 IF( INFO.NE.0 ) THEN 35752 CALL XERBLA( 'ZLA_PORCOND_C', -INFO ) 35753 RETURN 35754 END IF 35755 UP = .FALSE. 35756 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 35757 ANORM = 0.0D+0 35758 IF ( UP ) THEN 35759 DO I = 1, N 35760 TMP = 0.0D+0 35761 IF ( CAPPLY ) THEN 35762 DO J = 1, I 35763 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 35764 END DO 35765 DO J = I+1, N 35766 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 35767 END DO 35768 ELSE 35769 DO J = 1, I 35770 TMP = TMP + CABS1( A( J, I ) ) 35771 END DO 35772 DO J = I+1, N 35773 TMP = TMP + CABS1( A( I, J ) ) 35774 END DO 35775 END IF 35776 RWORK( I ) = TMP 35777 ANORM = MAX( ANORM, TMP ) 35778 END DO 35779 ELSE 35780 DO I = 1, N 35781 TMP = 0.0D+0 35782 IF ( CAPPLY ) THEN 35783 DO J = 1, I 35784 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 35785 END DO 35786 DO J = I+1, N 35787 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 35788 END DO 35789 ELSE 35790 DO J = 1, I 35791 TMP = TMP + CABS1( A( I, J ) ) 35792 END DO 35793 DO J = I+1, N 35794 TMP = TMP + CABS1( A( J, I ) ) 35795 END DO 35796 END IF 35797 RWORK( I ) = TMP 35798 ANORM = MAX( ANORM, TMP ) 35799 END DO 35800 END IF 35801 IF( N.EQ.0 ) THEN 35802 ZLA_PORCOND_C = 1.0D+0 35803 RETURN 35804 ELSE IF( ANORM .EQ. 0.0D+0 ) THEN 35805 RETURN 35806 END IF 35807 AINVNM = 0.0D+0 35808 KASE = 0 35809 10 CONTINUE 35810 CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 35811 IF( KASE.NE.0 ) THEN 35812 IF( KASE.EQ.2 ) THEN 35813 DO I = 1, N 35814 WORK( I ) = WORK( I ) * RWORK( I ) 35815 END DO 35816 IF ( UP ) THEN 35817 CALL ZPOTRS( 'U', N, 1, AF, LDAF, 35818 $ WORK, N, INFO ) 35819 ELSE 35820 CALL ZPOTRS( 'L', N, 1, AF, LDAF, 35821 $ WORK, N, INFO ) 35822 ENDIF 35823 IF ( CAPPLY ) THEN 35824 DO I = 1, N 35825 WORK( I ) = WORK( I ) * C( I ) 35826 END DO 35827 END IF 35828 ELSE 35829 IF ( CAPPLY ) THEN 35830 DO I = 1, N 35831 WORK( I ) = WORK( I ) * C( I ) 35832 END DO 35833 END IF 35834 IF ( UP ) THEN 35835 CALL ZPOTRS( 'U', N, 1, AF, LDAF, 35836 $ WORK, N, INFO ) 35837 ELSE 35838 CALL ZPOTRS( 'L', N, 1, AF, LDAF, 35839 $ WORK, N, INFO ) 35840 END IF 35841 DO I = 1, N 35842 WORK( I ) = WORK( I ) * RWORK( I ) 35843 END DO 35844 END IF 35845 GO TO 10 35846 END IF 35847 IF( AINVNM .NE. 0.0D+0 ) 35848 $ ZLA_PORCOND_C = 1.0D+0 / AINVNM 35849 RETURN 35850 END 35851! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_porcond_x.f 35852 DOUBLE PRECISION FUNCTION ZLA_PORCOND_X( UPLO, N, A, LDA, AF, 35853 $ LDAF, X, INFO, WORK, 35854 $ RWORK ) 35855 CHARACTER UPLO 35856 INTEGER N, LDA, LDAF, INFO 35857 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) 35858 DOUBLE PRECISION RWORK( * ) 35859 INTEGER KASE, I, J 35860 DOUBLE PRECISION AINVNM, ANORM, TMP 35861 LOGICAL UP, UPPER 35862 COMPLEX*16 ZDUM 35863 INTEGER ISAVE( 3 ) 35864 LOGICAL LSAME 35865 EXTERNAL LSAME 35866 EXTERNAL ZLACN2, ZPOTRS, XERBLA 35867 INTRINSIC ABS, MAX, REAL, DIMAG 35868 DOUBLE PRECISION CABS1 35869 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 35870 ZLA_PORCOND_X = 0.0D+0 35871 INFO = 0 35872 UPPER = LSAME( UPLO, 'U' ) 35873 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 35874 INFO = -1 35875 ELSE IF ( N.LT.0 ) THEN 35876 INFO = -2 35877 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 35878 INFO = -4 35879 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 35880 INFO = -6 35881 END IF 35882 IF( INFO.NE.0 ) THEN 35883 CALL XERBLA( 'ZLA_PORCOND_X', -INFO ) 35884 RETURN 35885 END IF 35886 UP = .FALSE. 35887 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 35888 ANORM = 0.0D+0 35889 IF ( UP ) THEN 35890 DO I = 1, N 35891 TMP = 0.0D+0 35892 DO J = 1, I 35893 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 35894 END DO 35895 DO J = I+1, N 35896 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 35897 END DO 35898 RWORK( I ) = TMP 35899 ANORM = MAX( ANORM, TMP ) 35900 END DO 35901 ELSE 35902 DO I = 1, N 35903 TMP = 0.0D+0 35904 DO J = 1, I 35905 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 35906 END DO 35907 DO J = I+1, N 35908 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 35909 END DO 35910 RWORK( I ) = TMP 35911 ANORM = MAX( ANORM, TMP ) 35912 END DO 35913 END IF 35914 IF( N.EQ.0 ) THEN 35915 ZLA_PORCOND_X = 1.0D+0 35916 RETURN 35917 ELSE IF( ANORM .EQ. 0.0D+0 ) THEN 35918 RETURN 35919 END IF 35920 AINVNM = 0.0D+0 35921 KASE = 0 35922 10 CONTINUE 35923 CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 35924 IF( KASE.NE.0 ) THEN 35925 IF( KASE.EQ.2 ) THEN 35926 DO I = 1, N 35927 WORK( I ) = WORK( I ) * RWORK( I ) 35928 END DO 35929 IF ( UP ) THEN 35930 CALL ZPOTRS( 'U', N, 1, AF, LDAF, 35931 $ WORK, N, INFO ) 35932 ELSE 35933 CALL ZPOTRS( 'L', N, 1, AF, LDAF, 35934 $ WORK, N, INFO ) 35935 ENDIF 35936 DO I = 1, N 35937 WORK( I ) = WORK( I ) / X( I ) 35938 END DO 35939 ELSE 35940 DO I = 1, N 35941 WORK( I ) = WORK( I ) / X( I ) 35942 END DO 35943 IF ( UP ) THEN 35944 CALL ZPOTRS( 'U', N, 1, AF, LDAF, 35945 $ WORK, N, INFO ) 35946 ELSE 35947 CALL ZPOTRS( 'L', N, 1, AF, LDAF, 35948 $ WORK, N, INFO ) 35949 END IF 35950 DO I = 1, N 35951 WORK( I ) = WORK( I ) * RWORK( I ) 35952 END DO 35953 END IF 35954 GO TO 10 35955 END IF 35956 IF( AINVNM .NE. 0.0D+0 ) 35957 $ ZLA_PORCOND_X = 1.0D+0 / AINVNM 35958 RETURN 35959 END 35960! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_porpvgrw.f 35961 DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, 35962 $ LDAF, WORK ) 35963 CHARACTER*1 UPLO 35964 INTEGER NCOLS, LDA, LDAF 35965 COMPLEX*16 A( LDA, * ), AF( LDAF, * ) 35966 DOUBLE PRECISION WORK( * ) 35967 INTEGER I, J 35968 DOUBLE PRECISION AMAX, UMAX, RPVGRW 35969 LOGICAL UPPER 35970 COMPLEX*16 ZDUM 35971 EXTERNAL LSAME 35972 LOGICAL LSAME 35973 INTRINSIC ABS, MAX, MIN, REAL, DIMAG 35974 DOUBLE PRECISION CABS1 35975 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 35976 UPPER = LSAME( 'Upper', UPLO ) 35977 RPVGRW = 1.0D+0 35978 DO I = 1, 2*NCOLS 35979 WORK( I ) = 0.0D+0 35980 END DO 35981 IF ( UPPER ) THEN 35982 DO J = 1, NCOLS 35983 DO I = 1, J 35984 WORK( NCOLS+J ) = 35985 $ MAX( CABS1( A( I, J ) ), WORK( NCOLS+J ) ) 35986 END DO 35987 END DO 35988 ELSE 35989 DO J = 1, NCOLS 35990 DO I = J, NCOLS 35991 WORK( NCOLS+J ) = 35992 $ MAX( CABS1( A( I, J ) ), WORK( NCOLS+J ) ) 35993 END DO 35994 END DO 35995 END IF 35996 IF ( LSAME( 'Upper', UPLO ) ) THEN 35997 DO J = 1, NCOLS 35998 DO I = 1, J 35999 WORK( J ) = MAX( CABS1( AF( I, J ) ), WORK( J ) ) 36000 END DO 36001 END DO 36002 ELSE 36003 DO J = 1, NCOLS 36004 DO I = J, NCOLS 36005 WORK( J ) = MAX( CABS1( AF( I, J ) ), WORK( J ) ) 36006 END DO 36007 END DO 36008 END IF 36009 IF ( LSAME( 'Upper', UPLO ) ) THEN 36010 DO I = 1, NCOLS 36011 UMAX = WORK( I ) 36012 AMAX = WORK( NCOLS+I ) 36013 IF ( UMAX /= 0.0D+0 ) THEN 36014 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 36015 END IF 36016 END DO 36017 ELSE 36018 DO I = 1, NCOLS 36019 UMAX = WORK( I ) 36020 AMAX = WORK( NCOLS+I ) 36021 IF ( UMAX /= 0.0D+0 ) THEN 36022 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 36023 END IF 36024 END DO 36025 END IF 36026 ZLA_PORPVGRW = RPVGRW 36027 END 36028! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_syrcond_c.f 36029 DOUBLE PRECISION FUNCTION ZLA_SYRCOND_C( UPLO, N, A, LDA, AF, 36030 $ LDAF, IPIV, C, CAPPLY, 36031 $ INFO, WORK, RWORK ) 36032 CHARACTER UPLO 36033 LOGICAL CAPPLY 36034 INTEGER N, LDA, LDAF, INFO 36035 INTEGER IPIV( * ) 36036 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) 36037 DOUBLE PRECISION C( * ), RWORK( * ) 36038 INTEGER KASE 36039 DOUBLE PRECISION AINVNM, ANORM, TMP 36040 INTEGER I, J 36041 LOGICAL UP, UPPER 36042 COMPLEX*16 ZDUM 36043 INTEGER ISAVE( 3 ) 36044 LOGICAL LSAME 36045 EXTERNAL LSAME 36046 EXTERNAL ZLACN2, ZSYTRS, XERBLA 36047 INTRINSIC ABS, MAX 36048 DOUBLE PRECISION CABS1 36049 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 36050 ZLA_SYRCOND_C = 0.0D+0 36051 INFO = 0 36052 UPPER = LSAME( UPLO, 'U' ) 36053 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 36054 INFO = -1 36055 ELSE IF( N.LT.0 ) THEN 36056 INFO = -2 36057 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 36058 INFO = -4 36059 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 36060 INFO = -6 36061 END IF 36062 IF( INFO.NE.0 ) THEN 36063 CALL XERBLA( 'ZLA_SYRCOND_C', -INFO ) 36064 RETURN 36065 END IF 36066 UP = .FALSE. 36067 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 36068 ANORM = 0.0D+0 36069 IF ( UP ) THEN 36070 DO I = 1, N 36071 TMP = 0.0D+0 36072 IF ( CAPPLY ) THEN 36073 DO J = 1, I 36074 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 36075 END DO 36076 DO J = I+1, N 36077 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 36078 END DO 36079 ELSE 36080 DO J = 1, I 36081 TMP = TMP + CABS1( A( J, I ) ) 36082 END DO 36083 DO J = I+1, N 36084 TMP = TMP + CABS1( A( I, J ) ) 36085 END DO 36086 END IF 36087 RWORK( I ) = TMP 36088 ANORM = MAX( ANORM, TMP ) 36089 END DO 36090 ELSE 36091 DO I = 1, N 36092 TMP = 0.0D+0 36093 IF ( CAPPLY ) THEN 36094 DO J = 1, I 36095 TMP = TMP + CABS1( A( I, J ) ) / C( J ) 36096 END DO 36097 DO J = I+1, N 36098 TMP = TMP + CABS1( A( J, I ) ) / C( J ) 36099 END DO 36100 ELSE 36101 DO J = 1, I 36102 TMP = TMP + CABS1( A( I, J ) ) 36103 END DO 36104 DO J = I+1, N 36105 TMP = TMP + CABS1( A( J, I ) ) 36106 END DO 36107 END IF 36108 RWORK( I ) = TMP 36109 ANORM = MAX( ANORM, TMP ) 36110 END DO 36111 END IF 36112 IF( N.EQ.0 ) THEN 36113 ZLA_SYRCOND_C = 1.0D+0 36114 RETURN 36115 ELSE IF( ANORM .EQ. 0.0D+0 ) THEN 36116 RETURN 36117 END IF 36118 AINVNM = 0.0D+0 36119 KASE = 0 36120 10 CONTINUE 36121 CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 36122 IF( KASE.NE.0 ) THEN 36123 IF( KASE.EQ.2 ) THEN 36124 DO I = 1, N 36125 WORK( I ) = WORK( I ) * RWORK( I ) 36126 END DO 36127 IF ( UP ) THEN 36128 CALL ZSYTRS( 'U', N, 1, AF, LDAF, IPIV, 36129 $ WORK, N, INFO ) 36130 ELSE 36131 CALL ZSYTRS( 'L', N, 1, AF, LDAF, IPIV, 36132 $ WORK, N, INFO ) 36133 ENDIF 36134 IF ( CAPPLY ) THEN 36135 DO I = 1, N 36136 WORK( I ) = WORK( I ) * C( I ) 36137 END DO 36138 END IF 36139 ELSE 36140 IF ( CAPPLY ) THEN 36141 DO I = 1, N 36142 WORK( I ) = WORK( I ) * C( I ) 36143 END DO 36144 END IF 36145 IF ( UP ) THEN 36146 CALL ZSYTRS( 'U', N, 1, AF, LDAF, IPIV, 36147 $ WORK, N, INFO ) 36148 ELSE 36149 CALL ZSYTRS( 'L', N, 1, AF, LDAF, IPIV, 36150 $ WORK, N, INFO ) 36151 END IF 36152 DO I = 1, N 36153 WORK( I ) = WORK( I ) * RWORK( I ) 36154 END DO 36155 END IF 36156 GO TO 10 36157 END IF 36158 IF( AINVNM .NE. 0.0D+0 ) 36159 $ ZLA_SYRCOND_C = 1.0D+0 / AINVNM 36160 RETURN 36161 END 36162! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_syrcond_x.f 36163 DOUBLE PRECISION FUNCTION ZLA_SYRCOND_X( UPLO, N, A, LDA, AF, 36164 $ LDAF, IPIV, X, INFO, 36165 $ WORK, RWORK ) 36166 CHARACTER UPLO 36167 INTEGER N, LDA, LDAF, INFO 36168 INTEGER IPIV( * ) 36169 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) 36170 DOUBLE PRECISION RWORK( * ) 36171 INTEGER KASE 36172 DOUBLE PRECISION AINVNM, ANORM, TMP 36173 INTEGER I, J 36174 LOGICAL UP, UPPER 36175 COMPLEX*16 ZDUM 36176 INTEGER ISAVE( 3 ) 36177 LOGICAL LSAME 36178 EXTERNAL LSAME 36179 EXTERNAL ZLACN2, ZSYTRS, XERBLA 36180 INTRINSIC ABS, MAX 36181 DOUBLE PRECISION CABS1 36182 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 36183 ZLA_SYRCOND_X = 0.0D+0 36184 INFO = 0 36185 UPPER = LSAME( UPLO, 'U' ) 36186 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 36187 INFO = -1 36188 ELSE IF( N.LT.0 ) THEN 36189 INFO = -2 36190 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 36191 INFO = -4 36192 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN 36193 INFO = -6 36194 END IF 36195 IF( INFO.NE.0 ) THEN 36196 CALL XERBLA( 'ZLA_SYRCOND_X', -INFO ) 36197 RETURN 36198 END IF 36199 UP = .FALSE. 36200 IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. 36201 ANORM = 0.0D+0 36202 IF ( UP ) THEN 36203 DO I = 1, N 36204 TMP = 0.0D+0 36205 DO J = 1, I 36206 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 36207 END DO 36208 DO J = I+1, N 36209 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 36210 END DO 36211 RWORK( I ) = TMP 36212 ANORM = MAX( ANORM, TMP ) 36213 END DO 36214 ELSE 36215 DO I = 1, N 36216 TMP = 0.0D+0 36217 DO J = 1, I 36218 TMP = TMP + CABS1( A( I, J ) * X( J ) ) 36219 END DO 36220 DO J = I+1, N 36221 TMP = TMP + CABS1( A( J, I ) * X( J ) ) 36222 END DO 36223 RWORK( I ) = TMP 36224 ANORM = MAX( ANORM, TMP ) 36225 END DO 36226 END IF 36227 IF( N.EQ.0 ) THEN 36228 ZLA_SYRCOND_X = 1.0D+0 36229 RETURN 36230 ELSE IF( ANORM .EQ. 0.0D+0 ) THEN 36231 RETURN 36232 END IF 36233 AINVNM = 0.0D+0 36234 KASE = 0 36235 10 CONTINUE 36236 CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) 36237 IF( KASE.NE.0 ) THEN 36238 IF( KASE.EQ.2 ) THEN 36239 DO I = 1, N 36240 WORK( I ) = WORK( I ) * RWORK( I ) 36241 END DO 36242 IF ( UP ) THEN 36243 CALL ZSYTRS( 'U', N, 1, AF, LDAF, IPIV, 36244 $ WORK, N, INFO ) 36245 ELSE 36246 CALL ZSYTRS( 'L', N, 1, AF, LDAF, IPIV, 36247 $ WORK, N, INFO ) 36248 ENDIF 36249 DO I = 1, N 36250 WORK( I ) = WORK( I ) / X( I ) 36251 END DO 36252 ELSE 36253 DO I = 1, N 36254 WORK( I ) = WORK( I ) / X( I ) 36255 END DO 36256 IF ( UP ) THEN 36257 CALL ZSYTRS( 'U', N, 1, AF, LDAF, IPIV, 36258 $ WORK, N, INFO ) 36259 ELSE 36260 CALL ZSYTRS( 'L', N, 1, AF, LDAF, IPIV, 36261 $ WORK, N, INFO ) 36262 END IF 36263 DO I = 1, N 36264 WORK( I ) = WORK( I ) * RWORK( I ) 36265 END DO 36266 END IF 36267 GO TO 10 36268 END IF 36269 IF( AINVNM .NE. 0.0D+0 ) 36270 $ ZLA_SYRCOND_X = 1.0D+0 / AINVNM 36271 RETURN 36272 END 36273! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zla_syrpvgrw.f 36274 DOUBLE PRECISION FUNCTION ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, 36275 $ LDAF, IPIV, WORK ) 36276 CHARACTER*1 UPLO 36277 INTEGER N, INFO, LDA, LDAF 36278 COMPLEX*16 A( LDA, * ), AF( LDAF, * ) 36279 DOUBLE PRECISION WORK( * ) 36280 INTEGER IPIV( * ) 36281 INTEGER NCOLS, I, J, K, KP 36282 DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP 36283 LOGICAL UPPER 36284 COMPLEX*16 ZDUM 36285 INTRINSIC ABS, REAL, DIMAG, MAX, MIN 36286 EXTERNAL LSAME 36287 LOGICAL LSAME 36288 DOUBLE PRECISION CABS1 36289 CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) ) 36290 UPPER = LSAME( 'Upper', UPLO ) 36291 IF ( INFO.EQ.0 ) THEN 36292 IF ( UPPER ) THEN 36293 NCOLS = 1 36294 ELSE 36295 NCOLS = N 36296 END IF 36297 ELSE 36298 NCOLS = INFO 36299 END IF 36300 RPVGRW = 1.0D+0 36301 DO I = 1, 2*N 36302 WORK( I ) = 0.0D+0 36303 END DO 36304 IF ( UPPER ) THEN 36305 DO J = 1, N 36306 DO I = 1, J 36307 WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) 36308 WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) 36309 END DO 36310 END DO 36311 ELSE 36312 DO J = 1, N 36313 DO I = J, N 36314 WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) 36315 WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) 36316 END DO 36317 END DO 36318 END IF 36319 IF ( UPPER ) THEN 36320 K = N 36321 DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) 36322 IF ( IPIV( K ).GT.0 ) THEN 36323 KP = IPIV( K ) 36324 IF ( KP .NE. K ) THEN 36325 TMP = WORK( N+K ) 36326 WORK( N+K ) = WORK( N+KP ) 36327 WORK( N+KP ) = TMP 36328 END IF 36329 DO I = 1, K 36330 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 36331 END DO 36332 K = K - 1 36333 ELSE 36334 KP = -IPIV( K ) 36335 TMP = WORK( N+K-1 ) 36336 WORK( N+K-1 ) = WORK( N+KP ) 36337 WORK( N+KP ) = TMP 36338 DO I = 1, K-1 36339 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 36340 WORK( K-1 ) = 36341 $ MAX( CABS1( AF( I, K-1 ) ), WORK( K-1 ) ) 36342 END DO 36343 WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) 36344 K = K - 2 36345 END IF 36346 END DO 36347 K = NCOLS 36348 DO WHILE ( K .LE. N ) 36349 IF ( IPIV( K ).GT.0 ) THEN 36350 KP = IPIV( K ) 36351 IF ( KP .NE. K ) THEN 36352 TMP = WORK( N+K ) 36353 WORK( N+K ) = WORK( N+KP ) 36354 WORK( N+KP ) = TMP 36355 END IF 36356 K = K + 1 36357 ELSE 36358 KP = -IPIV( K ) 36359 TMP = WORK( N+K ) 36360 WORK( N+K ) = WORK( N+KP ) 36361 WORK( N+KP ) = TMP 36362 K = K + 2 36363 END IF 36364 END DO 36365 ELSE 36366 K = 1 36367 DO WHILE ( K .LE. NCOLS ) 36368 IF ( IPIV( K ).GT.0 ) THEN 36369 KP = IPIV( K ) 36370 IF ( KP .NE. K ) THEN 36371 TMP = WORK( N+K ) 36372 WORK( N+K ) = WORK( N+KP ) 36373 WORK( N+KP ) = TMP 36374 END IF 36375 DO I = K, N 36376 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 36377 END DO 36378 K = K + 1 36379 ELSE 36380 KP = -IPIV( K ) 36381 TMP = WORK( N+K+1 ) 36382 WORK( N+K+1 ) = WORK( N+KP ) 36383 WORK( N+KP ) = TMP 36384 DO I = K+1, N 36385 WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) 36386 WORK( K+1 ) = 36387 $ MAX( CABS1( AF( I, K+1 ) ), WORK( K+1 ) ) 36388 END DO 36389 WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) 36390 K = K + 2 36391 END IF 36392 END DO 36393 K = NCOLS 36394 DO WHILE ( K .GE. 1 ) 36395 IF ( IPIV( K ).GT.0 ) THEN 36396 KP = IPIV( K ) 36397 IF ( KP .NE. K ) THEN 36398 TMP = WORK( N+K ) 36399 WORK( N+K ) = WORK( N+KP ) 36400 WORK( N+KP ) = TMP 36401 END IF 36402 K = K - 1 36403 ELSE 36404 KP = -IPIV( K ) 36405 TMP = WORK( N+K ) 36406 WORK( N+K ) = WORK( N+KP ) 36407 WORK( N+KP ) = TMP 36408 K = K - 2 36409 ENDIF 36410 END DO 36411 END IF 36412 IF ( UPPER ) THEN 36413 DO I = NCOLS, N 36414 UMAX = WORK( I ) 36415 AMAX = WORK( N+I ) 36416 IF ( UMAX /= 0.0D+0 ) THEN 36417 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 36418 END IF 36419 END DO 36420 ELSE 36421 DO I = 1, NCOLS 36422 UMAX = WORK( I ) 36423 AMAX = WORK( N+I ) 36424 IF ( UMAX /= 0.0D+0 ) THEN 36425 RPVGRW = MIN( AMAX / UMAX, RPVGRW ) 36426 END IF 36427 END DO 36428 END IF 36429 ZLA_SYRPVGRW = RPVGRW 36430 END 36431! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlacgv.f 36432 SUBROUTINE ZLACGV( N, X, INCX ) 36433 INTEGER INCX, N 36434 COMPLEX*16 X( * ) 36435 INTEGER I, IOFF 36436 INTRINSIC DCONJG 36437 IF( INCX.EQ.1 ) THEN 36438 DO 10 I = 1, N 36439 X( I ) = DCONJG( X( I ) ) 36440 10 CONTINUE 36441 ELSE 36442 IOFF = 1 36443 IF( INCX.LT.0 ) 36444 $ IOFF = 1 - ( N-1 )*INCX 36445 DO 20 I = 1, N 36446 X( IOFF ) = DCONJG( X( IOFF ) ) 36447 IOFF = IOFF + INCX 36448 20 CONTINUE 36449 END IF 36450 RETURN 36451 END 36452! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlacn2.f 36453 SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) 36454 INTEGER KASE, N 36455 DOUBLE PRECISION EST 36456 INTEGER ISAVE( 3 ) 36457 COMPLEX*16 V( * ), X( * ) 36458 INTEGER ITMAX 36459 PARAMETER ( ITMAX = 5 ) 36460 DOUBLE PRECISION ONE, TWO 36461 PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) 36462 COMPLEX*16 CZERO, CONE 36463 PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), 36464 $ CONE = ( 1.0D0, 0.0D0 ) ) 36465 INTEGER I, JLAST 36466 DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP 36467 INTEGER IZMAX1 36468 DOUBLE PRECISION DLAMCH, DZSUM1 36469 EXTERNAL IZMAX1, DLAMCH, DZSUM1 36470 EXTERNAL ZCOPY 36471 INTRINSIC ABS, DBLE, DCMPLX, DIMAG 36472 SAFMIN = DLAMCH( 'Safe minimum' ) 36473 IF( KASE.EQ.0 ) THEN 36474 DO 10 I = 1, N 36475 X( I ) = DCMPLX( ONE / DBLE( N ) ) 36476 10 CONTINUE 36477 KASE = 1 36478 ISAVE( 1 ) = 1 36479 RETURN 36480 END IF 36481 GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 ) 36482 20 CONTINUE 36483 IF( N.EQ.1 ) THEN 36484 V( 1 ) = X( 1 ) 36485 EST = ABS( V( 1 ) ) 36486 GO TO 130 36487 END IF 36488 EST = DZSUM1( N, X, 1 ) 36489 DO 30 I = 1, N 36490 ABSXI = ABS( X( I ) ) 36491 IF( ABSXI.GT.SAFMIN ) THEN 36492 X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, 36493 $ DIMAG( X( I ) ) / ABSXI ) 36494 ELSE 36495 X( I ) = CONE 36496 END IF 36497 30 CONTINUE 36498 KASE = 2 36499 ISAVE( 1 ) = 2 36500 RETURN 36501 40 CONTINUE 36502 ISAVE( 2 ) = IZMAX1( N, X, 1 ) 36503 ISAVE( 3 ) = 2 36504 50 CONTINUE 36505 DO 60 I = 1, N 36506 X( I ) = CZERO 36507 60 CONTINUE 36508 X( ISAVE( 2 ) ) = CONE 36509 KASE = 1 36510 ISAVE( 1 ) = 3 36511 RETURN 36512 70 CONTINUE 36513 CALL ZCOPY( N, X, 1, V, 1 ) 36514 ESTOLD = EST 36515 EST = DZSUM1( N, V, 1 ) 36516 IF( EST.LE.ESTOLD ) 36517 $ GO TO 100 36518 DO 80 I = 1, N 36519 ABSXI = ABS( X( I ) ) 36520 IF( ABSXI.GT.SAFMIN ) THEN 36521 X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI, 36522 $ DIMAG( X( I ) ) / ABSXI ) 36523 ELSE 36524 X( I ) = CONE 36525 END IF 36526 80 CONTINUE 36527 KASE = 2 36528 ISAVE( 1 ) = 4 36529 RETURN 36530 90 CONTINUE 36531 JLAST = ISAVE( 2 ) 36532 ISAVE( 2 ) = IZMAX1( N, X, 1 ) 36533 IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND. 36534 $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN 36535 ISAVE( 3 ) = ISAVE( 3 ) + 1 36536 GO TO 50 36537 END IF 36538 100 CONTINUE 36539 ALTSGN = ONE 36540 DO 110 I = 1, N 36541 X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ) 36542 ALTSGN = -ALTSGN 36543 110 CONTINUE 36544 KASE = 1 36545 ISAVE( 1 ) = 5 36546 RETURN 36547 120 CONTINUE 36548 TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) ) 36549 IF( TEMP.GT.EST ) THEN 36550 CALL ZCOPY( N, X, 1, V, 1 ) 36551 EST = TEMP 36552 END IF 36553 130 CONTINUE 36554 KASE = 0 36555 RETURN 36556 END 36557! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlacpy.f 36558 SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) 36559 CHARACTER UPLO 36560 INTEGER LDA, LDB, M, N 36561 COMPLEX*16 A( LDA, * ), B( LDB, * ) 36562 INTEGER I, J 36563 LOGICAL LSAME 36564 EXTERNAL LSAME 36565 INTRINSIC MIN 36566 IF( LSAME( UPLO, 'U' ) ) THEN 36567 DO 20 J = 1, N 36568 DO 10 I = 1, MIN( J, M ) 36569 B( I, J ) = A( I, J ) 36570 10 CONTINUE 36571 20 CONTINUE 36572 ELSE IF( LSAME( UPLO, 'L' ) ) THEN 36573 DO 40 J = 1, N 36574 DO 30 I = J, M 36575 B( I, J ) = A( I, J ) 36576 30 CONTINUE 36577 40 CONTINUE 36578 ELSE 36579 DO 60 J = 1, N 36580 DO 50 I = 1, M 36581 B( I, J ) = A( I, J ) 36582 50 CONTINUE 36583 60 CONTINUE 36584 END IF 36585 RETURN 36586 END 36587! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlacrm.f 36588 SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) 36589 INTEGER LDA, LDB, LDC, M, N 36590 DOUBLE PRECISION B( LDB, * ), RWORK( * ) 36591 COMPLEX*16 A( LDA, * ), C( LDC, * ) 36592 DOUBLE PRECISION ONE, ZERO 36593 PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) 36594 INTEGER I, J, L 36595 INTRINSIC DBLE, DCMPLX, DIMAG 36596 EXTERNAL DGEMM 36597 IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) 36598 $ RETURN 36599 DO 20 J = 1, N 36600 DO 10 I = 1, M 36601 RWORK( ( J-1 )*M+I ) = DBLE( A( I, J ) ) 36602 10 CONTINUE 36603 20 CONTINUE 36604 L = M*N + 1 36605 CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO, 36606 $ RWORK( L ), M ) 36607 DO 40 J = 1, N 36608 DO 30 I = 1, M 36609 C( I, J ) = RWORK( L+( J-1 )*M+I-1 ) 36610 30 CONTINUE 36611 40 CONTINUE 36612 DO 60 J = 1, N 36613 DO 50 I = 1, M 36614 RWORK( ( J-1 )*M+I ) = DIMAG( A( I, J ) ) 36615 50 CONTINUE 36616 60 CONTINUE 36617 CALL DGEMM( 'N', 'N', M, N, N, ONE, RWORK, M, B, LDB, ZERO, 36618 $ RWORK( L ), M ) 36619 DO 80 J = 1, N 36620 DO 70 I = 1, M 36621 C( I, J ) = DCMPLX( DBLE( C( I, J ) ), 36622 $ RWORK( L+( J-1 )*M+I-1 ) ) 36623 70 CONTINUE 36624 80 CONTINUE 36625 RETURN 36626 END 36627! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zladiv.f 36628 COMPLEX*16 FUNCTION ZLADIV( X, Y ) 36629 COMPLEX*16 X, Y 36630 DOUBLE PRECISION ZI, ZR 36631 EXTERNAL DLADIV 36632 INTRINSIC DBLE, DCMPLX, DIMAG 36633 CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, 36634 $ ZI ) 36635 ZLADIV = DCMPLX( ZR, ZI ) 36636 RETURN 36637 END 36638! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlaed0.f 36639 SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, 36640 $ IWORK, INFO ) 36641 INTEGER INFO, LDQ, LDQS, N, QSIZ 36642 INTEGER IWORK( * ) 36643 DOUBLE PRECISION D( * ), E( * ), RWORK( * ) 36644 COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * ) 36645 DOUBLE PRECISION TWO 36646 PARAMETER ( TWO = 2.D+0 ) 36647 INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM, 36648 $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM, 36649 $ J, K, LGN, LL, MATSIZ, MSD2, SMLSIZ, SMM1, 36650 $ SPM1, SPM2, SUBMAT, SUBPBS, TLVLS 36651 DOUBLE PRECISION TEMP 36652 EXTERNAL DCOPY, DSTEQR, XERBLA, ZCOPY, ZLACRM, ZLAED7 36653 INTEGER ILAENV 36654 EXTERNAL ILAENV 36655 INTRINSIC ABS, DBLE, INT, LOG, MAX 36656 INFO = 0 36657 IF( QSIZ.LT.MAX( 0, N ) ) THEN 36658 INFO = -1 36659 ELSE IF( N.LT.0 ) THEN 36660 INFO = -2 36661 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN 36662 INFO = -6 36663 ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN 36664 INFO = -8 36665 END IF 36666 IF( INFO.NE.0 ) THEN 36667 CALL XERBLA( 'ZLAED0', -INFO ) 36668 RETURN 36669 END IF 36670 IF( N.EQ.0 ) 36671 $ RETURN 36672 SMLSIZ = ILAENV( 9, 'ZLAED0', ' ', 0, 0, 0, 0 ) 36673 IWORK( 1 ) = N 36674 SUBPBS = 1 36675 TLVLS = 0 36676 10 CONTINUE 36677 IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN 36678 DO 20 J = SUBPBS, 1, -1 36679 IWORK( 2*J ) = ( IWORK( J )+1 ) / 2 36680 IWORK( 2*J-1 ) = IWORK( J ) / 2 36681 20 CONTINUE 36682 TLVLS = TLVLS + 1 36683 SUBPBS = 2*SUBPBS 36684 GO TO 10 36685 END IF 36686 DO 30 J = 2, SUBPBS 36687 IWORK( J ) = IWORK( J ) + IWORK( J-1 ) 36688 30 CONTINUE 36689 SPM1 = SUBPBS - 1 36690 DO 40 I = 1, SPM1 36691 SUBMAT = IWORK( I ) + 1 36692 SMM1 = SUBMAT - 1 36693 D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) ) 36694 D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) ) 36695 40 CONTINUE 36696 INDXQ = 4*N + 3 36697 TEMP = LOG( DBLE( N ) ) / LOG( TWO ) 36698 LGN = INT( TEMP ) 36699 IF( 2**LGN.LT.N ) 36700 $ LGN = LGN + 1 36701 IF( 2**LGN.LT.N ) 36702 $ LGN = LGN + 1 36703 IPRMPT = INDXQ + N + 1 36704 IPERM = IPRMPT + N*LGN 36705 IQPTR = IPERM + N*LGN 36706 IGIVPT = IQPTR + N + 2 36707 IGIVCL = IGIVPT + N*LGN 36708 IGIVNM = 1 36709 IQ = IGIVNM + 2*N*LGN 36710 IWREM = IQ + N**2 + 1 36711 DO 50 I = 0, SUBPBS 36712 IWORK( IPRMPT+I ) = 1 36713 IWORK( IGIVPT+I ) = 1 36714 50 CONTINUE 36715 IWORK( IQPTR ) = 1 36716 CURR = 0 36717 DO 70 I = 0, SPM1 36718 IF( I.EQ.0 ) THEN 36719 SUBMAT = 1 36720 MATSIZ = IWORK( 1 ) 36721 ELSE 36722 SUBMAT = IWORK( I ) + 1 36723 MATSIZ = IWORK( I+1 ) - IWORK( I ) 36724 END IF 36725 LL = IQ - 1 + IWORK( IQPTR+CURR ) 36726 CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ), 36727 $ RWORK( LL ), MATSIZ, RWORK, INFO ) 36728 CALL ZLACRM( QSIZ, MATSIZ, Q( 1, SUBMAT ), LDQ, RWORK( LL ), 36729 $ MATSIZ, QSTORE( 1, SUBMAT ), LDQS, 36730 $ RWORK( IWREM ) ) 36731 IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2 36732 CURR = CURR + 1 36733 IF( INFO.GT.0 ) THEN 36734 INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 36735 RETURN 36736 END IF 36737 K = 1 36738 DO 60 J = SUBMAT, IWORK( I+1 ) 36739 IWORK( INDXQ+J ) = K 36740 K = K + 1 36741 60 CONTINUE 36742 70 CONTINUE 36743 CURLVL = 1 36744 80 CONTINUE 36745 IF( SUBPBS.GT.1 ) THEN 36746 SPM2 = SUBPBS - 2 36747 DO 90 I = 0, SPM2, 2 36748 IF( I.EQ.0 ) THEN 36749 SUBMAT = 1 36750 MATSIZ = IWORK( 2 ) 36751 MSD2 = IWORK( 1 ) 36752 CURPRB = 0 36753 ELSE 36754 SUBMAT = IWORK( I ) + 1 36755 MATSIZ = IWORK( I+2 ) - IWORK( I ) 36756 MSD2 = MATSIZ / 2 36757 CURPRB = CURPRB + 1 36758 END IF 36759 CALL ZLAED7( MATSIZ, MSD2, QSIZ, TLVLS, CURLVL, CURPRB, 36760 $ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS, 36761 $ E( SUBMAT+MSD2-1 ), IWORK( INDXQ+SUBMAT ), 36762 $ RWORK( IQ ), IWORK( IQPTR ), IWORK( IPRMPT ), 36763 $ IWORK( IPERM ), IWORK( IGIVPT ), 36764 $ IWORK( IGIVCL ), RWORK( IGIVNM ), 36765 $ Q( 1, SUBMAT ), RWORK( IWREM ), 36766 $ IWORK( SUBPBS+1 ), INFO ) 36767 IF( INFO.GT.0 ) THEN 36768 INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 36769 RETURN 36770 END IF 36771 IWORK( I / 2+1 ) = IWORK( I+2 ) 36772 90 CONTINUE 36773 SUBPBS = SUBPBS / 2 36774 CURLVL = CURLVL + 1 36775 GO TO 80 36776 END IF 36777 DO 100 I = 1, N 36778 J = IWORK( INDXQ+I ) 36779 RWORK( I ) = D( J ) 36780 CALL ZCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 ) 36781 100 CONTINUE 36782 CALL DCOPY( N, RWORK, 1, D, 1 ) 36783 RETURN 36784 END 36785! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlaed7.f 36786 SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, 36787 $ LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, 36788 $ GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, 36789 $ INFO ) 36790 INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ, 36791 $ TLVLS 36792 DOUBLE PRECISION RHO 36793 INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), 36794 $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) 36795 DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * ) 36796 COMPLEX*16 Q( LDQ, * ), WORK( * ) 36797 INTEGER COLTYP, CURR, I, IDLMDA, INDX, 36798 $ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR 36799 EXTERNAL DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM, ZLAED8 36800 INTRINSIC MAX, MIN 36801 INFO = 0 36802 IF( N.LT.0 ) THEN 36803 INFO = -1 36804 ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN 36805 INFO = -2 36806 ELSE IF( QSIZ.LT.N ) THEN 36807 INFO = -3 36808 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN 36809 INFO = -9 36810 END IF 36811 IF( INFO.NE.0 ) THEN 36812 CALL XERBLA( 'ZLAED7', -INFO ) 36813 RETURN 36814 END IF 36815 IF( N.EQ.0 ) 36816 $ RETURN 36817 IZ = 1 36818 IDLMDA = IZ + N 36819 IW = IDLMDA + N 36820 IQ = IW + N 36821 INDX = 1 36822 INDXC = INDX + N 36823 COLTYP = INDXC + N 36824 INDXP = COLTYP + N 36825 PTR = 1 + 2**TLVLS 36826 DO 10 I = 1, CURLVL - 1 36827 PTR = PTR + 2**( TLVLS-I ) 36828 10 CONTINUE 36829 CURR = PTR + CURPBM 36830 CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, 36831 $ GIVCOL, GIVNUM, QSTORE, QPTR, RWORK( IZ ), 36832 $ RWORK( IZ+N ), INFO ) 36833 IF( CURLVL.EQ.TLVLS ) THEN 36834 QPTR( CURR ) = 1 36835 PRMPTR( CURR ) = 1 36836 GIVPTR( CURR ) = 1 36837 END IF 36838 CALL ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, RWORK( IZ ), 36839 $ RWORK( IDLMDA ), WORK, QSIZ, RWORK( IW ), 36840 $ IWORK( INDXP ), IWORK( INDX ), INDXQ, 36841 $ PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ), 36842 $ GIVCOL( 1, GIVPTR( CURR ) ), 36843 $ GIVNUM( 1, GIVPTR( CURR ) ), INFO ) 36844 PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N 36845 GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR ) 36846 IF( K.NE.0 ) THEN 36847 CALL DLAED9( K, 1, K, N, D, RWORK( IQ ), K, RHO, 36848 $ RWORK( IDLMDA ), RWORK( IW ), 36849 $ QSTORE( QPTR( CURR ) ), K, INFO ) 36850 CALL ZLACRM( QSIZ, K, WORK, QSIZ, QSTORE( QPTR( CURR ) ), K, Q, 36851 $ LDQ, RWORK( IQ ) ) 36852 QPTR( CURR+1 ) = QPTR( CURR ) + K**2 36853 IF( INFO.NE.0 ) THEN 36854 RETURN 36855 END IF 36856 N1 = K 36857 N2 = N - K 36858 CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) 36859 ELSE 36860 QPTR( CURR+1 ) = QPTR( CURR ) 36861 DO 20 I = 1, N 36862 INDXQ( I ) = I 36863 20 CONTINUE 36864 END IF 36865 RETURN 36866 END 36867! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlaed8.f 36868 SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, 36869 $ Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, 36870 $ GIVCOL, GIVNUM, INFO ) 36871 INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ 36872 DOUBLE PRECISION RHO 36873 INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), 36874 $ INDXQ( * ), PERM( * ) 36875 DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ), 36876 $ Z( * ) 36877 COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * ) 36878 DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT 36879 PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0, 36880 $ TWO = 2.0D0, EIGHT = 8.0D0 ) 36881 INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 36882 DOUBLE PRECISION C, EPS, S, T, TAU, TOL 36883 INTEGER IDAMAX 36884 DOUBLE PRECISION DLAMCH, DLAPY2 36885 EXTERNAL IDAMAX, DLAMCH, DLAPY2 36886 EXTERNAL DCOPY, DLAMRG, DSCAL, XERBLA, ZCOPY, ZDROT, 36887 $ ZLACPY 36888 INTRINSIC ABS, MAX, MIN, SQRT 36889 INFO = 0 36890 IF( N.LT.0 ) THEN 36891 INFO = -2 36892 ELSE IF( QSIZ.LT.N ) THEN 36893 INFO = -3 36894 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN 36895 INFO = -5 36896 ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN 36897 INFO = -8 36898 ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN 36899 INFO = -12 36900 END IF 36901 IF( INFO.NE.0 ) THEN 36902 CALL XERBLA( 'ZLAED8', -INFO ) 36903 RETURN 36904 END IF 36905 GIVPTR = 0 36906 IF( N.EQ.0 ) 36907 $ RETURN 36908 N1 = CUTPNT 36909 N2 = N - N1 36910 N1P1 = N1 + 1 36911 IF( RHO.LT.ZERO ) THEN 36912 CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) 36913 END IF 36914 T = ONE / SQRT( TWO ) 36915 DO 10 J = 1, N 36916 INDX( J ) = J 36917 10 CONTINUE 36918 CALL DSCAL( N, T, Z, 1 ) 36919 RHO = ABS( TWO*RHO ) 36920 DO 20 I = CUTPNT + 1, N 36921 INDXQ( I ) = INDXQ( I ) + CUTPNT 36922 20 CONTINUE 36923 DO 30 I = 1, N 36924 DLAMDA( I ) = D( INDXQ( I ) ) 36925 W( I ) = Z( INDXQ( I ) ) 36926 30 CONTINUE 36927 I = 1 36928 J = CUTPNT + 1 36929 CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX ) 36930 DO 40 I = 1, N 36931 D( I ) = DLAMDA( INDX( I ) ) 36932 Z( I ) = W( INDX( I ) ) 36933 40 CONTINUE 36934 IMAX = IDAMAX( N, Z, 1 ) 36935 JMAX = IDAMAX( N, D, 1 ) 36936 EPS = DLAMCH( 'Epsilon' ) 36937 TOL = EIGHT*EPS*ABS( D( JMAX ) ) 36938 IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN 36939 K = 0 36940 DO 50 J = 1, N 36941 PERM( J ) = INDXQ( INDX( J ) ) 36942 CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) 36943 50 CONTINUE 36944 CALL ZLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ), LDQ ) 36945 RETURN 36946 END IF 36947 K = 0 36948 K2 = N + 1 36949 DO 60 J = 1, N 36950 IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN 36951 K2 = K2 - 1 36952 INDXP( K2 ) = J 36953 IF( J.EQ.N ) 36954 $ GO TO 100 36955 ELSE 36956 JLAM = J 36957 GO TO 70 36958 END IF 36959 60 CONTINUE 36960 70 CONTINUE 36961 J = J + 1 36962 IF( J.GT.N ) 36963 $ GO TO 90 36964 IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN 36965 K2 = K2 - 1 36966 INDXP( K2 ) = J 36967 ELSE 36968 S = Z( JLAM ) 36969 C = Z( J ) 36970 TAU = DLAPY2( C, S ) 36971 T = D( J ) - D( JLAM ) 36972 C = C / TAU 36973 S = -S / TAU 36974 IF( ABS( T*C*S ).LE.TOL ) THEN 36975 Z( J ) = TAU 36976 Z( JLAM ) = ZERO 36977 GIVPTR = GIVPTR + 1 36978 GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) 36979 GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) 36980 GIVNUM( 1, GIVPTR ) = C 36981 GIVNUM( 2, GIVPTR ) = S 36982 CALL ZDROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, 36983 $ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S ) 36984 T = D( JLAM )*C*C + D( J )*S*S 36985 D( J ) = D( JLAM )*S*S + D( J )*C*C 36986 D( JLAM ) = T 36987 K2 = K2 - 1 36988 I = 1 36989 80 CONTINUE 36990 IF( K2+I.LE.N ) THEN 36991 IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN 36992 INDXP( K2+I-1 ) = INDXP( K2+I ) 36993 INDXP( K2+I ) = JLAM 36994 I = I + 1 36995 GO TO 80 36996 ELSE 36997 INDXP( K2+I-1 ) = JLAM 36998 END IF 36999 ELSE 37000 INDXP( K2+I-1 ) = JLAM 37001 END IF 37002 JLAM = J 37003 ELSE 37004 K = K + 1 37005 W( K ) = Z( JLAM ) 37006 DLAMDA( K ) = D( JLAM ) 37007 INDXP( K ) = JLAM 37008 JLAM = J 37009 END IF 37010 END IF 37011 GO TO 70 37012 90 CONTINUE 37013 K = K + 1 37014 W( K ) = Z( JLAM ) 37015 DLAMDA( K ) = D( JLAM ) 37016 INDXP( K ) = JLAM 37017 100 CONTINUE 37018 DO 110 J = 1, N 37019 JP = INDXP( J ) 37020 DLAMDA( J ) = D( JP ) 37021 PERM( J ) = INDXQ( INDX( JP ) ) 37022 CALL ZCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) 37023 110 CONTINUE 37024 IF( K.LT.N ) THEN 37025 CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 ) 37026 CALL ZLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2, Q( 1, K+1 ), 37027 $ LDQ ) 37028 END IF 37029 RETURN 37030 END 37031! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlahef.f 37032 SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) 37033 CHARACTER UPLO 37034 INTEGER INFO, KB, LDA, LDW, N, NB 37035 INTEGER IPIV( * ) 37036 COMPLEX*16 A( LDA, * ), W( LDW, * ) 37037 DOUBLE PRECISION ZERO, ONE 37038 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 37039 COMPLEX*16 CONE 37040 PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) 37041 DOUBLE PRECISION EIGHT, SEVTEN 37042 PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) 37043 INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, 37044 $ KSTEP, KW 37045 DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, R1, ROWMAX, T 37046 COMPLEX*16 D11, D21, D22, Z 37047 LOGICAL LSAME 37048 INTEGER IZAMAX 37049 EXTERNAL LSAME, IZAMAX 37050 EXTERNAL ZCOPY, ZDSCAL, ZGEMM, ZGEMV, ZLACGV, ZSWAP 37051 INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT 37052 DOUBLE PRECISION CABS1 37053 CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) ) 37054 INFO = 0 37055 ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT 37056 IF( LSAME( UPLO, 'U' ) ) THEN 37057 K = N 37058 10 CONTINUE 37059 KW = NB + K - N 37060 IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) 37061 $ GO TO 30 37062 KSTEP = 1 37063 CALL ZCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 ) 37064 W( K, KW ) = DBLE( A( K, K ) ) 37065 IF( K.LT.N ) THEN 37066 CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA, 37067 $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 ) 37068 W( K, KW ) = DBLE( W( K, KW ) ) 37069 END IF 37070 ABSAKK = ABS( DBLE( W( K, KW ) ) ) 37071 IF( K.GT.1 ) THEN 37072 IMAX = IZAMAX( K-1, W( 1, KW ), 1 ) 37073 COLMAX = CABS1( W( IMAX, KW ) ) 37074 ELSE 37075 COLMAX = ZERO 37076 END IF 37077 IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN 37078 IF( INFO.EQ.0 ) 37079 $ INFO = K 37080 KP = K 37081 A( K, K ) = DBLE( A( K, K ) ) 37082 ELSE 37083 IF( ABSAKK.GE.ALPHA*COLMAX ) THEN 37084 KP = K 37085 ELSE 37086 CALL ZCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) 37087 W( IMAX, KW-1 ) = DBLE( A( IMAX, IMAX ) ) 37088 CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, 37089 $ W( IMAX+1, KW-1 ), 1 ) 37090 CALL ZLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 ) 37091 IF( K.LT.N ) THEN 37092 CALL ZGEMV( 'No transpose', K, N-K, -CONE, 37093 $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW, 37094 $ CONE, W( 1, KW-1 ), 1 ) 37095 W( IMAX, KW-1 ) = DBLE( W( IMAX, KW-1 ) ) 37096 END IF 37097 JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 ) 37098 ROWMAX = CABS1( W( JMAX, KW-1 ) ) 37099 IF( IMAX.GT.1 ) THEN 37100 JMAX = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 ) 37101 ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, KW-1 ) ) ) 37102 END IF 37103 IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN 37104 KP = K 37105 ELSE IF( ABS( DBLE( W( IMAX, KW-1 ) ) ).GE.ALPHA*ROWMAX ) 37106 $ THEN 37107 KP = IMAX 37108 CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) 37109 ELSE 37110 KP = IMAX 37111 KSTEP = 2 37112 END IF 37113 END IF 37114 KK = K - KSTEP + 1 37115 KKW = NB + KK - N 37116 IF( KP.NE.KK ) THEN 37117 A( KP, KP ) = DBLE( A( KK, KK ) ) 37118 CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), 37119 $ LDA ) 37120 CALL ZLACGV( KK-1-KP, A( KP, KP+1 ), LDA ) 37121 IF( KP.GT.1 ) 37122 $ CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) 37123 IF( K.LT.N ) 37124 $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ), 37125 $ LDA ) 37126 CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), 37127 $ LDW ) 37128 END IF 37129 IF( KSTEP.EQ.1 ) THEN 37130 CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) 37131 IF( K.GT.1 ) THEN 37132 R1 = ONE / DBLE( A( K, K ) ) 37133 CALL ZDSCAL( K-1, R1, A( 1, K ), 1 ) 37134 CALL ZLACGV( K-1, W( 1, KW ), 1 ) 37135 END IF 37136 ELSE 37137 IF( K.GT.2 ) THEN 37138 D21 = W( K-1, KW ) 37139 D11 = W( K, KW ) / DCONJG( D21 ) 37140 D22 = W( K-1, KW-1 ) / D21 37141 T = ONE / ( DBLE( D11*D22 )-ONE ) 37142 D21 = T / D21 37143 DO 20 J = 1, K - 2 37144 A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) 37145 A( J, K ) = DCONJG( D21 )* 37146 $ ( D22*W( J, KW )-W( J, KW-1 ) ) 37147 20 CONTINUE 37148 END IF 37149 A( K-1, K-1 ) = W( K-1, KW-1 ) 37150 A( K-1, K ) = W( K-1, KW ) 37151 A( K, K ) = W( K, KW ) 37152 CALL ZLACGV( K-1, W( 1, KW ), 1 ) 37153 CALL ZLACGV( K-2, W( 1, KW-1 ), 1 ) 37154 END IF 37155 END IF 37156 IF( KSTEP.EQ.1 ) THEN 37157 IPIV( K ) = KP 37158 ELSE 37159 IPIV( K ) = -KP 37160 IPIV( K-1 ) = -KP 37161 END IF 37162 K = K - KSTEP 37163 GO TO 10 37164 30 CONTINUE 37165 DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB 37166 JB = MIN( NB, K-J+1 ) 37167 DO 40 JJ = J, J + JB - 1 37168 A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) 37169 CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE, 37170 $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE, 37171 $ A( J, JJ ), 1 ) 37172 A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) 37173 40 CONTINUE 37174 CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, 37175 $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, 37176 $ CONE, A( 1, J ), LDA ) 37177 50 CONTINUE 37178 J = K + 1 37179 60 CONTINUE 37180 JJ = J 37181 JP = IPIV( J ) 37182 IF( JP.LT.0 ) THEN 37183 JP = -JP 37184 J = J + 1 37185 END IF 37186 J = J + 1 37187 IF( JP.NE.JJ .AND. J.LE.N ) 37188 $ CALL ZSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) 37189 IF( J.LT.N ) 37190 $ GO TO 60 37191 KB = N - K 37192 ELSE 37193 K = 1 37194 70 CONTINUE 37195 IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) 37196 $ GO TO 90 37197 KSTEP = 1 37198 W( K, K ) = DBLE( A( K, K ) ) 37199 IF( K.LT.N ) 37200 $ CALL ZCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 ) 37201 CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA, 37202 $ W( K, 1 ), LDW, CONE, W( K, K ), 1 ) 37203 W( K, K ) = DBLE( W( K, K ) ) 37204 ABSAKK = ABS( DBLE( W( K, K ) ) ) 37205 IF( K.LT.N ) THEN 37206 IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 ) 37207 COLMAX = CABS1( W( IMAX, K ) ) 37208 ELSE 37209 COLMAX = ZERO 37210 END IF 37211 IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN 37212 IF( INFO.EQ.0 ) 37213 $ INFO = K 37214 KP = K 37215 A( K, K ) = DBLE( A( K, K ) ) 37216 ELSE 37217 IF( ABSAKK.GE.ALPHA*COLMAX ) THEN 37218 KP = K 37219 ELSE 37220 CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) 37221 CALL ZLACGV( IMAX-K, W( K, K+1 ), 1 ) 37222 W( IMAX, K+1 ) = DBLE( A( IMAX, IMAX ) ) 37223 IF( IMAX.LT.N ) 37224 $ CALL ZCOPY( N-IMAX, A( IMAX+1, IMAX ), 1, 37225 $ W( IMAX+1, K+1 ), 1 ) 37226 CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), 37227 $ LDA, W( IMAX, 1 ), LDW, CONE, W( K, K+1 ), 37228 $ 1 ) 37229 W( IMAX, K+1 ) = DBLE( W( IMAX, K+1 ) ) 37230 JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 ) 37231 ROWMAX = CABS1( W( JMAX, K+1 ) ) 37232 IF( IMAX.LT.N ) THEN 37233 JMAX = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 ) 37234 ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, K+1 ) ) ) 37235 END IF 37236 IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN 37237 KP = K 37238 ELSE IF( ABS( DBLE( W( IMAX, K+1 ) ) ).GE.ALPHA*ROWMAX ) 37239 $ THEN 37240 KP = IMAX 37241 CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) 37242 ELSE 37243 KP = IMAX 37244 KSTEP = 2 37245 END IF 37246 END IF 37247 KK = K + KSTEP - 1 37248 IF( KP.NE.KK ) THEN 37249 A( KP, KP ) = DBLE( A( KK, KK ) ) 37250 CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), 37251 $ LDA ) 37252 CALL ZLACGV( KP-KK-1, A( KP, KK+1 ), LDA ) 37253 IF( KP.LT.N ) 37254 $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) 37255 IF( K.GT.1 ) 37256 $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) 37257 CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) 37258 END IF 37259 IF( KSTEP.EQ.1 ) THEN 37260 CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) 37261 IF( K.LT.N ) THEN 37262 R1 = ONE / DBLE( A( K, K ) ) 37263 CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 ) 37264 CALL ZLACGV( N-K, W( K+1, K ), 1 ) 37265 END IF 37266 ELSE 37267 IF( K.LT.N-1 ) THEN 37268 D21 = W( K+1, K ) 37269 D11 = W( K+1, K+1 ) / D21 37270 D22 = W( K, K ) / DCONJG( D21 ) 37271 T = ONE / ( DBLE( D11*D22 )-ONE ) 37272 D21 = T / D21 37273 DO 80 J = K + 2, N 37274 A( J, K ) = DCONJG( D21 )* 37275 $ ( D11*W( J, K )-W( J, K+1 ) ) 37276 A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) 37277 80 CONTINUE 37278 END IF 37279 A( K, K ) = W( K, K ) 37280 A( K+1, K ) = W( K+1, K ) 37281 A( K+1, K+1 ) = W( K+1, K+1 ) 37282 CALL ZLACGV( N-K, W( K+1, K ), 1 ) 37283 CALL ZLACGV( N-K-1, W( K+2, K+1 ), 1 ) 37284 END IF 37285 END IF 37286 IF( KSTEP.EQ.1 ) THEN 37287 IPIV( K ) = KP 37288 ELSE 37289 IPIV( K ) = -KP 37290 IPIV( K+1 ) = -KP 37291 END IF 37292 K = K + KSTEP 37293 GO TO 70 37294 90 CONTINUE 37295 DO 110 J = K, N, NB 37296 JB = MIN( NB, N-J+1 ) 37297 DO 100 JJ = J, J + JB - 1 37298 A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) 37299 CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE, 37300 $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE, 37301 $ A( JJ, JJ ), 1 ) 37302 A( JJ, JJ ) = DBLE( A( JJ, JJ ) ) 37303 100 CONTINUE 37304 IF( J+JB.LE.N ) 37305 $ CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, 37306 $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ), 37307 $ LDW, CONE, A( J+JB, J ), LDA ) 37308 110 CONTINUE 37309 J = K - 1 37310 120 CONTINUE 37311 JJ = J 37312 JP = IPIV( J ) 37313 IF( JP.LT.0 ) THEN 37314 JP = -JP 37315 J = J - 1 37316 END IF 37317 J = J - 1 37318 IF( JP.NE.JJ .AND. J.GE.1 ) 37319 $ CALL ZSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) 37320 IF( J.GT.1 ) 37321 $ GO TO 120 37322 KB = K - 1 37323 END IF 37324 RETURN 37325 END 37326! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlahqr.f 37327 SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, 37328 $ IHIZ, Z, LDZ, INFO ) 37329 INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N 37330 LOGICAL WANTT, WANTZ 37331 COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) 37332 COMPLEX*16 ZERO, ONE 37333 PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), 37334 $ ONE = ( 1.0d0, 0.0d0 ) ) 37335 DOUBLE PRECISION RZERO, RONE, HALF 37336 PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 ) 37337 DOUBLE PRECISION DAT1 37338 PARAMETER ( DAT1 = 3.0d0 / 4.0d0 ) 37339 COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, 37340 $ V2, X, Y 37341 DOUBLE PRECISION AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, 37342 $ SAFMIN, SMLNUM, SX, T2, TST, ULP 37343 INTEGER I, I1, I2, ITS, ITMAX, J, JHI, JLO, K, L, M, 37344 $ NH, NZ 37345 COMPLEX*16 V( 2 ) 37346 COMPLEX*16 ZLADIV 37347 DOUBLE PRECISION DLAMCH 37348 EXTERNAL ZLADIV, DLAMCH 37349 EXTERNAL DLABAD, ZCOPY, ZLARFG, ZSCAL 37350 DOUBLE PRECISION CABS1 37351 INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT 37352 CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) 37353 INFO = 0 37354 IF( N.EQ.0 ) 37355 $ RETURN 37356 IF( ILO.EQ.IHI ) THEN 37357 W( ILO ) = H( ILO, ILO ) 37358 RETURN 37359 END IF 37360 DO 10 J = ILO, IHI - 3 37361 H( J+2, J ) = ZERO 37362 H( J+3, J ) = ZERO 37363 10 CONTINUE 37364 IF( ILO.LE.IHI-2 ) 37365 $ H( IHI, IHI-2 ) = ZERO 37366 IF( WANTT ) THEN 37367 JLO = 1 37368 JHI = N 37369 ELSE 37370 JLO = ILO 37371 JHI = IHI 37372 END IF 37373 DO 20 I = ILO + 1, IHI 37374 IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN 37375 SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) 37376 SC = DCONJG( SC ) / ABS( SC ) 37377 H( I, I-1 ) = ABS( H( I, I-1 ) ) 37378 CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH ) 37379 CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ), 37380 $ H( JLO, I ), 1 ) 37381 IF( WANTZ ) 37382 $ CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 ) 37383 END IF 37384 20 CONTINUE 37385 NH = IHI - ILO + 1 37386 NZ = IHIZ - ILOZ + 1 37387 SAFMIN = DLAMCH( 'SAFE MINIMUM' ) 37388 SAFMAX = RONE / SAFMIN 37389 CALL DLABAD( SAFMIN, SAFMAX ) 37390 ULP = DLAMCH( 'PRECISION' ) 37391 SMLNUM = SAFMIN*( DBLE( NH ) / ULP ) 37392 IF( WANTT ) THEN 37393 I1 = 1 37394 I2 = N 37395 END IF 37396 ITMAX = 30 * MAX( 10, NH ) 37397 I = IHI 37398 30 CONTINUE 37399 IF( I.LT.ILO ) 37400 $ GO TO 150 37401 L = ILO 37402 DO 130 ITS = 0, ITMAX 37403 DO 40 K = I, L + 1, -1 37404 IF( CABS1( H( K, K-1 ) ).LE.SMLNUM ) 37405 $ GO TO 50 37406 TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) 37407 IF( TST.EQ.ZERO ) THEN 37408 IF( K-2.GE.ILO ) 37409 $ TST = TST + ABS( DBLE( H( K-1, K-2 ) ) ) 37410 IF( K+1.LE.IHI ) 37411 $ TST = TST + ABS( DBLE( H( K+1, K ) ) ) 37412 END IF 37413 IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN 37414 AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) 37415 BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) 37416 AA = MAX( CABS1( H( K, K ) ), 37417 $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) 37418 BB = MIN( CABS1( H( K, K ) ), 37419 $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) 37420 S = AA + AB 37421 IF( BA*( AB / S ).LE.MAX( SMLNUM, 37422 $ ULP*( BB*( AA / S ) ) ) )GO TO 50 37423 END IF 37424 40 CONTINUE 37425 50 CONTINUE 37426 L = K 37427 IF( L.GT.ILO ) THEN 37428 H( L, L-1 ) = ZERO 37429 END IF 37430 IF( L.GE.I ) 37431 $ GO TO 140 37432 IF( .NOT.WANTT ) THEN 37433 I1 = L 37434 I2 = I 37435 END IF 37436 IF( ITS.EQ.10 ) THEN 37437 S = DAT1*ABS( DBLE( H( L+1, L ) ) ) 37438 T = S + H( L, L ) 37439 ELSE IF( ITS.EQ.20 ) THEN 37440 S = DAT1*ABS( DBLE( H( I, I-1 ) ) ) 37441 T = S + H( I, I ) 37442 ELSE 37443 T = H( I, I ) 37444 U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) ) 37445 S = CABS1( U ) 37446 IF( S.NE.RZERO ) THEN 37447 X = HALF*( H( I-1, I-1 )-T ) 37448 SX = CABS1( X ) 37449 S = MAX( S, CABS1( X ) ) 37450 Y = S*SQRT( ( X / S )**2+( U / S )**2 ) 37451 IF( SX.GT.RZERO ) THEN 37452 IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )* 37453 $ DIMAG( Y ).LT.RZERO )Y = -Y 37454 END IF 37455 T = T - U*ZLADIV( U, ( X+Y ) ) 37456 END IF 37457 END IF 37458 DO 60 M = I - 1, L + 1, -1 37459 H11 = H( M, M ) 37460 H22 = H( M+1, M+1 ) 37461 H11S = H11 - T 37462 H21 = DBLE( H( M+1, M ) ) 37463 S = CABS1( H11S ) + ABS( H21 ) 37464 H11S = H11S / S 37465 H21 = H21 / S 37466 V( 1 ) = H11S 37467 V( 2 ) = H21 37468 H10 = DBLE( H( M, M-1 ) ) 37469 IF( ABS( H10 )*ABS( H21 ).LE.ULP* 37470 $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) 37471 $ GO TO 70 37472 60 CONTINUE 37473 H11 = H( L, L ) 37474 H22 = H( L+1, L+1 ) 37475 H11S = H11 - T 37476 H21 = DBLE( H( L+1, L ) ) 37477 S = CABS1( H11S ) + ABS( H21 ) 37478 H11S = H11S / S 37479 H21 = H21 / S 37480 V( 1 ) = H11S 37481 V( 2 ) = H21 37482 70 CONTINUE 37483 DO 120 K = M, I - 1 37484 IF( K.GT.M ) 37485 $ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 ) 37486 CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 ) 37487 IF( K.GT.M ) THEN 37488 H( K, K-1 ) = V( 1 ) 37489 H( K+1, K-1 ) = ZERO 37490 END IF 37491 V2 = V( 2 ) 37492 T2 = DBLE( T1*V2 ) 37493 DO 80 J = K, I2 37494 SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J ) 37495 H( K, J ) = H( K, J ) - SUM 37496 H( K+1, J ) = H( K+1, J ) - SUM*V2 37497 80 CONTINUE 37498 DO 90 J = I1, MIN( K+2, I ) 37499 SUM = T1*H( J, K ) + T2*H( J, K+1 ) 37500 H( J, K ) = H( J, K ) - SUM 37501 H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 ) 37502 90 CONTINUE 37503 IF( WANTZ ) THEN 37504 DO 100 J = ILOZ, IHIZ 37505 SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) 37506 Z( J, K ) = Z( J, K ) - SUM 37507 Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 ) 37508 100 CONTINUE 37509 END IF 37510 IF( K.EQ.M .AND. M.GT.L ) THEN 37511 TEMP = ONE - T1 37512 TEMP = TEMP / ABS( TEMP ) 37513 H( M+1, M ) = H( M+1, M )*DCONJG( TEMP ) 37514 IF( M+2.LE.I ) 37515 $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP 37516 DO 110 J = M, I 37517 IF( J.NE.M+1 ) THEN 37518 IF( I2.GT.J ) 37519 $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) 37520 CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 ) 37521 IF( WANTZ ) THEN 37522 CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ), 37523 $ 1 ) 37524 END IF 37525 END IF 37526 110 CONTINUE 37527 END IF 37528 120 CONTINUE 37529 TEMP = H( I, I-1 ) 37530 IF( DIMAG( TEMP ).NE.RZERO ) THEN 37531 RTEMP = ABS( TEMP ) 37532 H( I, I-1 ) = RTEMP 37533 TEMP = TEMP / RTEMP 37534 IF( I2.GT.I ) 37535 $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) 37536 CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) 37537 IF( WANTZ ) THEN 37538 CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 ) 37539 END IF 37540 END IF 37541 130 CONTINUE 37542 INFO = I 37543 RETURN 37544 140 CONTINUE 37545 W( I ) = H( I, I ) 37546 I = L - 1 37547 GO TO 30 37548 150 CONTINUE 37549 RETURN 37550 END 37551! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlahr2.f 37552 SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) 37553 INTEGER K, LDA, LDT, LDY, N, NB 37554 COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), 37555 $ Y( LDY, NB ) 37556 COMPLEX*16 ZERO, ONE 37557 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), 37558 $ ONE = ( 1.0D+0, 0.0D+0 ) ) 37559 INTEGER I 37560 COMPLEX*16 EI 37561 EXTERNAL ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY, 37562 $ ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV 37563 INTRINSIC MIN 37564 IF( N.LE.1 ) 37565 $ RETURN 37566 DO 10 I = 1, NB 37567 IF( I.GT.1 ) THEN 37568 CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) 37569 CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY, 37570 $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 ) 37571 CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) 37572 CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 ) 37573 CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT', 37574 $ I-1, A( K+1, 1 ), 37575 $ LDA, T( 1, NB ), 1 ) 37576 CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, 37577 $ ONE, A( K+I, 1 ), 37578 $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 ) 37579 CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', 37580 $ I-1, T, LDT, 37581 $ T( 1, NB ), 1 ) 37582 CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, 37583 $ A( K+I, 1 ), 37584 $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 ) 37585 CALL ZTRMV( 'Lower', 'NO TRANSPOSE', 37586 $ 'UNIT', I-1, 37587 $ A( K+1, 1 ), LDA, T( 1, NB ), 1 ) 37588 CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 ) 37589 A( K+I-1, I-1 ) = EI 37590 END IF 37591 CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1, 37592 $ TAU( I ) ) 37593 EI = A( K+I, I ) 37594 A( K+I, I ) = ONE 37595 CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, 37596 $ ONE, A( K+1, I+1 ), 37597 $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 ) 37598 CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, 37599 $ ONE, A( K+I, 1 ), LDA, 37600 $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 ) 37601 CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, 37602 $ Y( K+1, 1 ), LDY, 37603 $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 ) 37604 CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 ) 37605 CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 ) 37606 CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', 37607 $ I-1, T, LDT, 37608 $ T( 1, I ), 1 ) 37609 T( I, I ) = TAU( I ) 37610 10 CONTINUE 37611 A( K+NB, NB ) = EI 37612 CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY ) 37613 CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', 37614 $ 'UNIT', K, NB, 37615 $ ONE, A( K+1, 1 ), LDA, Y, LDY ) 37616 IF( N.GT.K+NB ) 37617 $ CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, 37618 $ NB, N-K-NB, ONE, 37619 $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y, 37620 $ LDY ) 37621 CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', 37622 $ 'NON-UNIT', K, NB, 37623 $ ONE, T, LDT, Y, LDY ) 37624 RETURN 37625 END 37626! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlangb.f 37627 DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, 37628 $ WORK ) 37629 IMPLICIT NONE 37630 CHARACTER NORM 37631 INTEGER KL, KU, LDAB, N 37632 DOUBLE PRECISION WORK( * ) 37633 COMPLEX*16 AB( LDAB, * ) 37634 DOUBLE PRECISION ONE, ZERO 37635 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 37636 INTEGER I, J, K, L 37637 DOUBLE PRECISION SUM, VALUE, TEMP 37638 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 37639 LOGICAL LSAME, DISNAN 37640 EXTERNAL LSAME, DISNAN 37641 EXTERNAL ZLASSQ, DCOMBSSQ 37642 INTRINSIC ABS, MAX, MIN, SQRT 37643 IF( N.EQ.0 ) THEN 37644 VALUE = ZERO 37645 ELSE IF( LSAME( NORM, 'M' ) ) THEN 37646 VALUE = ZERO 37647 DO 20 J = 1, N 37648 DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) 37649 TEMP = ABS( AB( I, J ) ) 37650 IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 37651 10 CONTINUE 37652 20 CONTINUE 37653 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 37654 VALUE = ZERO 37655 DO 40 J = 1, N 37656 SUM = ZERO 37657 DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) 37658 SUM = SUM + ABS( AB( I, J ) ) 37659 30 CONTINUE 37660 IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37661 40 CONTINUE 37662 ELSE IF( LSAME( NORM, 'I' ) ) THEN 37663 DO 50 I = 1, N 37664 WORK( I ) = ZERO 37665 50 CONTINUE 37666 DO 70 J = 1, N 37667 K = KU + 1 - J 37668 DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL ) 37669 WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) ) 37670 60 CONTINUE 37671 70 CONTINUE 37672 VALUE = ZERO 37673 DO 80 I = 1, N 37674 TEMP = WORK( I ) 37675 IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 37676 80 CONTINUE 37677 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 37678 SSQ( 1 ) = ZERO 37679 SSQ( 2 ) = ONE 37680 DO 90 J = 1, N 37681 L = MAX( 1, J-KU ) 37682 K = KU + 1 - J + L 37683 COLSSQ( 1 ) = ZERO 37684 COLSSQ( 2 ) = ONE 37685 CALL ZLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, 37686 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 37687 CALL DCOMBSSQ( SSQ, COLSSQ ) 37688 90 CONTINUE 37689 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 37690 END IF 37691 ZLANGB = VALUE 37692 RETURN 37693 END 37694! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlange.f 37695 DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) 37696 IMPLICIT NONE 37697 CHARACTER NORM 37698 INTEGER LDA, M, N 37699 DOUBLE PRECISION WORK( * ) 37700 COMPLEX*16 A( LDA, * ) 37701 DOUBLE PRECISION ONE, ZERO 37702 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 37703 INTEGER I, J 37704 DOUBLE PRECISION SUM, VALUE, TEMP 37705 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 37706 LOGICAL LSAME, DISNAN 37707 EXTERNAL LSAME, DISNAN 37708 EXTERNAL ZLASSQ, DCOMBSSQ 37709 INTRINSIC ABS, MIN, SQRT 37710 IF( MIN( M, N ).EQ.0 ) THEN 37711 VALUE = ZERO 37712 ELSE IF( LSAME( NORM, 'M' ) ) THEN 37713 VALUE = ZERO 37714 DO 20 J = 1, N 37715 DO 10 I = 1, M 37716 TEMP = ABS( A( I, J ) ) 37717 IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 37718 10 CONTINUE 37719 20 CONTINUE 37720 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 37721 VALUE = ZERO 37722 DO 40 J = 1, N 37723 SUM = ZERO 37724 DO 30 I = 1, M 37725 SUM = SUM + ABS( A( I, J ) ) 37726 30 CONTINUE 37727 IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37728 40 CONTINUE 37729 ELSE IF( LSAME( NORM, 'I' ) ) THEN 37730 DO 50 I = 1, M 37731 WORK( I ) = ZERO 37732 50 CONTINUE 37733 DO 70 J = 1, N 37734 DO 60 I = 1, M 37735 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 37736 60 CONTINUE 37737 70 CONTINUE 37738 VALUE = ZERO 37739 DO 80 I = 1, M 37740 TEMP = WORK( I ) 37741 IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP 37742 80 CONTINUE 37743 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 37744 SSQ( 1 ) = ZERO 37745 SSQ( 2 ) = ONE 37746 DO 90 J = 1, N 37747 COLSSQ( 1 ) = ZERO 37748 COLSSQ( 2 ) = ONE 37749 CALL ZLASSQ( M, A( 1, J ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 37750 CALL DCOMBSSQ( SSQ, COLSSQ ) 37751 90 CONTINUE 37752 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 37753 END IF 37754 ZLANGE = VALUE 37755 RETURN 37756 END 37757! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlangt.f 37758 DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU ) 37759 CHARACTER NORM 37760 INTEGER N 37761 COMPLEX*16 D( * ), DL( * ), DU( * ) 37762 DOUBLE PRECISION ONE, ZERO 37763 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 37764 INTEGER I 37765 DOUBLE PRECISION ANORM, SCALE, SUM, TEMP 37766 LOGICAL LSAME, DISNAN 37767 EXTERNAL LSAME, DISNAN 37768 EXTERNAL ZLASSQ 37769 INTRINSIC ABS, SQRT 37770 IF( N.LE.0 ) THEN 37771 ANORM = ZERO 37772 ELSE IF( LSAME( NORM, 'M' ) ) THEN 37773 ANORM = ABS( D( N ) ) 37774 DO 10 I = 1, N - 1 37775 IF( ANORM.LT.ABS( DL( I ) ) .OR. DISNAN( ABS( DL( I ) ) ) ) 37776 $ ANORM = ABS(DL(I)) 37777 IF( ANORM.LT.ABS( D( I ) ) .OR. DISNAN( ABS( D( I ) ) ) ) 37778 $ ANORM = ABS(D(I)) 37779 IF( ANORM.LT.ABS( DU( I ) ) .OR. DISNAN (ABS( DU( I ) ) ) ) 37780 $ ANORM = ABS(DU(I)) 37781 10 CONTINUE 37782 ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN 37783 IF( N.EQ.1 ) THEN 37784 ANORM = ABS( D( 1 ) ) 37785 ELSE 37786 ANORM = ABS( D( 1 ) )+ABS( DL( 1 ) ) 37787 TEMP = ABS( D( N ) )+ABS( DU( N-1 ) ) 37788 IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP 37789 DO 20 I = 2, N - 1 37790 TEMP = ABS( D( I ) )+ABS( DL( I ) )+ABS( DU( I-1 ) ) 37791 IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP 37792 20 CONTINUE 37793 END IF 37794 ELSE IF( LSAME( NORM, 'I' ) ) THEN 37795 IF( N.EQ.1 ) THEN 37796 ANORM = ABS( D( 1 ) ) 37797 ELSE 37798 ANORM = ABS( D( 1 ) )+ABS( DU( 1 ) ) 37799 TEMP = ABS( D( N ) )+ABS( DL( N-1 ) ) 37800 IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP 37801 DO 30 I = 2, N - 1 37802 TEMP = ABS( D( I ) )+ABS( DU( I ) )+ABS( DL( I-1 ) ) 37803 IF( ANORM .LT. TEMP .OR. DISNAN( TEMP ) ) ANORM = TEMP 37804 30 CONTINUE 37805 END IF 37806 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 37807 SCALE = ZERO 37808 SUM = ONE 37809 CALL ZLASSQ( N, D, 1, SCALE, SUM ) 37810 IF( N.GT.1 ) THEN 37811 CALL ZLASSQ( N-1, DL, 1, SCALE, SUM ) 37812 CALL ZLASSQ( N-1, DU, 1, SCALE, SUM ) 37813 END IF 37814 ANORM = SCALE*SQRT( SUM ) 37815 END IF 37816 ZLANGT = ANORM 37817 RETURN 37818 END 37819! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlanhb.f 37820 DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, 37821 $ WORK ) 37822 IMPLICIT NONE 37823 CHARACTER NORM, UPLO 37824 INTEGER K, LDAB, N 37825 DOUBLE PRECISION WORK( * ) 37826 COMPLEX*16 AB( LDAB, * ) 37827 DOUBLE PRECISION ONE, ZERO 37828 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 37829 INTEGER I, J, L 37830 DOUBLE PRECISION ABSA, SUM, VALUE 37831 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 37832 LOGICAL LSAME, DISNAN 37833 EXTERNAL LSAME, DISNAN 37834 EXTERNAL ZLASSQ, DCOMBSSQ 37835 INTRINSIC ABS, DBLE, MAX, MIN, SQRT 37836 IF( N.EQ.0 ) THEN 37837 VALUE = ZERO 37838 ELSE IF( LSAME( NORM, 'M' ) ) THEN 37839 VALUE = ZERO 37840 IF( LSAME( UPLO, 'U' ) ) THEN 37841 DO 20 J = 1, N 37842 DO 10 I = MAX( K+2-J, 1 ), K 37843 SUM = ABS( AB( I, J ) ) 37844 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37845 10 CONTINUE 37846 SUM = ABS( DBLE( AB( K+1, J ) ) ) 37847 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37848 20 CONTINUE 37849 ELSE 37850 DO 40 J = 1, N 37851 SUM = ABS( DBLE( AB( 1, J ) ) ) 37852 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37853 DO 30 I = 2, MIN( N+1-J, K+1 ) 37854 SUM = ABS( AB( I, J ) ) 37855 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37856 30 CONTINUE 37857 40 CONTINUE 37858 END IF 37859 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 37860 $ ( NORM.EQ.'1' ) ) THEN 37861 VALUE = ZERO 37862 IF( LSAME( UPLO, 'U' ) ) THEN 37863 DO 60 J = 1, N 37864 SUM = ZERO 37865 L = K + 1 - J 37866 DO 50 I = MAX( 1, J-K ), J - 1 37867 ABSA = ABS( AB( L+I, J ) ) 37868 SUM = SUM + ABSA 37869 WORK( I ) = WORK( I ) + ABSA 37870 50 CONTINUE 37871 WORK( J ) = SUM + ABS( DBLE( AB( K+1, J ) ) ) 37872 60 CONTINUE 37873 DO 70 I = 1, N 37874 SUM = WORK( I ) 37875 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37876 70 CONTINUE 37877 ELSE 37878 DO 80 I = 1, N 37879 WORK( I ) = ZERO 37880 80 CONTINUE 37881 DO 100 J = 1, N 37882 SUM = WORK( J ) + ABS( DBLE( AB( 1, J ) ) ) 37883 L = 1 - J 37884 DO 90 I = J + 1, MIN( N, J+K ) 37885 ABSA = ABS( AB( L+I, J ) ) 37886 SUM = SUM + ABSA 37887 WORK( I ) = WORK( I ) + ABSA 37888 90 CONTINUE 37889 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37890 100 CONTINUE 37891 END IF 37892 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 37893 SSQ( 1 ) = ZERO 37894 SSQ( 2 ) = ONE 37895 IF( K.GT.0 ) THEN 37896 IF( LSAME( UPLO, 'U' ) ) THEN 37897 DO 110 J = 2, N 37898 COLSSQ( 1 ) = ZERO 37899 COLSSQ( 2 ) = ONE 37900 CALL ZLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), 37901 $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 37902 CALL DCOMBSSQ( SSQ, COLSSQ ) 37903 110 CONTINUE 37904 L = K + 1 37905 ELSE 37906 DO 120 J = 1, N - 1 37907 COLSSQ( 1 ) = ZERO 37908 COLSSQ( 2 ) = ONE 37909 CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, 37910 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 37911 CALL DCOMBSSQ( SSQ, COLSSQ ) 37912 120 CONTINUE 37913 L = 1 37914 END IF 37915 SSQ( 2 ) = 2*SSQ( 2 ) 37916 ELSE 37917 L = 1 37918 END IF 37919 COLSSQ( 1 ) = ZERO 37920 COLSSQ( 2 ) = ONE 37921 DO 130 J = 1, N 37922 IF( DBLE( AB( L, J ) ).NE.ZERO ) THEN 37923 ABSA = ABS( DBLE( AB( L, J ) ) ) 37924 IF( COLSSQ( 1 ).LT.ABSA ) THEN 37925 COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 37926 COLSSQ( 1 ) = ABSA 37927 ELSE 37928 COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 37929 END IF 37930 END IF 37931 130 CONTINUE 37932 CALL DCOMBSSQ( SSQ, COLSSQ ) 37933 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 37934 END IF 37935 ZLANHB = VALUE 37936 RETURN 37937 END 37938! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlanhe.f 37939 DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) 37940 IMPLICIT NONE 37941 CHARACTER NORM, UPLO 37942 INTEGER LDA, N 37943 DOUBLE PRECISION WORK( * ) 37944 COMPLEX*16 A( LDA, * ) 37945 DOUBLE PRECISION ONE, ZERO 37946 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 37947 INTEGER I, J 37948 DOUBLE PRECISION ABSA, SUM, VALUE 37949 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 37950 LOGICAL LSAME, DISNAN 37951 EXTERNAL LSAME, DISNAN 37952 EXTERNAL ZLASSQ, DCOMBSSQ 37953 INTRINSIC ABS, DBLE, SQRT 37954 IF( N.EQ.0 ) THEN 37955 VALUE = ZERO 37956 ELSE IF( LSAME( NORM, 'M' ) ) THEN 37957 VALUE = ZERO 37958 IF( LSAME( UPLO, 'U' ) ) THEN 37959 DO 20 J = 1, N 37960 DO 10 I = 1, J - 1 37961 SUM = ABS( A( I, J ) ) 37962 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37963 10 CONTINUE 37964 SUM = ABS( DBLE( A( J, J ) ) ) 37965 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37966 20 CONTINUE 37967 ELSE 37968 DO 40 J = 1, N 37969 SUM = ABS( DBLE( A( J, J ) ) ) 37970 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37971 DO 30 I = J + 1, N 37972 SUM = ABS( A( I, J ) ) 37973 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37974 30 CONTINUE 37975 40 CONTINUE 37976 END IF 37977 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 37978 $ ( NORM.EQ.'1' ) ) THEN 37979 VALUE = ZERO 37980 IF( LSAME( UPLO, 'U' ) ) THEN 37981 DO 60 J = 1, N 37982 SUM = ZERO 37983 DO 50 I = 1, J - 1 37984 ABSA = ABS( A( I, J ) ) 37985 SUM = SUM + ABSA 37986 WORK( I ) = WORK( I ) + ABSA 37987 50 CONTINUE 37988 WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) ) 37989 60 CONTINUE 37990 DO 70 I = 1, N 37991 SUM = WORK( I ) 37992 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 37993 70 CONTINUE 37994 ELSE 37995 DO 80 I = 1, N 37996 WORK( I ) = ZERO 37997 80 CONTINUE 37998 DO 100 J = 1, N 37999 SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) ) 38000 DO 90 I = J + 1, N 38001 ABSA = ABS( A( I, J ) ) 38002 SUM = SUM + ABSA 38003 WORK( I ) = WORK( I ) + ABSA 38004 90 CONTINUE 38005 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 38006 100 CONTINUE 38007 END IF 38008 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 38009 SSQ( 1 ) = ZERO 38010 SSQ( 2 ) = ONE 38011 IF( LSAME( UPLO, 'U' ) ) THEN 38012 DO 110 J = 2, N 38013 COLSSQ( 1 ) = ZERO 38014 COLSSQ( 2 ) = ONE 38015 CALL ZLASSQ( J-1, A( 1, J ), 1, 38016 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 38017 CALL DCOMBSSQ( SSQ, COLSSQ ) 38018 110 CONTINUE 38019 ELSE 38020 DO 120 J = 1, N - 1 38021 COLSSQ( 1 ) = ZERO 38022 COLSSQ( 2 ) = ONE 38023 CALL ZLASSQ( N-J, A( J+1, J ), 1, 38024 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 38025 CALL DCOMBSSQ( SSQ, COLSSQ ) 38026 120 CONTINUE 38027 END IF 38028 SSQ( 2 ) = 2*SSQ( 2 ) 38029 DO 130 I = 1, N 38030 IF( DBLE( A( I, I ) ).NE.ZERO ) THEN 38031 ABSA = ABS( DBLE( A( I, I ) ) ) 38032 IF( SSQ( 1 ).LT.ABSA ) THEN 38033 SSQ( 2 ) = ONE + SSQ( 2 )*( SSQ( 1 ) / ABSA )**2 38034 SSQ( 1 ) = ABSA 38035 ELSE 38036 SSQ( 2 ) = SSQ( 2 ) + ( ABSA / SSQ( 1 ) )**2 38037 END IF 38038 END IF 38039 130 CONTINUE 38040 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 38041 END IF 38042 ZLANHE = VALUE 38043 RETURN 38044 END 38045! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlanhf.f 38046 DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK ) 38047 CHARACTER NORM, TRANSR, UPLO 38048 INTEGER N 38049 DOUBLE PRECISION WORK( 0: * ) 38050 COMPLEX*16 A( 0: * ) 38051 DOUBLE PRECISION ONE, ZERO 38052 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 38053 INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA 38054 DOUBLE PRECISION SCALE, S, VALUE, AA, TEMP 38055 LOGICAL LSAME, DISNAN 38056 EXTERNAL LSAME, DISNAN 38057 EXTERNAL ZLASSQ 38058 INTRINSIC ABS, DBLE, SQRT 38059 IF( N.EQ.0 ) THEN 38060 ZLANHF = ZERO 38061 RETURN 38062 ELSE IF( N.EQ.1 ) THEN 38063 ZLANHF = ABS(DBLE(A(0))) 38064 RETURN 38065 END IF 38066 NOE = 1 38067 IF( MOD( N, 2 ).EQ.0 ) 38068 $ NOE = 0 38069 IFM = 1 38070 IF( LSAME( TRANSR, 'C' ) ) 38071 $ IFM = 0 38072 ILU = 1 38073 IF( LSAME( UPLO, 'U' ) ) 38074 $ ILU = 0 38075 IF( IFM.EQ.1 ) THEN 38076 IF( NOE.EQ.1 ) THEN 38077 LDA = N 38078 ELSE 38079 LDA = N + 1 38080 END IF 38081 ELSE 38082 LDA = ( N+1 ) / 2 38083 END IF 38084 IF( LSAME( NORM, 'M' ) ) THEN 38085 K = ( N+1 ) / 2 38086 VALUE = ZERO 38087 IF( NOE.EQ.1 ) THEN 38088 IF( IFM.EQ.1 ) THEN 38089 IF( ILU.EQ.1 ) THEN 38090 J = 0 38091 TEMP = ABS( DBLE( A( J+J*LDA ) ) ) 38092 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38093 $ VALUE = TEMP 38094 DO I = 1, N - 1 38095 TEMP = ABS( A( I+J*LDA ) ) 38096 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38097 $ VALUE = TEMP 38098 END DO 38099 DO J = 1, K - 1 38100 DO I = 0, J - 2 38101 TEMP = ABS( A( I+J*LDA ) ) 38102 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38103 $ VALUE = TEMP 38104 END DO 38105 I = J - 1 38106 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38107 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38108 $ VALUE = TEMP 38109 I = J 38110 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38111 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38112 $ VALUE = TEMP 38113 DO I = J + 1, N - 1 38114 TEMP = ABS( A( I+J*LDA ) ) 38115 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38116 $ VALUE = TEMP 38117 END DO 38118 END DO 38119 ELSE 38120 DO J = 0, K - 2 38121 DO I = 0, K + J - 2 38122 TEMP = ABS( A( I+J*LDA ) ) 38123 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38124 $ VALUE = TEMP 38125 END DO 38126 I = K + J - 1 38127 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38128 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38129 $ VALUE = TEMP 38130 I = I + 1 38131 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38132 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38133 $ VALUE = TEMP 38134 DO I = K + J + 1, N - 1 38135 TEMP = ABS( A( I+J*LDA ) ) 38136 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38137 $ VALUE = TEMP 38138 END DO 38139 END DO 38140 DO I = 0, N - 2 38141 TEMP = ABS( A( I+J*LDA ) ) 38142 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38143 $ VALUE = TEMP 38144 END DO 38145 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38146 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38147 $ VALUE = TEMP 38148 END IF 38149 ELSE 38150 IF( ILU.EQ.1 ) THEN 38151 DO J = 0, K - 2 38152 DO I = 0, J - 1 38153 TEMP = ABS( A( I+J*LDA ) ) 38154 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38155 $ VALUE = TEMP 38156 END DO 38157 I = J 38158 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38159 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38160 $ VALUE = TEMP 38161 I = J + 1 38162 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38163 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38164 $ VALUE = TEMP 38165 DO I = J + 2, K - 1 38166 TEMP = ABS( A( I+J*LDA ) ) 38167 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38168 $ VALUE = TEMP 38169 END DO 38170 END DO 38171 J = K - 1 38172 DO I = 0, K - 2 38173 TEMP = ABS( A( I+J*LDA ) ) 38174 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38175 $ VALUE = TEMP 38176 END DO 38177 I = K - 1 38178 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38179 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38180 $ VALUE = TEMP 38181 DO J = K, N - 1 38182 DO I = 0, K - 1 38183 TEMP = ABS( A( I+J*LDA ) ) 38184 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38185 $ VALUE = TEMP 38186 END DO 38187 END DO 38188 ELSE 38189 DO J = 0, K - 2 38190 DO I = 0, K - 1 38191 TEMP = ABS( A( I+J*LDA ) ) 38192 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38193 $ VALUE = TEMP 38194 END DO 38195 END DO 38196 J = K - 1 38197 TEMP = ABS( DBLE( A( 0+J*LDA ) ) ) 38198 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38199 $ VALUE = TEMP 38200 DO I = 1, K - 1 38201 TEMP = ABS( A( I+J*LDA ) ) 38202 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38203 $ VALUE = TEMP 38204 END DO 38205 DO J = K, N - 1 38206 DO I = 0, J - K - 1 38207 TEMP = ABS( A( I+J*LDA ) ) 38208 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38209 $ VALUE = TEMP 38210 END DO 38211 I = J - K 38212 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38213 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38214 $ VALUE = TEMP 38215 I = J - K + 1 38216 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38217 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38218 $ VALUE = TEMP 38219 DO I = J - K + 2, K - 1 38220 TEMP = ABS( A( I+J*LDA ) ) 38221 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38222 $ VALUE = TEMP 38223 END DO 38224 END DO 38225 END IF 38226 END IF 38227 ELSE 38228 IF( IFM.EQ.1 ) THEN 38229 IF( ILU.EQ.1 ) THEN 38230 J = 0 38231 TEMP = ABS( DBLE( A( J+J*LDA ) ) ) 38232 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38233 $ VALUE = TEMP 38234 TEMP = ABS( DBLE( A( J+1+J*LDA ) ) ) 38235 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38236 $ VALUE = TEMP 38237 DO I = 2, N 38238 TEMP = ABS( A( I+J*LDA ) ) 38239 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38240 $ VALUE = TEMP 38241 END DO 38242 DO J = 1, K - 1 38243 DO I = 0, J - 1 38244 TEMP = ABS( A( I+J*LDA ) ) 38245 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38246 $ VALUE = TEMP 38247 END DO 38248 I = J 38249 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38250 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38251 $ VALUE = TEMP 38252 I = J + 1 38253 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38254 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38255 $ VALUE = TEMP 38256 DO I = J + 2, N 38257 TEMP = ABS( A( I+J*LDA ) ) 38258 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38259 $ VALUE = TEMP 38260 END DO 38261 END DO 38262 ELSE 38263 DO J = 0, K - 2 38264 DO I = 0, K + J - 1 38265 TEMP = ABS( A( I+J*LDA ) ) 38266 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38267 $ VALUE = TEMP 38268 END DO 38269 I = K + J 38270 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38271 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38272 $ VALUE = TEMP 38273 I = I + 1 38274 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38275 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38276 $ VALUE = TEMP 38277 DO I = K + J + 2, N 38278 TEMP = ABS( A( I+J*LDA ) ) 38279 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38280 $ VALUE = TEMP 38281 END DO 38282 END DO 38283 DO I = 0, N - 2 38284 TEMP = ABS( A( I+J*LDA ) ) 38285 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38286 $ VALUE = TEMP 38287 END DO 38288 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38289 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38290 $ VALUE = TEMP 38291 I = N 38292 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38293 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38294 $ VALUE = TEMP 38295 END IF 38296 ELSE 38297 IF( ILU.EQ.1 ) THEN 38298 J = 0 38299 TEMP = ABS( DBLE( A( J+J*LDA ) ) ) 38300 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38301 $ VALUE = TEMP 38302 DO I = 1, K - 1 38303 TEMP = ABS( A( I+J*LDA ) ) 38304 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38305 $ VALUE = TEMP 38306 END DO 38307 DO J = 1, K - 1 38308 DO I = 0, J - 2 38309 TEMP = ABS( A( I+J*LDA ) ) 38310 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38311 $ VALUE = TEMP 38312 END DO 38313 I = J - 1 38314 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38315 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38316 $ VALUE = TEMP 38317 I = J 38318 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38319 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38320 $ VALUE = TEMP 38321 DO I = J + 1, K - 1 38322 TEMP = ABS( A( I+J*LDA ) ) 38323 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38324 $ VALUE = TEMP 38325 END DO 38326 END DO 38327 J = K 38328 DO I = 0, K - 2 38329 TEMP = ABS( A( I+J*LDA ) ) 38330 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38331 $ VALUE = TEMP 38332 END DO 38333 I = K - 1 38334 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38335 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38336 $ VALUE = TEMP 38337 DO J = K + 1, N 38338 DO I = 0, K - 1 38339 TEMP = ABS( A( I+J*LDA ) ) 38340 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38341 $ VALUE = TEMP 38342 END DO 38343 END DO 38344 ELSE 38345 DO J = 0, K - 1 38346 DO I = 0, K - 1 38347 TEMP = ABS( A( I+J*LDA ) ) 38348 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38349 $ VALUE = TEMP 38350 END DO 38351 END DO 38352 J = K 38353 TEMP = ABS( DBLE( A( 0+J*LDA ) ) ) 38354 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38355 $ VALUE = TEMP 38356 DO I = 1, K - 1 38357 TEMP = ABS( A( I+J*LDA ) ) 38358 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38359 $ VALUE = TEMP 38360 END DO 38361 DO J = K + 1, N - 1 38362 DO I = 0, J - K - 2 38363 TEMP = ABS( A( I+J*LDA ) ) 38364 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38365 $ VALUE = TEMP 38366 END DO 38367 I = J - K - 1 38368 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38369 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38370 $ VALUE = TEMP 38371 I = J - K 38372 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38373 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38374 $ VALUE = TEMP 38375 DO I = J - K + 1, K - 1 38376 TEMP = ABS( A( I+J*LDA ) ) 38377 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38378 $ VALUE = TEMP 38379 END DO 38380 END DO 38381 J = N 38382 DO I = 0, K - 2 38383 TEMP = ABS( A( I+J*LDA ) ) 38384 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38385 $ VALUE = TEMP 38386 END DO 38387 I = K - 1 38388 TEMP = ABS( DBLE( A( I+J*LDA ) ) ) 38389 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38390 $ VALUE = TEMP 38391 END IF 38392 END IF 38393 END IF 38394 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 38395 $ ( NORM.EQ.'1' ) ) THEN 38396 IF( IFM.EQ.1 ) THEN 38397 K = N / 2 38398 IF( NOE.EQ.1 ) THEN 38399 IF( ILU.EQ.0 ) THEN 38400 DO I = 0, K - 1 38401 WORK( I ) = ZERO 38402 END DO 38403 DO J = 0, K 38404 S = ZERO 38405 DO I = 0, K + J - 1 38406 AA = ABS( A( I+J*LDA ) ) 38407 S = S + AA 38408 WORK( I ) = WORK( I ) + AA 38409 END DO 38410 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38411 WORK( J+K ) = S + AA 38412 IF( I.EQ.K+K ) 38413 $ GO TO 10 38414 I = I + 1 38415 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38416 WORK( J ) = WORK( J ) + AA 38417 S = ZERO 38418 DO L = J + 1, K - 1 38419 I = I + 1 38420 AA = ABS( A( I+J*LDA ) ) 38421 S = S + AA 38422 WORK( L ) = WORK( L ) + AA 38423 END DO 38424 WORK( J ) = WORK( J ) + S 38425 END DO 38426 10 CONTINUE 38427 VALUE = WORK( 0 ) 38428 DO I = 1, N-1 38429 TEMP = WORK( I ) 38430 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38431 $ VALUE = TEMP 38432 END DO 38433 ELSE 38434 K = K + 1 38435 DO I = K, N - 1 38436 WORK( I ) = ZERO 38437 END DO 38438 DO J = K - 1, 0, -1 38439 S = ZERO 38440 DO I = 0, J - 2 38441 AA = ABS( A( I+J*LDA ) ) 38442 S = S + AA 38443 WORK( I+K ) = WORK( I+K ) + AA 38444 END DO 38445 IF( J.GT.0 ) THEN 38446 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38447 S = S + AA 38448 WORK( I+K ) = WORK( I+K ) + S 38449 I = I + 1 38450 END IF 38451 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38452 WORK( J ) = AA 38453 S = ZERO 38454 DO L = J + 1, N - 1 38455 I = I + 1 38456 AA = ABS( A( I+J*LDA ) ) 38457 S = S + AA 38458 WORK( L ) = WORK( L ) + AA 38459 END DO 38460 WORK( J ) = WORK( J ) + S 38461 END DO 38462 VALUE = WORK( 0 ) 38463 DO I = 1, N-1 38464 TEMP = WORK( I ) 38465 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38466 $ VALUE = TEMP 38467 END DO 38468 END IF 38469 ELSE 38470 IF( ILU.EQ.0 ) THEN 38471 DO I = 0, K - 1 38472 WORK( I ) = ZERO 38473 END DO 38474 DO J = 0, K - 1 38475 S = ZERO 38476 DO I = 0, K + J - 1 38477 AA = ABS( A( I+J*LDA ) ) 38478 S = S + AA 38479 WORK( I ) = WORK( I ) + AA 38480 END DO 38481 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38482 WORK( J+K ) = S + AA 38483 I = I + 1 38484 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38485 WORK( J ) = WORK( J ) + AA 38486 S = ZERO 38487 DO L = J + 1, K - 1 38488 I = I + 1 38489 AA = ABS( A( I+J*LDA ) ) 38490 S = S + AA 38491 WORK( L ) = WORK( L ) + AA 38492 END DO 38493 WORK( J ) = WORK( J ) + S 38494 END DO 38495 VALUE = WORK( 0 ) 38496 DO I = 1, N-1 38497 TEMP = WORK( I ) 38498 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38499 $ VALUE = TEMP 38500 END DO 38501 ELSE 38502 DO I = K, N - 1 38503 WORK( I ) = ZERO 38504 END DO 38505 DO J = K - 1, 0, -1 38506 S = ZERO 38507 DO I = 0, J - 1 38508 AA = ABS( A( I+J*LDA ) ) 38509 S = S + AA 38510 WORK( I+K ) = WORK( I+K ) + AA 38511 END DO 38512 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38513 S = S + AA 38514 WORK( I+K ) = WORK( I+K ) + S 38515 I = I + 1 38516 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38517 WORK( J ) = AA 38518 S = ZERO 38519 DO L = J + 1, N - 1 38520 I = I + 1 38521 AA = ABS( A( I+J*LDA ) ) 38522 S = S + AA 38523 WORK( L ) = WORK( L ) + AA 38524 END DO 38525 WORK( J ) = WORK( J ) + S 38526 END DO 38527 VALUE = WORK( 0 ) 38528 DO I = 1, N-1 38529 TEMP = WORK( I ) 38530 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38531 $ VALUE = TEMP 38532 END DO 38533 END IF 38534 END IF 38535 ELSE 38536 K = N / 2 38537 IF( NOE.EQ.1 ) THEN 38538 IF( ILU.EQ.0 ) THEN 38539 N1 = K 38540 K = K + 1 38541 DO I = N1, N - 1 38542 WORK( I ) = ZERO 38543 END DO 38544 DO J = 0, N1 - 1 38545 S = ZERO 38546 DO I = 0, K - 1 38547 AA = ABS( A( I+J*LDA ) ) 38548 WORK( I+N1 ) = WORK( I+N1 ) + AA 38549 S = S + AA 38550 END DO 38551 WORK( J ) = S 38552 END DO 38553 S = ABS( DBLE( A( 0+J*LDA ) ) ) 38554 DO I = 1, K - 1 38555 AA = ABS( A( I+J*LDA ) ) 38556 WORK( I+N1 ) = WORK( I+N1 ) + AA 38557 S = S + AA 38558 END DO 38559 WORK( J ) = WORK( J ) + S 38560 DO J = K, N - 1 38561 S = ZERO 38562 DO I = 0, J - K - 1 38563 AA = ABS( A( I+J*LDA ) ) 38564 WORK( I ) = WORK( I ) + AA 38565 S = S + AA 38566 END DO 38567 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38568 S = S + AA 38569 WORK( J-K ) = WORK( J-K ) + S 38570 I = I + 1 38571 S = ABS( DBLE( A( I+J*LDA ) ) ) 38572 DO L = J + 1, N - 1 38573 I = I + 1 38574 AA = ABS( A( I+J*LDA ) ) 38575 WORK( L ) = WORK( L ) + AA 38576 S = S + AA 38577 END DO 38578 WORK( J ) = WORK( J ) + S 38579 END DO 38580 VALUE = WORK( 0 ) 38581 DO I = 1, N-1 38582 TEMP = WORK( I ) 38583 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38584 $ VALUE = TEMP 38585 END DO 38586 ELSE 38587 K = K + 1 38588 DO I = K, N - 1 38589 WORK( I ) = ZERO 38590 END DO 38591 DO J = 0, K - 2 38592 S = ZERO 38593 DO I = 0, J - 1 38594 AA = ABS( A( I+J*LDA ) ) 38595 WORK( I ) = WORK( I ) + AA 38596 S = S + AA 38597 END DO 38598 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38599 S = S + AA 38600 WORK( J ) = S 38601 I = I + 1 38602 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38603 S = AA 38604 DO L = K + J + 1, N - 1 38605 I = I + 1 38606 AA = ABS( A( I+J*LDA ) ) 38607 S = S + AA 38608 WORK( L ) = WORK( L ) + AA 38609 END DO 38610 WORK( K+J ) = WORK( K+J ) + S 38611 END DO 38612 S = ZERO 38613 DO I = 0, K - 2 38614 AA = ABS( A( I+J*LDA ) ) 38615 WORK( I ) = WORK( I ) + AA 38616 S = S + AA 38617 END DO 38618 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38619 S = S + AA 38620 WORK( I ) = S 38621 DO J = K, N - 1 38622 S = ZERO 38623 DO I = 0, K - 1 38624 AA = ABS( A( I+J*LDA ) ) 38625 WORK( I ) = WORK( I ) + AA 38626 S = S + AA 38627 END DO 38628 WORK( J ) = WORK( J ) + S 38629 END DO 38630 VALUE = WORK( 0 ) 38631 DO I = 1, N-1 38632 TEMP = WORK( I ) 38633 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38634 $ VALUE = TEMP 38635 END DO 38636 END IF 38637 ELSE 38638 IF( ILU.EQ.0 ) THEN 38639 DO I = K, N - 1 38640 WORK( I ) = ZERO 38641 END DO 38642 DO J = 0, K - 1 38643 S = ZERO 38644 DO I = 0, K - 1 38645 AA = ABS( A( I+J*LDA ) ) 38646 WORK( I+K ) = WORK( I+K ) + AA 38647 S = S + AA 38648 END DO 38649 WORK( J ) = S 38650 END DO 38651 AA = ABS( DBLE( A( 0+J*LDA ) ) ) 38652 S = AA 38653 DO I = 1, K - 1 38654 AA = ABS( A( I+J*LDA ) ) 38655 WORK( I+K ) = WORK( I+K ) + AA 38656 S = S + AA 38657 END DO 38658 WORK( J ) = WORK( J ) + S 38659 DO J = K + 1, N - 1 38660 S = ZERO 38661 DO I = 0, J - 2 - K 38662 AA = ABS( A( I+J*LDA ) ) 38663 WORK( I ) = WORK( I ) + AA 38664 S = S + AA 38665 END DO 38666 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38667 S = S + AA 38668 WORK( J-K-1 ) = WORK( J-K-1 ) + S 38669 I = I + 1 38670 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38671 S = AA 38672 DO L = J + 1, N - 1 38673 I = I + 1 38674 AA = ABS( A( I+J*LDA ) ) 38675 WORK( L ) = WORK( L ) + AA 38676 S = S + AA 38677 END DO 38678 WORK( J ) = WORK( J ) + S 38679 END DO 38680 S = ZERO 38681 DO I = 0, K - 2 38682 AA = ABS( A( I+J*LDA ) ) 38683 WORK( I ) = WORK( I ) + AA 38684 S = S + AA 38685 END DO 38686 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38687 S = S + AA 38688 WORK( I ) = WORK( I ) + S 38689 VALUE = WORK( 0 ) 38690 DO I = 1, N-1 38691 TEMP = WORK( I ) 38692 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38693 $ VALUE = TEMP 38694 END DO 38695 ELSE 38696 DO I = K, N - 1 38697 WORK( I ) = ZERO 38698 END DO 38699 S = ABS( DBLE( A( 0 ) ) ) 38700 DO I = 1, K - 1 38701 AA = ABS( A( I ) ) 38702 WORK( I+K ) = WORK( I+K ) + AA 38703 S = S + AA 38704 END DO 38705 WORK( K ) = WORK( K ) + S 38706 DO J = 1, K - 1 38707 S = ZERO 38708 DO I = 0, J - 2 38709 AA = ABS( A( I+J*LDA ) ) 38710 WORK( I ) = WORK( I ) + AA 38711 S = S + AA 38712 END DO 38713 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38714 S = S + AA 38715 WORK( J-1 ) = S 38716 I = I + 1 38717 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38718 S = AA 38719 DO L = K + J + 1, N - 1 38720 I = I + 1 38721 AA = ABS( A( I+J*LDA ) ) 38722 S = S + AA 38723 WORK( L ) = WORK( L ) + AA 38724 END DO 38725 WORK( K+J ) = WORK( K+J ) + S 38726 END DO 38727 S = ZERO 38728 DO I = 0, K - 2 38729 AA = ABS( A( I+J*LDA ) ) 38730 WORK( I ) = WORK( I ) + AA 38731 S = S + AA 38732 END DO 38733 AA = ABS( DBLE( A( I+J*LDA ) ) ) 38734 S = S + AA 38735 WORK( I ) = S 38736 DO J = K + 1, N 38737 S = ZERO 38738 DO I = 0, K - 1 38739 AA = ABS( A( I+J*LDA ) ) 38740 WORK( I ) = WORK( I ) + AA 38741 S = S + AA 38742 END DO 38743 WORK( J-1 ) = WORK( J-1 ) + S 38744 END DO 38745 VALUE = WORK( 0 ) 38746 DO I = 1, N-1 38747 TEMP = WORK( I ) 38748 IF( VALUE .LT. TEMP .OR. DISNAN( TEMP ) ) 38749 $ VALUE = TEMP 38750 END DO 38751 END IF 38752 END IF 38753 END IF 38754 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 38755 K = ( N+1 ) / 2 38756 SCALE = ZERO 38757 S = ONE 38758 IF( NOE.EQ.1 ) THEN 38759 IF( IFM.EQ.1 ) THEN 38760 IF( ILU.EQ.0 ) THEN 38761 DO J = 0, K - 3 38762 CALL ZLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S ) 38763 END DO 38764 DO J = 0, K - 1 38765 CALL ZLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S ) 38766 END DO 38767 S = S + S 38768 L = K - 1 38769 DO I = 0, K - 2 38770 AA = DBLE( A( L ) ) 38771 IF( AA.NE.ZERO ) THEN 38772 IF( SCALE.LT.AA ) THEN 38773 S = ONE + S*( SCALE / AA )**2 38774 SCALE = AA 38775 ELSE 38776 S = S + ( AA / SCALE )**2 38777 END IF 38778 END IF 38779 AA = DBLE( A( L+1 ) ) 38780 IF( AA.NE.ZERO ) THEN 38781 IF( SCALE.LT.AA ) THEN 38782 S = ONE + S*( SCALE / AA )**2 38783 SCALE = AA 38784 ELSE 38785 S = S + ( AA / SCALE )**2 38786 END IF 38787 END IF 38788 L = L + LDA + 1 38789 END DO 38790 AA = DBLE( A( L ) ) 38791 IF( AA.NE.ZERO ) THEN 38792 IF( SCALE.LT.AA ) THEN 38793 S = ONE + S*( SCALE / AA )**2 38794 SCALE = AA 38795 ELSE 38796 S = S + ( AA / SCALE )**2 38797 END IF 38798 END IF 38799 ELSE 38800 DO J = 0, K - 1 38801 CALL ZLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S ) 38802 END DO 38803 DO J = 1, K - 2 38804 CALL ZLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S ) 38805 END DO 38806 S = S + S 38807 AA = DBLE( A( 0 ) ) 38808 IF( AA.NE.ZERO ) THEN 38809 IF( SCALE.LT.AA ) THEN 38810 S = ONE + S*( SCALE / AA )**2 38811 SCALE = AA 38812 ELSE 38813 S = S + ( AA / SCALE )**2 38814 END IF 38815 END IF 38816 L = LDA 38817 DO I = 1, K - 1 38818 AA = DBLE( A( L ) ) 38819 IF( AA.NE.ZERO ) THEN 38820 IF( SCALE.LT.AA ) THEN 38821 S = ONE + S*( SCALE / AA )**2 38822 SCALE = AA 38823 ELSE 38824 S = S + ( AA / SCALE )**2 38825 END IF 38826 END IF 38827 AA = DBLE( A( L+1 ) ) 38828 IF( AA.NE.ZERO ) THEN 38829 IF( SCALE.LT.AA ) THEN 38830 S = ONE + S*( SCALE / AA )**2 38831 SCALE = AA 38832 ELSE 38833 S = S + ( AA / SCALE )**2 38834 END IF 38835 END IF 38836 L = L + LDA + 1 38837 END DO 38838 END IF 38839 ELSE 38840 IF( ILU.EQ.0 ) THEN 38841 DO J = 1, K - 2 38842 CALL ZLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S ) 38843 END DO 38844 DO J = 0, K - 2 38845 CALL ZLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 38846 END DO 38847 DO J = 0, K - 2 38848 CALL ZLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1, 38849 $ SCALE, S ) 38850 END DO 38851 S = S + S 38852 L = 0 + K*LDA - LDA 38853 AA = DBLE( A( L ) ) 38854 IF( AA.NE.ZERO ) THEN 38855 IF( SCALE.LT.AA ) THEN 38856 S = ONE + S*( SCALE / AA )**2 38857 SCALE = AA 38858 ELSE 38859 S = S + ( AA / SCALE )**2 38860 END IF 38861 END IF 38862 L = L + LDA 38863 DO J = K, N - 1 38864 AA = DBLE( A( L ) ) 38865 IF( AA.NE.ZERO ) THEN 38866 IF( SCALE.LT.AA ) THEN 38867 S = ONE + S*( SCALE / AA )**2 38868 SCALE = AA 38869 ELSE 38870 S = S + ( AA / SCALE )**2 38871 END IF 38872 END IF 38873 AA = DBLE( A( L+1 ) ) 38874 IF( AA.NE.ZERO ) THEN 38875 IF( SCALE.LT.AA ) THEN 38876 S = ONE + S*( SCALE / AA )**2 38877 SCALE = AA 38878 ELSE 38879 S = S + ( AA / SCALE )**2 38880 END IF 38881 END IF 38882 L = L + LDA + 1 38883 END DO 38884 ELSE 38885 DO J = 1, K - 1 38886 CALL ZLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) 38887 END DO 38888 DO J = K, N - 1 38889 CALL ZLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 38890 END DO 38891 DO J = 0, K - 3 38892 CALL ZLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S ) 38893 END DO 38894 S = S + S 38895 L = 0 38896 DO I = 0, K - 2 38897 AA = DBLE( A( L ) ) 38898 IF( AA.NE.ZERO ) THEN 38899 IF( SCALE.LT.AA ) THEN 38900 S = ONE + S*( SCALE / AA )**2 38901 SCALE = AA 38902 ELSE 38903 S = S + ( AA / SCALE )**2 38904 END IF 38905 END IF 38906 AA = DBLE( A( L+1 ) ) 38907 IF( AA.NE.ZERO ) THEN 38908 IF( SCALE.LT.AA ) THEN 38909 S = ONE + S*( SCALE / AA )**2 38910 SCALE = AA 38911 ELSE 38912 S = S + ( AA / SCALE )**2 38913 END IF 38914 END IF 38915 L = L + LDA + 1 38916 END DO 38917 AA = DBLE( A( L ) ) 38918 IF( AA.NE.ZERO ) THEN 38919 IF( SCALE.LT.AA ) THEN 38920 S = ONE + S*( SCALE / AA )**2 38921 SCALE = AA 38922 ELSE 38923 S = S + ( AA / SCALE )**2 38924 END IF 38925 END IF 38926 END IF 38927 END IF 38928 ELSE 38929 IF( IFM.EQ.1 ) THEN 38930 IF( ILU.EQ.0 ) THEN 38931 DO J = 0, K - 2 38932 CALL ZLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S ) 38933 END DO 38934 DO J = 0, K - 1 38935 CALL ZLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S ) 38936 END DO 38937 S = S + S 38938 L = K 38939 DO I = 0, K - 1 38940 AA = DBLE( A( L ) ) 38941 IF( AA.NE.ZERO ) THEN 38942 IF( SCALE.LT.AA ) THEN 38943 S = ONE + S*( SCALE / AA )**2 38944 SCALE = AA 38945 ELSE 38946 S = S + ( AA / SCALE )**2 38947 END IF 38948 END IF 38949 AA = DBLE( A( L+1 ) ) 38950 IF( AA.NE.ZERO ) THEN 38951 IF( SCALE.LT.AA ) THEN 38952 S = ONE + S*( SCALE / AA )**2 38953 SCALE = AA 38954 ELSE 38955 S = S + ( AA / SCALE )**2 38956 END IF 38957 END IF 38958 L = L + LDA + 1 38959 END DO 38960 ELSE 38961 DO J = 0, K - 1 38962 CALL ZLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S ) 38963 END DO 38964 DO J = 1, K - 1 38965 CALL ZLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) 38966 END DO 38967 S = S + S 38968 L = 0 38969 DO I = 0, K - 1 38970 AA = DBLE( A( L ) ) 38971 IF( AA.NE.ZERO ) THEN 38972 IF( SCALE.LT.AA ) THEN 38973 S = ONE + S*( SCALE / AA )**2 38974 SCALE = AA 38975 ELSE 38976 S = S + ( AA / SCALE )**2 38977 END IF 38978 END IF 38979 AA = DBLE( A( L+1 ) ) 38980 IF( AA.NE.ZERO ) THEN 38981 IF( SCALE.LT.AA ) THEN 38982 S = ONE + S*( SCALE / AA )**2 38983 SCALE = AA 38984 ELSE 38985 S = S + ( AA / SCALE )**2 38986 END IF 38987 END IF 38988 L = L + LDA + 1 38989 END DO 38990 END IF 38991 ELSE 38992 IF( ILU.EQ.0 ) THEN 38993 DO J = 1, K - 1 38994 CALL ZLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S ) 38995 END DO 38996 DO J = 0, K - 1 38997 CALL ZLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 38998 END DO 38999 DO J = 0, K - 2 39000 CALL ZLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE, 39001 $ S ) 39002 END DO 39003 S = S + S 39004 L = 0 + K*LDA 39005 AA = DBLE( A( L ) ) 39006 IF( AA.NE.ZERO ) THEN 39007 IF( SCALE.LT.AA ) THEN 39008 S = ONE + S*( SCALE / AA )**2 39009 SCALE = AA 39010 ELSE 39011 S = S + ( AA / SCALE )**2 39012 END IF 39013 END IF 39014 L = L + LDA 39015 DO J = K + 1, N - 1 39016 AA = DBLE( A( L ) ) 39017 IF( AA.NE.ZERO ) THEN 39018 IF( SCALE.LT.AA ) THEN 39019 S = ONE + S*( SCALE / AA )**2 39020 SCALE = AA 39021 ELSE 39022 S = S + ( AA / SCALE )**2 39023 END IF 39024 END IF 39025 AA = DBLE( A( L+1 ) ) 39026 IF( AA.NE.ZERO ) THEN 39027 IF( SCALE.LT.AA ) THEN 39028 S = ONE + S*( SCALE / AA )**2 39029 SCALE = AA 39030 ELSE 39031 S = S + ( AA / SCALE )**2 39032 END IF 39033 END IF 39034 L = L + LDA + 1 39035 END DO 39036 AA = DBLE( A( L ) ) 39037 IF( AA.NE.ZERO ) THEN 39038 IF( SCALE.LT.AA ) THEN 39039 S = ONE + S*( SCALE / AA )**2 39040 SCALE = AA 39041 ELSE 39042 S = S + ( AA / SCALE )**2 39043 END IF 39044 END IF 39045 ELSE 39046 DO J = 1, K - 1 39047 CALL ZLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S ) 39048 END DO 39049 DO J = K + 1, N 39050 CALL ZLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) 39051 END DO 39052 DO J = 0, K - 2 39053 CALL ZLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S ) 39054 END DO 39055 S = S + S 39056 L = 0 39057 AA = DBLE( A( L ) ) 39058 IF( AA.NE.ZERO ) THEN 39059 IF( SCALE.LT.AA ) THEN 39060 S = ONE + S*( SCALE / AA )**2 39061 SCALE = AA 39062 ELSE 39063 S = S + ( AA / SCALE )**2 39064 END IF 39065 END IF 39066 L = LDA 39067 DO I = 0, K - 2 39068 AA = DBLE( A( L ) ) 39069 IF( AA.NE.ZERO ) THEN 39070 IF( SCALE.LT.AA ) THEN 39071 S = ONE + S*( SCALE / AA )**2 39072 SCALE = AA 39073 ELSE 39074 S = S + ( AA / SCALE )**2 39075 END IF 39076 END IF 39077 AA = DBLE( A( L+1 ) ) 39078 IF( AA.NE.ZERO ) THEN 39079 IF( SCALE.LT.AA ) THEN 39080 S = ONE + S*( SCALE / AA )**2 39081 SCALE = AA 39082 ELSE 39083 S = S + ( AA / SCALE )**2 39084 END IF 39085 END IF 39086 L = L + LDA + 1 39087 END DO 39088 AA = DBLE( A( L ) ) 39089 IF( AA.NE.ZERO ) THEN 39090 IF( SCALE.LT.AA ) THEN 39091 S = ONE + S*( SCALE / AA )**2 39092 SCALE = AA 39093 ELSE 39094 S = S + ( AA / SCALE )**2 39095 END IF 39096 END IF 39097 END IF 39098 END IF 39099 END IF 39100 VALUE = SCALE*SQRT( S ) 39101 END IF 39102 ZLANHF = VALUE 39103 RETURN 39104 END 39105! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlanhp.f 39106 DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK ) 39107 IMPLICIT NONE 39108 CHARACTER NORM, UPLO 39109 INTEGER N 39110 DOUBLE PRECISION WORK( * ) 39111 COMPLEX*16 AP( * ) 39112 DOUBLE PRECISION ONE, ZERO 39113 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 39114 INTEGER I, J, K 39115 DOUBLE PRECISION ABSA, SUM, VALUE 39116 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 39117 LOGICAL LSAME, DISNAN 39118 EXTERNAL LSAME, DISNAN 39119 EXTERNAL ZLASSQ, DCOMBSSQ 39120 INTRINSIC ABS, DBLE, SQRT 39121 IF( N.EQ.0 ) THEN 39122 VALUE = ZERO 39123 ELSE IF( LSAME( NORM, 'M' ) ) THEN 39124 VALUE = ZERO 39125 IF( LSAME( UPLO, 'U' ) ) THEN 39126 K = 0 39127 DO 20 J = 1, N 39128 DO 10 I = K + 1, K + J - 1 39129 SUM = ABS( AP( I ) ) 39130 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39131 10 CONTINUE 39132 K = K + J 39133 SUM = ABS( DBLE( AP( K ) ) ) 39134 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39135 20 CONTINUE 39136 ELSE 39137 K = 1 39138 DO 40 J = 1, N 39139 SUM = ABS( DBLE( AP( K ) ) ) 39140 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39141 DO 30 I = K + 1, K + N - J 39142 SUM = ABS( AP( I ) ) 39143 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39144 30 CONTINUE 39145 K = K + N - J + 1 39146 40 CONTINUE 39147 END IF 39148 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 39149 $ ( NORM.EQ.'1' ) ) THEN 39150 VALUE = ZERO 39151 K = 1 39152 IF( LSAME( UPLO, 'U' ) ) THEN 39153 DO 60 J = 1, N 39154 SUM = ZERO 39155 DO 50 I = 1, J - 1 39156 ABSA = ABS( AP( K ) ) 39157 SUM = SUM + ABSA 39158 WORK( I ) = WORK( I ) + ABSA 39159 K = K + 1 39160 50 CONTINUE 39161 WORK( J ) = SUM + ABS( DBLE( AP( K ) ) ) 39162 K = K + 1 39163 60 CONTINUE 39164 DO 70 I = 1, N 39165 SUM = WORK( I ) 39166 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39167 70 CONTINUE 39168 ELSE 39169 DO 80 I = 1, N 39170 WORK( I ) = ZERO 39171 80 CONTINUE 39172 DO 100 J = 1, N 39173 SUM = WORK( J ) + ABS( DBLE( AP( K ) ) ) 39174 K = K + 1 39175 DO 90 I = J + 1, N 39176 ABSA = ABS( AP( K ) ) 39177 SUM = SUM + ABSA 39178 WORK( I ) = WORK( I ) + ABSA 39179 K = K + 1 39180 90 CONTINUE 39181 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39182 100 CONTINUE 39183 END IF 39184 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 39185 SSQ( 1 ) = ZERO 39186 SSQ( 2 ) = ONE 39187 K = 2 39188 IF( LSAME( UPLO, 'U' ) ) THEN 39189 DO 110 J = 2, N 39190 COLSSQ( 1 ) = ZERO 39191 COLSSQ( 2 ) = ONE 39192 CALL ZLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 39193 CALL DCOMBSSQ( SSQ, COLSSQ ) 39194 K = K + J 39195 110 CONTINUE 39196 ELSE 39197 DO 120 J = 1, N - 1 39198 COLSSQ( 1 ) = ZERO 39199 COLSSQ( 2 ) = ONE 39200 CALL ZLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 39201 CALL DCOMBSSQ( SSQ, COLSSQ ) 39202 K = K + N - J + 1 39203 120 CONTINUE 39204 END IF 39205 SSQ( 2 ) = 2*SSQ( 2 ) 39206 K = 1 39207 COLSSQ( 1 ) = ZERO 39208 COLSSQ( 2 ) = ONE 39209 DO 130 I = 1, N 39210 IF( DBLE( AP( K ) ).NE.ZERO ) THEN 39211 ABSA = ABS( DBLE( AP( K ) ) ) 39212 IF( COLSSQ( 1 ).LT.ABSA ) THEN 39213 COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 39214 COLSSQ( 1 ) = ABSA 39215 ELSE 39216 COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 39217 END IF 39218 END IF 39219 IF( LSAME( UPLO, 'U' ) ) THEN 39220 K = K + I + 1 39221 ELSE 39222 K = K + N - I + 1 39223 END IF 39224 130 CONTINUE 39225 CALL DCOMBSSQ( SSQ, COLSSQ ) 39226 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 39227 END IF 39228 ZLANHP = VALUE 39229 RETURN 39230 END 39231! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlanhs.f 39232 DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) 39233 IMPLICIT NONE 39234 CHARACTER NORM 39235 INTEGER LDA, N 39236 DOUBLE PRECISION WORK( * ) 39237 COMPLEX*16 A( LDA, * ) 39238 DOUBLE PRECISION ONE, ZERO 39239 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 39240 INTEGER I, J 39241 DOUBLE PRECISION SUM, VALUE 39242 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 39243 LOGICAL LSAME, DISNAN 39244 EXTERNAL LSAME, DISNAN 39245 EXTERNAL ZLASSQ, DCOMBSSQ 39246 INTRINSIC ABS, MIN, SQRT 39247 IF( N.EQ.0 ) THEN 39248 VALUE = ZERO 39249 ELSE IF( LSAME( NORM, 'M' ) ) THEN 39250 VALUE = ZERO 39251 DO 20 J = 1, N 39252 DO 10 I = 1, MIN( N, J+1 ) 39253 SUM = ABS( A( I, J ) ) 39254 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39255 10 CONTINUE 39256 20 CONTINUE 39257 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 39258 VALUE = ZERO 39259 DO 40 J = 1, N 39260 SUM = ZERO 39261 DO 30 I = 1, MIN( N, J+1 ) 39262 SUM = SUM + ABS( A( I, J ) ) 39263 30 CONTINUE 39264 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39265 40 CONTINUE 39266 ELSE IF( LSAME( NORM, 'I' ) ) THEN 39267 DO 50 I = 1, N 39268 WORK( I ) = ZERO 39269 50 CONTINUE 39270 DO 70 J = 1, N 39271 DO 60 I = 1, MIN( N, J+1 ) 39272 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 39273 60 CONTINUE 39274 70 CONTINUE 39275 VALUE = ZERO 39276 DO 80 I = 1, N 39277 SUM = WORK( I ) 39278 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39279 80 CONTINUE 39280 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 39281 SSQ( 1 ) = ZERO 39282 SSQ( 2 ) = ONE 39283 DO 90 J = 1, N 39284 COLSSQ( 1 ) = ZERO 39285 COLSSQ( 2 ) = ONE 39286 CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, 39287 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 39288 CALL DCOMBSSQ( SSQ, COLSSQ ) 39289 90 CONTINUE 39290 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 39291 END IF 39292 ZLANHS = VALUE 39293 RETURN 39294 END 39295! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlanht.f 39296 DOUBLE PRECISION FUNCTION ZLANHT( NORM, N, D, E ) 39297 CHARACTER NORM 39298 INTEGER N 39299 DOUBLE PRECISION D( * ) 39300 COMPLEX*16 E( * ) 39301 DOUBLE PRECISION ONE, ZERO 39302 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 39303 INTEGER I 39304 DOUBLE PRECISION ANORM, SCALE, SUM 39305 LOGICAL LSAME, DISNAN 39306 EXTERNAL LSAME, DISNAN 39307 EXTERNAL DLASSQ, ZLASSQ 39308 INTRINSIC ABS, MAX, SQRT 39309 IF( N.LE.0 ) THEN 39310 ANORM = ZERO 39311 ELSE IF( LSAME( NORM, 'M' ) ) THEN 39312 ANORM = ABS( D( N ) ) 39313 DO 10 I = 1, N - 1 39314 SUM = ABS( D( I ) ) 39315 IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 39316 SUM = ABS( E( I ) ) 39317 IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 39318 10 CONTINUE 39319 ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. 39320 $ LSAME( NORM, 'I' ) ) THEN 39321 IF( N.EQ.1 ) THEN 39322 ANORM = ABS( D( 1 ) ) 39323 ELSE 39324 ANORM = ABS( D( 1 ) )+ABS( E( 1 ) ) 39325 SUM = ABS( E( N-1 ) )+ABS( D( N ) ) 39326 IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 39327 DO 20 I = 2, N - 1 39328 SUM = ABS( D( I ) )+ABS( E( I ) )+ABS( E( I-1 ) ) 39329 IF( ANORM .LT. SUM .OR. DISNAN( SUM ) ) ANORM = SUM 39330 20 CONTINUE 39331 END IF 39332 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 39333 SCALE = ZERO 39334 SUM = ONE 39335 IF( N.GT.1 ) THEN 39336 CALL ZLASSQ( N-1, E, 1, SCALE, SUM ) 39337 SUM = 2*SUM 39338 END IF 39339 CALL DLASSQ( N, D, 1, SCALE, SUM ) 39340 ANORM = SCALE*SQRT( SUM ) 39341 END IF 39342 ZLANHT = ANORM 39343 RETURN 39344 END 39345! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlansb.f 39346 DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, 39347 $ WORK ) 39348 IMPLICIT NONE 39349 CHARACTER NORM, UPLO 39350 INTEGER K, LDAB, N 39351 DOUBLE PRECISION WORK( * ) 39352 COMPLEX*16 AB( LDAB, * ) 39353 DOUBLE PRECISION ONE, ZERO 39354 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 39355 INTEGER I, J, L 39356 DOUBLE PRECISION ABSA, SUM, VALUE 39357 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 39358 LOGICAL LSAME, DISNAN 39359 EXTERNAL LSAME, DISNAN 39360 EXTERNAL ZLASSQ, DCOMBSSQ 39361 INTRINSIC ABS, MAX, MIN, SQRT 39362 IF( N.EQ.0 ) THEN 39363 VALUE = ZERO 39364 ELSE IF( LSAME( NORM, 'M' ) ) THEN 39365 VALUE = ZERO 39366 IF( LSAME( UPLO, 'U' ) ) THEN 39367 DO 20 J = 1, N 39368 DO 10 I = MAX( K+2-J, 1 ), K + 1 39369 SUM = ABS( AB( I, J ) ) 39370 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39371 10 CONTINUE 39372 20 CONTINUE 39373 ELSE 39374 DO 40 J = 1, N 39375 DO 30 I = 1, MIN( N+1-J, K+1 ) 39376 SUM = ABS( AB( I, J ) ) 39377 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39378 30 CONTINUE 39379 40 CONTINUE 39380 END IF 39381 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 39382 $ ( NORM.EQ.'1' ) ) THEN 39383 VALUE = ZERO 39384 IF( LSAME( UPLO, 'U' ) ) THEN 39385 DO 60 J = 1, N 39386 SUM = ZERO 39387 L = K + 1 - J 39388 DO 50 I = MAX( 1, J-K ), J - 1 39389 ABSA = ABS( AB( L+I, J ) ) 39390 SUM = SUM + ABSA 39391 WORK( I ) = WORK( I ) + ABSA 39392 50 CONTINUE 39393 WORK( J ) = SUM + ABS( AB( K+1, J ) ) 39394 60 CONTINUE 39395 DO 70 I = 1, N 39396 SUM = WORK( I ) 39397 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39398 70 CONTINUE 39399 ELSE 39400 DO 80 I = 1, N 39401 WORK( I ) = ZERO 39402 80 CONTINUE 39403 DO 100 J = 1, N 39404 SUM = WORK( J ) + ABS( AB( 1, J ) ) 39405 L = 1 - J 39406 DO 90 I = J + 1, MIN( N, J+K ) 39407 ABSA = ABS( AB( L+I, J ) ) 39408 SUM = SUM + ABSA 39409 WORK( I ) = WORK( I ) + ABSA 39410 90 CONTINUE 39411 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39412 100 CONTINUE 39413 END IF 39414 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 39415 SSQ( 1 ) = ZERO 39416 SSQ( 2 ) = ONE 39417 IF( K.GT.0 ) THEN 39418 IF( LSAME( UPLO, 'U' ) ) THEN 39419 DO 110 J = 2, N 39420 COLSSQ( 1 ) = ZERO 39421 COLSSQ( 2 ) = ONE 39422 CALL ZLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ), 39423 $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 39424 CALL DCOMBSSQ( SSQ, COLSSQ ) 39425 110 CONTINUE 39426 L = K + 1 39427 ELSE 39428 DO 120 J = 1, N - 1 39429 COLSSQ( 1 ) = ZERO 39430 COLSSQ( 2 ) = ONE 39431 CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, 39432 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 39433 CALL DCOMBSSQ( SSQ, COLSSQ ) 39434 120 CONTINUE 39435 L = 1 39436 END IF 39437 SSQ( 2 ) = 2*SSQ( 2 ) 39438 ELSE 39439 L = 1 39440 END IF 39441 COLSSQ( 1 ) = ZERO 39442 COLSSQ( 2 ) = ONE 39443 CALL ZLASSQ( N, AB( L, 1 ), LDAB, COLSSQ( 1 ), COLSSQ( 2 ) ) 39444 CALL DCOMBSSQ( SSQ, COLSSQ ) 39445 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 39446 END IF 39447 ZLANSB = VALUE 39448 RETURN 39449 END 39450! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlansp.f 39451 DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK ) 39452 IMPLICIT NONE 39453 CHARACTER NORM, UPLO 39454 INTEGER N 39455 DOUBLE PRECISION WORK( * ) 39456 COMPLEX*16 AP( * ) 39457 DOUBLE PRECISION ONE, ZERO 39458 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 39459 INTEGER I, J, K 39460 DOUBLE PRECISION ABSA, SUM, VALUE 39461 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 39462 LOGICAL LSAME, DISNAN 39463 EXTERNAL LSAME, DISNAN 39464 EXTERNAL ZLASSQ, DCOMBSSQ 39465 INTRINSIC ABS, DBLE, DIMAG, SQRT 39466 IF( N.EQ.0 ) THEN 39467 VALUE = ZERO 39468 ELSE IF( LSAME( NORM, 'M' ) ) THEN 39469 VALUE = ZERO 39470 IF( LSAME( UPLO, 'U' ) ) THEN 39471 K = 1 39472 DO 20 J = 1, N 39473 DO 10 I = K, K + J - 1 39474 SUM = ABS( AP( I ) ) 39475 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39476 10 CONTINUE 39477 K = K + J 39478 20 CONTINUE 39479 ELSE 39480 K = 1 39481 DO 40 J = 1, N 39482 DO 30 I = K, K + N - J 39483 SUM = ABS( AP( I ) ) 39484 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39485 30 CONTINUE 39486 K = K + N - J + 1 39487 40 CONTINUE 39488 END IF 39489 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 39490 $ ( NORM.EQ.'1' ) ) THEN 39491 VALUE = ZERO 39492 K = 1 39493 IF( LSAME( UPLO, 'U' ) ) THEN 39494 DO 60 J = 1, N 39495 SUM = ZERO 39496 DO 50 I = 1, J - 1 39497 ABSA = ABS( AP( K ) ) 39498 SUM = SUM + ABSA 39499 WORK( I ) = WORK( I ) + ABSA 39500 K = K + 1 39501 50 CONTINUE 39502 WORK( J ) = SUM + ABS( AP( K ) ) 39503 K = K + 1 39504 60 CONTINUE 39505 DO 70 I = 1, N 39506 SUM = WORK( I ) 39507 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39508 70 CONTINUE 39509 ELSE 39510 DO 80 I = 1, N 39511 WORK( I ) = ZERO 39512 80 CONTINUE 39513 DO 100 J = 1, N 39514 SUM = WORK( J ) + ABS( AP( K ) ) 39515 K = K + 1 39516 DO 90 I = J + 1, N 39517 ABSA = ABS( AP( K ) ) 39518 SUM = SUM + ABSA 39519 WORK( I ) = WORK( I ) + ABSA 39520 K = K + 1 39521 90 CONTINUE 39522 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39523 100 CONTINUE 39524 END IF 39525 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 39526 SSQ( 1 ) = ZERO 39527 SSQ( 2 ) = ONE 39528 K = 2 39529 IF( LSAME( UPLO, 'U' ) ) THEN 39530 DO 110 J = 2, N 39531 COLSSQ( 1 ) = ZERO 39532 COLSSQ( 2 ) = ONE 39533 CALL ZLASSQ( J-1, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 39534 CALL DCOMBSSQ( SSQ, COLSSQ ) 39535 K = K + J 39536 110 CONTINUE 39537 ELSE 39538 DO 120 J = 1, N - 1 39539 COLSSQ( 1 ) = ZERO 39540 COLSSQ( 2 ) = ONE 39541 CALL ZLASSQ( N-J, AP( K ), 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 39542 CALL DCOMBSSQ( SSQ, COLSSQ ) 39543 K = K + N - J + 1 39544 120 CONTINUE 39545 END IF 39546 SSQ( 2 ) = 2*SSQ( 2 ) 39547 K = 1 39548 COLSSQ( 1 ) = ZERO 39549 COLSSQ( 2 ) = ONE 39550 DO 130 I = 1, N 39551 IF( DBLE( AP( K ) ).NE.ZERO ) THEN 39552 ABSA = ABS( DBLE( AP( K ) ) ) 39553 IF( COLSSQ( 1 ).LT.ABSA ) THEN 39554 COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 39555 COLSSQ( 1 ) = ABSA 39556 ELSE 39557 COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 39558 END IF 39559 END IF 39560 IF( DIMAG( AP( K ) ).NE.ZERO ) THEN 39561 ABSA = ABS( DIMAG( AP( K ) ) ) 39562 IF( COLSSQ( 1 ).LT.ABSA ) THEN 39563 COLSSQ( 2 ) = ONE + COLSSQ(2)*( COLSSQ(1) / ABSA )**2 39564 COLSSQ( 1 ) = ABSA 39565 ELSE 39566 COLSSQ( 2 ) = COLSSQ( 2 ) + ( ABSA / COLSSQ( 1 ) )**2 39567 END IF 39568 END IF 39569 IF( LSAME( UPLO, 'U' ) ) THEN 39570 K = K + I + 1 39571 ELSE 39572 K = K + N - I + 1 39573 END IF 39574 130 CONTINUE 39575 CALL DCOMBSSQ( SSQ, COLSSQ ) 39576 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 39577 END IF 39578 ZLANSP = VALUE 39579 RETURN 39580 END 39581! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlansy.f 39582 DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK ) 39583 IMPLICIT NONE 39584 CHARACTER NORM, UPLO 39585 INTEGER LDA, N 39586 DOUBLE PRECISION WORK( * ) 39587 COMPLEX*16 A( LDA, * ) 39588 DOUBLE PRECISION ONE, ZERO 39589 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 39590 INTEGER I, J 39591 DOUBLE PRECISION ABSA, SUM, VALUE 39592 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 39593 LOGICAL LSAME, DISNAN 39594 EXTERNAL LSAME, DISNAN 39595 EXTERNAL ZLASSQ, DCOMBSSQ 39596 INTRINSIC ABS, SQRT 39597 IF( N.EQ.0 ) THEN 39598 VALUE = ZERO 39599 ELSE IF( LSAME( NORM, 'M' ) ) THEN 39600 VALUE = ZERO 39601 IF( LSAME( UPLO, 'U' ) ) THEN 39602 DO 20 J = 1, N 39603 DO 10 I = 1, J 39604 SUM = ABS( A( I, J ) ) 39605 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39606 10 CONTINUE 39607 20 CONTINUE 39608 ELSE 39609 DO 40 J = 1, N 39610 DO 30 I = J, N 39611 SUM = ABS( A( I, J ) ) 39612 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39613 30 CONTINUE 39614 40 CONTINUE 39615 END IF 39616 ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. 39617 $ ( NORM.EQ.'1' ) ) THEN 39618 VALUE = ZERO 39619 IF( LSAME( UPLO, 'U' ) ) THEN 39620 DO 60 J = 1, N 39621 SUM = ZERO 39622 DO 50 I = 1, J - 1 39623 ABSA = ABS( A( I, J ) ) 39624 SUM = SUM + ABSA 39625 WORK( I ) = WORK( I ) + ABSA 39626 50 CONTINUE 39627 WORK( J ) = SUM + ABS( A( J, J ) ) 39628 60 CONTINUE 39629 DO 70 I = 1, N 39630 SUM = WORK( I ) 39631 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39632 70 CONTINUE 39633 ELSE 39634 DO 80 I = 1, N 39635 WORK( I ) = ZERO 39636 80 CONTINUE 39637 DO 100 J = 1, N 39638 SUM = WORK( J ) + ABS( A( J, J ) ) 39639 DO 90 I = J + 1, N 39640 ABSA = ABS( A( I, J ) ) 39641 SUM = SUM + ABSA 39642 WORK( I ) = WORK( I ) + ABSA 39643 90 CONTINUE 39644 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39645 100 CONTINUE 39646 END IF 39647 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 39648 SSQ( 1 ) = ZERO 39649 SSQ( 2 ) = ONE 39650 IF( LSAME( UPLO, 'U' ) ) THEN 39651 DO 110 J = 2, N 39652 COLSSQ( 1 ) = ZERO 39653 COLSSQ( 2 ) = ONE 39654 CALL ZLASSQ( J-1, A( 1, J ), 1, COLSSQ(1), COLSSQ(2) ) 39655 CALL DCOMBSSQ( SSQ, COLSSQ ) 39656 110 CONTINUE 39657 ELSE 39658 DO 120 J = 1, N - 1 39659 COLSSQ( 1 ) = ZERO 39660 COLSSQ( 2 ) = ONE 39661 CALL ZLASSQ( N-J, A( J+1, J ), 1, COLSSQ(1), COLSSQ(2) ) 39662 CALL DCOMBSSQ( SSQ, COLSSQ ) 39663 120 CONTINUE 39664 END IF 39665 SSQ( 2 ) = 2*SSQ( 2 ) 39666 COLSSQ( 1 ) = ZERO 39667 COLSSQ( 2 ) = ONE 39668 CALL ZLASSQ( N, A, LDA+1, COLSSQ( 1 ), COLSSQ( 2 ) ) 39669 CALL DCOMBSSQ( SSQ, COLSSQ ) 39670 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 39671 END IF 39672 ZLANSY = VALUE 39673 RETURN 39674 END 39675! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlantb.f 39676 DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, 39677 $ LDAB, WORK ) 39678 IMPLICIT NONE 39679 CHARACTER DIAG, NORM, UPLO 39680 INTEGER K, LDAB, N 39681 DOUBLE PRECISION WORK( * ) 39682 COMPLEX*16 AB( LDAB, * ) 39683 DOUBLE PRECISION ONE, ZERO 39684 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 39685 LOGICAL UDIAG 39686 INTEGER I, J, L 39687 DOUBLE PRECISION SUM, VALUE 39688 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 39689 LOGICAL LSAME, DISNAN 39690 EXTERNAL LSAME, DISNAN 39691 EXTERNAL ZLASSQ, DCOMBSSQ 39692 INTRINSIC ABS, MAX, MIN, SQRT 39693 IF( N.EQ.0 ) THEN 39694 VALUE = ZERO 39695 ELSE IF( LSAME( NORM, 'M' ) ) THEN 39696 IF( LSAME( DIAG, 'U' ) ) THEN 39697 VALUE = ONE 39698 IF( LSAME( UPLO, 'U' ) ) THEN 39699 DO 20 J = 1, N 39700 DO 10 I = MAX( K+2-J, 1 ), K 39701 SUM = ABS( AB( I, J ) ) 39702 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39703 10 CONTINUE 39704 20 CONTINUE 39705 ELSE 39706 DO 40 J = 1, N 39707 DO 30 I = 2, MIN( N+1-J, K+1 ) 39708 SUM = ABS( AB( I, J ) ) 39709 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39710 30 CONTINUE 39711 40 CONTINUE 39712 END IF 39713 ELSE 39714 VALUE = ZERO 39715 IF( LSAME( UPLO, 'U' ) ) THEN 39716 DO 60 J = 1, N 39717 DO 50 I = MAX( K+2-J, 1 ), K + 1 39718 SUM = ABS( AB( I, J ) ) 39719 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39720 50 CONTINUE 39721 60 CONTINUE 39722 ELSE 39723 DO 80 J = 1, N 39724 DO 70 I = 1, MIN( N+1-J, K+1 ) 39725 SUM = ABS( AB( I, J ) ) 39726 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39727 70 CONTINUE 39728 80 CONTINUE 39729 END IF 39730 END IF 39731 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 39732 VALUE = ZERO 39733 UDIAG = LSAME( DIAG, 'U' ) 39734 IF( LSAME( UPLO, 'U' ) ) THEN 39735 DO 110 J = 1, N 39736 IF( UDIAG ) THEN 39737 SUM = ONE 39738 DO 90 I = MAX( K+2-J, 1 ), K 39739 SUM = SUM + ABS( AB( I, J ) ) 39740 90 CONTINUE 39741 ELSE 39742 SUM = ZERO 39743 DO 100 I = MAX( K+2-J, 1 ), K + 1 39744 SUM = SUM + ABS( AB( I, J ) ) 39745 100 CONTINUE 39746 END IF 39747 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39748 110 CONTINUE 39749 ELSE 39750 DO 140 J = 1, N 39751 IF( UDIAG ) THEN 39752 SUM = ONE 39753 DO 120 I = 2, MIN( N+1-J, K+1 ) 39754 SUM = SUM + ABS( AB( I, J ) ) 39755 120 CONTINUE 39756 ELSE 39757 SUM = ZERO 39758 DO 130 I = 1, MIN( N+1-J, K+1 ) 39759 SUM = SUM + ABS( AB( I, J ) ) 39760 130 CONTINUE 39761 END IF 39762 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39763 140 CONTINUE 39764 END IF 39765 ELSE IF( LSAME( NORM, 'I' ) ) THEN 39766 VALUE = ZERO 39767 IF( LSAME( UPLO, 'U' ) ) THEN 39768 IF( LSAME( DIAG, 'U' ) ) THEN 39769 DO 150 I = 1, N 39770 WORK( I ) = ONE 39771 150 CONTINUE 39772 DO 170 J = 1, N 39773 L = K + 1 - J 39774 DO 160 I = MAX( 1, J-K ), J - 1 39775 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 39776 160 CONTINUE 39777 170 CONTINUE 39778 ELSE 39779 DO 180 I = 1, N 39780 WORK( I ) = ZERO 39781 180 CONTINUE 39782 DO 200 J = 1, N 39783 L = K + 1 - J 39784 DO 190 I = MAX( 1, J-K ), J 39785 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 39786 190 CONTINUE 39787 200 CONTINUE 39788 END IF 39789 ELSE 39790 IF( LSAME( DIAG, 'U' ) ) THEN 39791 DO 210 I = 1, N 39792 WORK( I ) = ONE 39793 210 CONTINUE 39794 DO 230 J = 1, N 39795 L = 1 - J 39796 DO 220 I = J + 1, MIN( N, J+K ) 39797 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 39798 220 CONTINUE 39799 230 CONTINUE 39800 ELSE 39801 DO 240 I = 1, N 39802 WORK( I ) = ZERO 39803 240 CONTINUE 39804 DO 260 J = 1, N 39805 L = 1 - J 39806 DO 250 I = J, MIN( N, J+K ) 39807 WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) ) 39808 250 CONTINUE 39809 260 CONTINUE 39810 END IF 39811 END IF 39812 DO 270 I = 1, N 39813 SUM = WORK( I ) 39814 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39815 270 CONTINUE 39816 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 39817 IF( LSAME( UPLO, 'U' ) ) THEN 39818 IF( LSAME( DIAG, 'U' ) ) THEN 39819 SSQ( 1 ) = ONE 39820 SSQ( 2 ) = N 39821 IF( K.GT.0 ) THEN 39822 DO 280 J = 2, N 39823 COLSSQ( 1 ) = ZERO 39824 COLSSQ( 2 ) = ONE 39825 CALL ZLASSQ( MIN( J-1, K ), 39826 $ AB( MAX( K+2-J, 1 ), J ), 1, 39827 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 39828 CALL DCOMBSSQ( SSQ, COLSSQ ) 39829 280 CONTINUE 39830 END IF 39831 ELSE 39832 SSQ( 1 ) = ZERO 39833 SSQ( 2 ) = ONE 39834 DO 290 J = 1, N 39835 COLSSQ( 1 ) = ZERO 39836 COLSSQ( 2 ) = ONE 39837 CALL ZLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ), 39838 $ 1, COLSSQ( 1 ), COLSSQ( 2 ) ) 39839 CALL DCOMBSSQ( SSQ, COLSSQ ) 39840 290 CONTINUE 39841 END IF 39842 ELSE 39843 IF( LSAME( DIAG, 'U' ) ) THEN 39844 SSQ( 1 ) = ONE 39845 SSQ( 2 ) = N 39846 IF( K.GT.0 ) THEN 39847 DO 300 J = 1, N - 1 39848 COLSSQ( 1 ) = ZERO 39849 COLSSQ( 2 ) = ONE 39850 CALL ZLASSQ( MIN( N-J, K ), AB( 2, J ), 1, 39851 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 39852 CALL DCOMBSSQ( SSQ, COLSSQ ) 39853 300 CONTINUE 39854 END IF 39855 ELSE 39856 SSQ( 1 ) = ZERO 39857 SSQ( 2 ) = ONE 39858 DO 310 J = 1, N 39859 COLSSQ( 1 ) = ZERO 39860 COLSSQ( 2 ) = ONE 39861 CALL ZLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, 39862 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 39863 CALL DCOMBSSQ( SSQ, COLSSQ ) 39864 310 CONTINUE 39865 END IF 39866 END IF 39867 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 39868 END IF 39869 ZLANTB = VALUE 39870 RETURN 39871 END 39872! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlantp.f 39873 DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK ) 39874 IMPLICIT NONE 39875 CHARACTER DIAG, NORM, UPLO 39876 INTEGER N 39877 DOUBLE PRECISION WORK( * ) 39878 COMPLEX*16 AP( * ) 39879 DOUBLE PRECISION ONE, ZERO 39880 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 39881 LOGICAL UDIAG 39882 INTEGER I, J, K 39883 DOUBLE PRECISION SUM, VALUE 39884 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 39885 LOGICAL LSAME, DISNAN 39886 EXTERNAL LSAME, DISNAN 39887 EXTERNAL ZLASSQ, DCOMBSSQ 39888 INTRINSIC ABS, SQRT 39889 IF( N.EQ.0 ) THEN 39890 VALUE = ZERO 39891 ELSE IF( LSAME( NORM, 'M' ) ) THEN 39892 K = 1 39893 IF( LSAME( DIAG, 'U' ) ) THEN 39894 VALUE = ONE 39895 IF( LSAME( UPLO, 'U' ) ) THEN 39896 DO 20 J = 1, N 39897 DO 10 I = K, K + J - 2 39898 SUM = ABS( AP( I ) ) 39899 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39900 10 CONTINUE 39901 K = K + J 39902 20 CONTINUE 39903 ELSE 39904 DO 40 J = 1, N 39905 DO 30 I = K + 1, K + N - J 39906 SUM = ABS( AP( I ) ) 39907 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39908 30 CONTINUE 39909 K = K + N - J + 1 39910 40 CONTINUE 39911 END IF 39912 ELSE 39913 VALUE = ZERO 39914 IF( LSAME( UPLO, 'U' ) ) THEN 39915 DO 60 J = 1, N 39916 DO 50 I = K, K + J - 1 39917 SUM = ABS( AP( I ) ) 39918 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39919 50 CONTINUE 39920 K = K + J 39921 60 CONTINUE 39922 ELSE 39923 DO 80 J = 1, N 39924 DO 70 I = K, K + N - J 39925 SUM = ABS( AP( I ) ) 39926 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39927 70 CONTINUE 39928 K = K + N - J + 1 39929 80 CONTINUE 39930 END IF 39931 END IF 39932 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 39933 VALUE = ZERO 39934 K = 1 39935 UDIAG = LSAME( DIAG, 'U' ) 39936 IF( LSAME( UPLO, 'U' ) ) THEN 39937 DO 110 J = 1, N 39938 IF( UDIAG ) THEN 39939 SUM = ONE 39940 DO 90 I = K, K + J - 2 39941 SUM = SUM + ABS( AP( I ) ) 39942 90 CONTINUE 39943 ELSE 39944 SUM = ZERO 39945 DO 100 I = K, K + J - 1 39946 SUM = SUM + ABS( AP( I ) ) 39947 100 CONTINUE 39948 END IF 39949 K = K + J 39950 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39951 110 CONTINUE 39952 ELSE 39953 DO 140 J = 1, N 39954 IF( UDIAG ) THEN 39955 SUM = ONE 39956 DO 120 I = K + 1, K + N - J 39957 SUM = SUM + ABS( AP( I ) ) 39958 120 CONTINUE 39959 ELSE 39960 SUM = ZERO 39961 DO 130 I = K, K + N - J 39962 SUM = SUM + ABS( AP( I ) ) 39963 130 CONTINUE 39964 END IF 39965 K = K + N - J + 1 39966 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 39967 140 CONTINUE 39968 END IF 39969 ELSE IF( LSAME( NORM, 'I' ) ) THEN 39970 K = 1 39971 IF( LSAME( UPLO, 'U' ) ) THEN 39972 IF( LSAME( DIAG, 'U' ) ) THEN 39973 DO 150 I = 1, N 39974 WORK( I ) = ONE 39975 150 CONTINUE 39976 DO 170 J = 1, N 39977 DO 160 I = 1, J - 1 39978 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 39979 K = K + 1 39980 160 CONTINUE 39981 K = K + 1 39982 170 CONTINUE 39983 ELSE 39984 DO 180 I = 1, N 39985 WORK( I ) = ZERO 39986 180 CONTINUE 39987 DO 200 J = 1, N 39988 DO 190 I = 1, J 39989 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 39990 K = K + 1 39991 190 CONTINUE 39992 200 CONTINUE 39993 END IF 39994 ELSE 39995 IF( LSAME( DIAG, 'U' ) ) THEN 39996 DO 210 I = 1, N 39997 WORK( I ) = ONE 39998 210 CONTINUE 39999 DO 230 J = 1, N 40000 K = K + 1 40001 DO 220 I = J + 1, N 40002 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 40003 K = K + 1 40004 220 CONTINUE 40005 230 CONTINUE 40006 ELSE 40007 DO 240 I = 1, N 40008 WORK( I ) = ZERO 40009 240 CONTINUE 40010 DO 260 J = 1, N 40011 DO 250 I = J, N 40012 WORK( I ) = WORK( I ) + ABS( AP( K ) ) 40013 K = K + 1 40014 250 CONTINUE 40015 260 CONTINUE 40016 END IF 40017 END IF 40018 VALUE = ZERO 40019 DO 270 I = 1, N 40020 SUM = WORK( I ) 40021 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40022 270 CONTINUE 40023 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 40024 IF( LSAME( UPLO, 'U' ) ) THEN 40025 IF( LSAME( DIAG, 'U' ) ) THEN 40026 SSQ( 1 ) = ONE 40027 SSQ( 2 ) = N 40028 K = 2 40029 DO 280 J = 2, N 40030 COLSSQ( 1 ) = ZERO 40031 COLSSQ( 2 ) = ONE 40032 CALL ZLASSQ( J-1, AP( K ), 1, 40033 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 40034 CALL DCOMBSSQ( SSQ, COLSSQ ) 40035 K = K + J 40036 280 CONTINUE 40037 ELSE 40038 SSQ( 1 ) = ZERO 40039 SSQ( 2 ) = ONE 40040 K = 1 40041 DO 290 J = 1, N 40042 COLSSQ( 1 ) = ZERO 40043 COLSSQ( 2 ) = ONE 40044 CALL ZLASSQ( J, AP( K ), 1, 40045 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 40046 CALL DCOMBSSQ( SSQ, COLSSQ ) 40047 K = K + J 40048 290 CONTINUE 40049 END IF 40050 ELSE 40051 IF( LSAME( DIAG, 'U' ) ) THEN 40052 SSQ( 1 ) = ONE 40053 SSQ( 2 ) = N 40054 K = 2 40055 DO 300 J = 1, N - 1 40056 COLSSQ( 1 ) = ZERO 40057 COLSSQ( 2 ) = ONE 40058 CALL ZLASSQ( N-J, AP( K ), 1, 40059 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 40060 CALL DCOMBSSQ( SSQ, COLSSQ ) 40061 K = K + N - J + 1 40062 300 CONTINUE 40063 ELSE 40064 SSQ( 1 ) = ZERO 40065 SSQ( 2 ) = ONE 40066 K = 1 40067 DO 310 J = 1, N 40068 COLSSQ( 1 ) = ZERO 40069 COLSSQ( 2 ) = ONE 40070 CALL ZLASSQ( N-J+1, AP( K ), 1, 40071 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 40072 CALL DCOMBSSQ( SSQ, COLSSQ ) 40073 K = K + N - J + 1 40074 310 CONTINUE 40075 END IF 40076 END IF 40077 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 40078 END IF 40079 ZLANTP = VALUE 40080 RETURN 40081 END 40082! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlantr.f 40083 DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, 40084 $ WORK ) 40085 IMPLICIT NONE 40086 CHARACTER DIAG, NORM, UPLO 40087 INTEGER LDA, M, N 40088 DOUBLE PRECISION WORK( * ) 40089 COMPLEX*16 A( LDA, * ) 40090 DOUBLE PRECISION ONE, ZERO 40091 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 40092 LOGICAL UDIAG 40093 INTEGER I, J 40094 DOUBLE PRECISION SUM, VALUE 40095 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 40096 LOGICAL LSAME, DISNAN 40097 EXTERNAL LSAME, DISNAN 40098 EXTERNAL ZLASSQ, DCOMBSSQ 40099 INTRINSIC ABS, MIN, SQRT 40100 IF( MIN( M, N ).EQ.0 ) THEN 40101 VALUE = ZERO 40102 ELSE IF( LSAME( NORM, 'M' ) ) THEN 40103 IF( LSAME( DIAG, 'U' ) ) THEN 40104 VALUE = ONE 40105 IF( LSAME( UPLO, 'U' ) ) THEN 40106 DO 20 J = 1, N 40107 DO 10 I = 1, MIN( M, J-1 ) 40108 SUM = ABS( A( I, J ) ) 40109 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40110 10 CONTINUE 40111 20 CONTINUE 40112 ELSE 40113 DO 40 J = 1, N 40114 DO 30 I = J + 1, M 40115 SUM = ABS( A( I, J ) ) 40116 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40117 30 CONTINUE 40118 40 CONTINUE 40119 END IF 40120 ELSE 40121 VALUE = ZERO 40122 IF( LSAME( UPLO, 'U' ) ) THEN 40123 DO 60 J = 1, N 40124 DO 50 I = 1, MIN( M, J ) 40125 SUM = ABS( A( I, J ) ) 40126 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40127 50 CONTINUE 40128 60 CONTINUE 40129 ELSE 40130 DO 80 J = 1, N 40131 DO 70 I = J, M 40132 SUM = ABS( A( I, J ) ) 40133 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40134 70 CONTINUE 40135 80 CONTINUE 40136 END IF 40137 END IF 40138 ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN 40139 VALUE = ZERO 40140 UDIAG = LSAME( DIAG, 'U' ) 40141 IF( LSAME( UPLO, 'U' ) ) THEN 40142 DO 110 J = 1, N 40143 IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN 40144 SUM = ONE 40145 DO 90 I = 1, J - 1 40146 SUM = SUM + ABS( A( I, J ) ) 40147 90 CONTINUE 40148 ELSE 40149 SUM = ZERO 40150 DO 100 I = 1, MIN( M, J ) 40151 SUM = SUM + ABS( A( I, J ) ) 40152 100 CONTINUE 40153 END IF 40154 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40155 110 CONTINUE 40156 ELSE 40157 DO 140 J = 1, N 40158 IF( UDIAG ) THEN 40159 SUM = ONE 40160 DO 120 I = J + 1, M 40161 SUM = SUM + ABS( A( I, J ) ) 40162 120 CONTINUE 40163 ELSE 40164 SUM = ZERO 40165 DO 130 I = J, M 40166 SUM = SUM + ABS( A( I, J ) ) 40167 130 CONTINUE 40168 END IF 40169 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40170 140 CONTINUE 40171 END IF 40172 ELSE IF( LSAME( NORM, 'I' ) ) THEN 40173 IF( LSAME( UPLO, 'U' ) ) THEN 40174 IF( LSAME( DIAG, 'U' ) ) THEN 40175 DO 150 I = 1, M 40176 WORK( I ) = ONE 40177 150 CONTINUE 40178 DO 170 J = 1, N 40179 DO 160 I = 1, MIN( M, J-1 ) 40180 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 40181 160 CONTINUE 40182 170 CONTINUE 40183 ELSE 40184 DO 180 I = 1, M 40185 WORK( I ) = ZERO 40186 180 CONTINUE 40187 DO 200 J = 1, N 40188 DO 190 I = 1, MIN( M, J ) 40189 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 40190 190 CONTINUE 40191 200 CONTINUE 40192 END IF 40193 ELSE 40194 IF( LSAME( DIAG, 'U' ) ) THEN 40195 DO 210 I = 1, MIN( M, N ) 40196 WORK( I ) = ONE 40197 210 CONTINUE 40198 DO 220 I = N + 1, M 40199 WORK( I ) = ZERO 40200 220 CONTINUE 40201 DO 240 J = 1, N 40202 DO 230 I = J + 1, M 40203 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 40204 230 CONTINUE 40205 240 CONTINUE 40206 ELSE 40207 DO 250 I = 1, M 40208 WORK( I ) = ZERO 40209 250 CONTINUE 40210 DO 270 J = 1, N 40211 DO 260 I = J, M 40212 WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 40213 260 CONTINUE 40214 270 CONTINUE 40215 END IF 40216 END IF 40217 VALUE = ZERO 40218 DO 280 I = 1, M 40219 SUM = WORK( I ) 40220 IF( VALUE .LT. SUM .OR. DISNAN( SUM ) ) VALUE = SUM 40221 280 CONTINUE 40222 ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN 40223 IF( LSAME( UPLO, 'U' ) ) THEN 40224 IF( LSAME( DIAG, 'U' ) ) THEN 40225 SSQ( 1 ) = ONE 40226 SSQ( 2 ) = MIN( M, N ) 40227 DO 290 J = 2, N 40228 COLSSQ( 1 ) = ZERO 40229 COLSSQ( 2 ) = ONE 40230 CALL ZLASSQ( MIN( M, J-1 ), A( 1, J ), 1, 40231 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 40232 CALL DCOMBSSQ( SSQ, COLSSQ ) 40233 290 CONTINUE 40234 ELSE 40235 SSQ( 1 ) = ZERO 40236 SSQ( 2 ) = ONE 40237 DO 300 J = 1, N 40238 COLSSQ( 1 ) = ZERO 40239 COLSSQ( 2 ) = ONE 40240 CALL ZLASSQ( MIN( M, J ), A( 1, J ), 1, 40241 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 40242 CALL DCOMBSSQ( SSQ, COLSSQ ) 40243 300 CONTINUE 40244 END IF 40245 ELSE 40246 IF( LSAME( DIAG, 'U' ) ) THEN 40247 SSQ( 1 ) = ONE 40248 SSQ( 2 ) = MIN( M, N ) 40249 DO 310 J = 1, N 40250 COLSSQ( 1 ) = ZERO 40251 COLSSQ( 2 ) = ONE 40252 CALL ZLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, 40253 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 40254 CALL DCOMBSSQ( SSQ, COLSSQ ) 40255 310 CONTINUE 40256 ELSE 40257 SSQ( 1 ) = ZERO 40258 SSQ( 2 ) = ONE 40259 DO 320 J = 1, N 40260 COLSSQ( 1 ) = ZERO 40261 COLSSQ( 2 ) = ONE 40262 CALL ZLASSQ( M-J+1, A( J, J ), 1, 40263 $ COLSSQ( 1 ), COLSSQ( 2 ) ) 40264 CALL DCOMBSSQ( SSQ, COLSSQ ) 40265 320 CONTINUE 40266 END IF 40267 END IF 40268 VALUE = SSQ( 1 )*SQRT( SSQ( 2 ) ) 40269 END IF 40270 ZLANTR = VALUE 40271 RETURN 40272 END 40273! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlaqr0.f 40274 SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, 40275 $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) 40276 INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N 40277 LOGICAL WANTT, WANTZ 40278 COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) 40279 INTEGER NTINY 40280 PARAMETER ( NTINY = 11 ) 40281 INTEGER KEXNW 40282 PARAMETER ( KEXNW = 5 ) 40283 INTEGER KEXSH 40284 PARAMETER ( KEXSH = 6 ) 40285 DOUBLE PRECISION WILK1 40286 PARAMETER ( WILK1 = 0.75d0 ) 40287 COMPLEX*16 ZERO, ONE 40288 PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), 40289 $ ONE = ( 1.0d0, 0.0d0 ) ) 40290 DOUBLE PRECISION TWO 40291 PARAMETER ( TWO = 2.0d0 ) 40292 COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 40293 DOUBLE PRECISION S 40294 INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, 40295 $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, 40296 $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, 40297 $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD 40298 LOGICAL SORTED 40299 CHARACTER JBCMPZ*2 40300 INTEGER ILAENV 40301 EXTERNAL ILAENV 40302 COMPLEX*16 ZDUM( 1, 1 ) 40303 EXTERNAL ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5 40304 INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, 40305 $ SQRT 40306 DOUBLE PRECISION CABS1 40307 CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) 40308 INFO = 0 40309 IF( N.EQ.0 ) THEN 40310 WORK( 1 ) = ONE 40311 RETURN 40312 END IF 40313 IF( N.LE.NTINY ) THEN 40314 LWKOPT = 1 40315 IF( LWORK.NE.-1 ) 40316 $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, 40317 $ IHIZ, Z, LDZ, INFO ) 40318 ELSE 40319 INFO = 0 40320 IF( WANTT ) THEN 40321 JBCMPZ( 1: 1 ) = 'S' 40322 ELSE 40323 JBCMPZ( 1: 1 ) = 'E' 40324 END IF 40325 IF( WANTZ ) THEN 40326 JBCMPZ( 2: 2 ) = 'V' 40327 ELSE 40328 JBCMPZ( 2: 2 ) = 'N' 40329 END IF 40330 NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) 40331 NWR = MAX( 2, NWR ) 40332 NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) 40333 NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) 40334 NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) 40335 NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) 40336 CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, 40337 $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, 40338 $ LDH, WORK, -1 ) 40339 LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) 40340 IF( LWORK.EQ.-1 ) THEN 40341 WORK( 1 ) = DCMPLX( LWKOPT, 0 ) 40342 RETURN 40343 END IF 40344 NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) 40345 NMIN = MAX( NTINY, NMIN ) 40346 NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) 40347 NIBBLE = MAX( 0, NIBBLE ) 40348 KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) 40349 KACC22 = MAX( 0, KACC22 ) 40350 KACC22 = MIN( 2, KACC22 ) 40351 NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) 40352 NW = NWMAX 40353 NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) 40354 NSMAX = NSMAX - MOD( NSMAX, 2 ) 40355 NDFL = 1 40356 ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) 40357 KBOT = IHI 40358 DO 70 IT = 1, ITMAX 40359 IF( KBOT.LT.ILO ) 40360 $ GO TO 80 40361 DO 10 K = KBOT, ILO + 1, -1 40362 IF( H( K, K-1 ).EQ.ZERO ) 40363 $ GO TO 20 40364 10 CONTINUE 40365 K = ILO 40366 20 CONTINUE 40367 KTOP = K 40368 NH = KBOT - KTOP + 1 40369 NWUPBD = MIN( NH, NWMAX ) 40370 IF( NDFL.LT.KEXNW ) THEN 40371 NW = MIN( NWUPBD, NWR ) 40372 ELSE 40373 NW = MIN( NWUPBD, 2*NW ) 40374 END IF 40375 IF( NW.LT.NWMAX ) THEN 40376 IF( NW.GE.NH-1 ) THEN 40377 NW = NH 40378 ELSE 40379 KWTOP = KBOT - NW + 1 40380 IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. 40381 $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 40382 END IF 40383 END IF 40384 IF( NDFL.LT.KEXNW ) THEN 40385 NDEC = -1 40386 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN 40387 NDEC = NDEC + 1 40388 IF( NW-NDEC.LT.2 ) 40389 $ NDEC = 0 40390 NW = NW - NDEC 40391 END IF 40392 KV = N - NW + 1 40393 KT = NW + 1 40394 NHO = ( N-NW-1 ) - KT + 1 40395 KWV = NW + 2 40396 NVE = ( N-NW ) - KWV + 1 40397 CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, 40398 $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, 40399 $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, 40400 $ LWORK ) 40401 KBOT = KBOT - LD 40402 KS = KBOT - LS + 1 40403 IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- 40404 $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN 40405 NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) 40406 NS = NS - MOD( NS, 2 ) 40407 IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN 40408 KS = KBOT - NS + 1 40409 DO 30 I = KBOT, KS + 1, -2 40410 W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) 40411 W( I-1 ) = W( I ) 40412 30 CONTINUE 40413 ELSE 40414 IF( KBOT-KS+1.LE.NS / 2 ) THEN 40415 KS = KBOT - NS + 1 40416 KT = N - NS + 1 40417 CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, 40418 $ H( KT, 1 ), LDH ) 40419 IF( NS.GT.NMIN ) THEN 40420 CALL ZLAQR4( .false., .false., NS, 1, NS, 40421 $ H( KT, 1 ), LDH, W( KS ), 1, 1, 40422 $ ZDUM, 1, WORK, LWORK, INF ) 40423 ELSE 40424 CALL ZLAHQR( .false., .false., NS, 1, NS, 40425 $ H( KT, 1 ), LDH, W( KS ), 1, 1, 40426 $ ZDUM, 1, INF ) 40427 END IF 40428 KS = KS + INF 40429 IF( KS.GE.KBOT ) THEN 40430 S = CABS1( H( KBOT-1, KBOT-1 ) ) + 40431 $ CABS1( H( KBOT, KBOT-1 ) ) + 40432 $ CABS1( H( KBOT-1, KBOT ) ) + 40433 $ CABS1( H( KBOT, KBOT ) ) 40434 AA = H( KBOT-1, KBOT-1 ) / S 40435 CC = H( KBOT, KBOT-1 ) / S 40436 BB = H( KBOT-1, KBOT ) / S 40437 DD = H( KBOT, KBOT ) / S 40438 TR2 = ( AA+DD ) / TWO 40439 DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC 40440 RTDISC = SQRT( -DET ) 40441 W( KBOT-1 ) = ( TR2+RTDISC )*S 40442 W( KBOT ) = ( TR2-RTDISC )*S 40443 KS = KBOT - 1 40444 END IF 40445 END IF 40446 IF( KBOT-KS+1.GT.NS ) THEN 40447 SORTED = .false. 40448 DO 50 K = KBOT, KS + 1, -1 40449 IF( SORTED ) 40450 $ GO TO 60 40451 SORTED = .true. 40452 DO 40 I = KS, K - 1 40453 IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) 40454 $ THEN 40455 SORTED = .false. 40456 SWAP = W( I ) 40457 W( I ) = W( I+1 ) 40458 W( I+1 ) = SWAP 40459 END IF 40460 40 CONTINUE 40461 50 CONTINUE 40462 60 CONTINUE 40463 END IF 40464 END IF 40465 IF( KBOT-KS+1.EQ.2 ) THEN 40466 IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. 40467 $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN 40468 W( KBOT-1 ) = W( KBOT ) 40469 ELSE 40470 W( KBOT ) = W( KBOT-1 ) 40471 END IF 40472 END IF 40473 NS = MIN( NS, KBOT-KS+1 ) 40474 NS = NS - MOD( NS, 2 ) 40475 KS = KBOT - NS + 1 40476 KDU = 3*NS - 3 40477 KU = N - KDU + 1 40478 KWH = KDU + 1 40479 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 40480 KWV = KDU + 4 40481 NVE = N - KDU - KWV + 1 40482 CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, 40483 $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, 40484 $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, 40485 $ NHO, H( KU, KWH ), LDH ) 40486 END IF 40487 IF( LD.GT.0 ) THEN 40488 NDFL = 1 40489 ELSE 40490 NDFL = NDFL + 1 40491 END IF 40492 70 CONTINUE 40493 INFO = KBOT 40494 80 CONTINUE 40495 END IF 40496 WORK( 1 ) = DCMPLX( LWKOPT, 0 ) 40497 END 40498! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlaqr1.f 40499 SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) 40500 COMPLEX*16 S1, S2 40501 INTEGER LDH, N 40502 COMPLEX*16 H( LDH, * ), V( * ) 40503 COMPLEX*16 ZERO 40504 PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ) ) 40505 DOUBLE PRECISION RZERO 40506 PARAMETER ( RZERO = 0.0d0 ) 40507 COMPLEX*16 CDUM, H21S, H31S 40508 DOUBLE PRECISION S 40509 INTRINSIC ABS, DBLE, DIMAG 40510 DOUBLE PRECISION CABS1 40511 CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) 40512 IF( N.NE.2 .AND. N.NE.3 ) THEN 40513 RETURN 40514 END IF 40515 IF( N.EQ.2 ) THEN 40516 S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) 40517 IF( S.EQ.RZERO ) THEN 40518 V( 1 ) = ZERO 40519 V( 2 ) = ZERO 40520 ELSE 40521 H21S = H( 2, 1 ) / S 40522 V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )* 40523 $ ( ( H( 1, 1 )-S2 ) / S ) 40524 V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) 40525 END IF 40526 ELSE 40527 S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) + 40528 $ CABS1( H( 3, 1 ) ) 40529 IF( S.EQ.ZERO ) THEN 40530 V( 1 ) = ZERO 40531 V( 2 ) = ZERO 40532 V( 3 ) = ZERO 40533 ELSE 40534 H21S = H( 2, 1 ) / S 40535 H31S = H( 3, 1 ) / S 40536 V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) + 40537 $ H( 1, 2 )*H21S + H( 1, 3 )*H31S 40538 V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S 40539 V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 ) 40540 END IF 40541 END IF 40542 END 40543! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlaqr2.f 40544 SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, 40545 $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, 40546 $ NV, WV, LDWV, WORK, LWORK ) 40547 INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, 40548 $ LDZ, LWORK, N, ND, NH, NS, NV, NW 40549 LOGICAL WANTT, WANTZ 40550 COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), 40551 $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) 40552 COMPLEX*16 ZERO, ONE 40553 PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), 40554 $ ONE = ( 1.0d0, 0.0d0 ) ) 40555 DOUBLE PRECISION RZERO, RONE 40556 PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) 40557 COMPLEX*16 BETA, CDUM, S, TAU 40558 DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP 40559 INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, 40560 $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT 40561 DOUBLE PRECISION DLAMCH 40562 EXTERNAL DLAMCH 40563 EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, 40564 $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR 40565 INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN 40566 DOUBLE PRECISION CABS1 40567 CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) 40568 JW = MIN( NW, KBOT-KTOP+1 ) 40569 IF( JW.LE.2 ) THEN 40570 LWKOPT = 1 40571 ELSE 40572 CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) 40573 LWK1 = INT( WORK( 1 ) ) 40574 CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, 40575 $ WORK, -1, INFO ) 40576 LWK2 = INT( WORK( 1 ) ) 40577 LWKOPT = JW + MAX( LWK1, LWK2 ) 40578 END IF 40579 IF( LWORK.EQ.-1 ) THEN 40580 WORK( 1 ) = DCMPLX( LWKOPT, 0 ) 40581 RETURN 40582 END IF 40583 NS = 0 40584 ND = 0 40585 WORK( 1 ) = ONE 40586 IF( KTOP.GT.KBOT ) 40587 $ RETURN 40588 IF( NW.LT.1 ) 40589 $ RETURN 40590 SAFMIN = DLAMCH( 'SAFE MINIMUM' ) 40591 SAFMAX = RONE / SAFMIN 40592 CALL DLABAD( SAFMIN, SAFMAX ) 40593 ULP = DLAMCH( 'PRECISION' ) 40594 SMLNUM = SAFMIN*( DBLE( N ) / ULP ) 40595 JW = MIN( NW, KBOT-KTOP+1 ) 40596 KWTOP = KBOT - JW + 1 40597 IF( KWTOP.EQ.KTOP ) THEN 40598 S = ZERO 40599 ELSE 40600 S = H( KWTOP, KWTOP-1 ) 40601 END IF 40602 IF( KBOT.EQ.KWTOP ) THEN 40603 SH( KWTOP ) = H( KWTOP, KWTOP ) 40604 NS = 1 40605 ND = 0 40606 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, 40607 $ KWTOP ) ) ) ) THEN 40608 NS = 0 40609 ND = 1 40610 IF( KWTOP.GT.KTOP ) 40611 $ H( KWTOP, KWTOP-1 ) = ZERO 40612 END IF 40613 WORK( 1 ) = ONE 40614 RETURN 40615 END IF 40616 CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) 40617 CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) 40618 CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) 40619 CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, 40620 $ JW, V, LDV, INFQR ) 40621 NS = JW 40622 ILST = INFQR + 1 40623 DO 10 KNT = INFQR + 1, JW 40624 FOO = CABS1( T( NS, NS ) ) 40625 IF( FOO.EQ.RZERO ) 40626 $ FOO = CABS1( S ) 40627 IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) 40628 $ THEN 40629 NS = NS - 1 40630 ELSE 40631 IFST = NS 40632 CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 40633 ILST = ILST + 1 40634 END IF 40635 10 CONTINUE 40636 IF( NS.EQ.0 ) 40637 $ S = ZERO 40638 IF( NS.LT.JW ) THEN 40639 DO 30 I = INFQR + 1, NS 40640 IFST = I 40641 DO 20 J = I + 1, NS 40642 IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) 40643 $ IFST = J 40644 20 CONTINUE 40645 ILST = I 40646 IF( IFST.NE.ILST ) 40647 $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 40648 30 CONTINUE 40649 END IF 40650 DO 40 I = INFQR + 1, JW 40651 SH( KWTOP+I-1 ) = T( I, I ) 40652 40 CONTINUE 40653 IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN 40654 IF( NS.GT.1 .AND. S.NE.ZERO ) THEN 40655 CALL ZCOPY( NS, V, LDV, WORK, 1 ) 40656 DO 50 I = 1, NS 40657 WORK( I ) = DCONJG( WORK( I ) ) 40658 50 CONTINUE 40659 BETA = WORK( 1 ) 40660 CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) 40661 WORK( 1 ) = ONE 40662 CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) 40663 CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, 40664 $ WORK( JW+1 ) ) 40665 CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, 40666 $ WORK( JW+1 ) ) 40667 CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, 40668 $ WORK( JW+1 ) ) 40669 CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), 40670 $ LWORK-JW, INFO ) 40671 END IF 40672 IF( KWTOP.GT.1 ) 40673 $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) 40674 CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) 40675 CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), 40676 $ LDH+1 ) 40677 IF( NS.GT.1 .AND. S.NE.ZERO ) 40678 $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, 40679 $ WORK( JW+1 ), LWORK-JW, INFO ) 40680 IF( WANTT ) THEN 40681 LTOP = 1 40682 ELSE 40683 LTOP = KTOP 40684 END IF 40685 DO 60 KROW = LTOP, KWTOP - 1, NV 40686 KLN = MIN( NV, KWTOP-KROW ) 40687 CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), 40688 $ LDH, V, LDV, ZERO, WV, LDWV ) 40689 CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 40690 60 CONTINUE 40691 IF( WANTT ) THEN 40692 DO 70 KCOL = KBOT + 1, N, NH 40693 KLN = MIN( NH, N-KCOL+1 ) 40694 CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, 40695 $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) 40696 CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), 40697 $ LDH ) 40698 70 CONTINUE 40699 END IF 40700 IF( WANTZ ) THEN 40701 DO 80 KROW = ILOZ, IHIZ, NV 40702 KLN = MIN( NV, IHIZ-KROW+1 ) 40703 CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), 40704 $ LDZ, V, LDV, ZERO, WV, LDWV ) 40705 CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), 40706 $ LDZ ) 40707 80 CONTINUE 40708 END IF 40709 END IF 40710 ND = JW - NS 40711 NS = NS - INFQR 40712 WORK( 1 ) = DCMPLX( LWKOPT, 0 ) 40713 END 40714! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlaqr3.f 40715 SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, 40716 $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, 40717 $ NV, WV, LDWV, WORK, LWORK ) 40718 INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, 40719 $ LDZ, LWORK, N, ND, NH, NS, NV, NW 40720 LOGICAL WANTT, WANTZ 40721 COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), 40722 $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) 40723 COMPLEX*16 ZERO, ONE 40724 PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), 40725 $ ONE = ( 1.0d0, 0.0d0 ) ) 40726 DOUBLE PRECISION RZERO, RONE 40727 PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) 40728 COMPLEX*16 BETA, CDUM, S, TAU 40729 DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP 40730 INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, 40731 $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, 40732 $ LWKOPT, NMIN 40733 DOUBLE PRECISION DLAMCH 40734 INTEGER ILAENV 40735 EXTERNAL DLAMCH, ILAENV 40736 EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, 40737 $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR 40738 INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN 40739 DOUBLE PRECISION CABS1 40740 CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) 40741 JW = MIN( NW, KBOT-KTOP+1 ) 40742 IF( JW.LE.2 ) THEN 40743 LWKOPT = 1 40744 ELSE 40745 CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) 40746 LWK1 = INT( WORK( 1 ) ) 40747 CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, 40748 $ WORK, -1, INFO ) 40749 LWK2 = INT( WORK( 1 ) ) 40750 CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, 40751 $ LDV, WORK, -1, INFQR ) 40752 LWK3 = INT( WORK( 1 ) ) 40753 LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) 40754 END IF 40755 IF( LWORK.EQ.-1 ) THEN 40756 WORK( 1 ) = DCMPLX( LWKOPT, 0 ) 40757 RETURN 40758 END IF 40759 NS = 0 40760 ND = 0 40761 WORK( 1 ) = ONE 40762 IF( KTOP.GT.KBOT ) 40763 $ RETURN 40764 IF( NW.LT.1 ) 40765 $ RETURN 40766 SAFMIN = DLAMCH( 'SAFE MINIMUM' ) 40767 SAFMAX = RONE / SAFMIN 40768 CALL DLABAD( SAFMIN, SAFMAX ) 40769 ULP = DLAMCH( 'PRECISION' ) 40770 SMLNUM = SAFMIN*( DBLE( N ) / ULP ) 40771 JW = MIN( NW, KBOT-KTOP+1 ) 40772 KWTOP = KBOT - JW + 1 40773 IF( KWTOP.EQ.KTOP ) THEN 40774 S = ZERO 40775 ELSE 40776 S = H( KWTOP, KWTOP-1 ) 40777 END IF 40778 IF( KBOT.EQ.KWTOP ) THEN 40779 SH( KWTOP ) = H( KWTOP, KWTOP ) 40780 NS = 1 40781 ND = 0 40782 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, 40783 $ KWTOP ) ) ) ) THEN 40784 NS = 0 40785 ND = 1 40786 IF( KWTOP.GT.KTOP ) 40787 $ H( KWTOP, KWTOP-1 ) = ZERO 40788 END IF 40789 WORK( 1 ) = ONE 40790 RETURN 40791 END IF 40792 CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) 40793 CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) 40794 CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) 40795 NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK ) 40796 IF( JW.GT.NMIN ) THEN 40797 CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, 40798 $ JW, V, LDV, WORK, LWORK, INFQR ) 40799 ELSE 40800 CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, 40801 $ JW, V, LDV, INFQR ) 40802 END IF 40803 NS = JW 40804 ILST = INFQR + 1 40805 DO 10 KNT = INFQR + 1, JW 40806 FOO = CABS1( T( NS, NS ) ) 40807 IF( FOO.EQ.RZERO ) 40808 $ FOO = CABS1( S ) 40809 IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) 40810 $ THEN 40811 NS = NS - 1 40812 ELSE 40813 IFST = NS 40814 CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 40815 ILST = ILST + 1 40816 END IF 40817 10 CONTINUE 40818 IF( NS.EQ.0 ) 40819 $ S = ZERO 40820 IF( NS.LT.JW ) THEN 40821 DO 30 I = INFQR + 1, NS 40822 IFST = I 40823 DO 20 J = I + 1, NS 40824 IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) 40825 $ IFST = J 40826 20 CONTINUE 40827 ILST = I 40828 IF( IFST.NE.ILST ) 40829 $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 40830 30 CONTINUE 40831 END IF 40832 DO 40 I = INFQR + 1, JW 40833 SH( KWTOP+I-1 ) = T( I, I ) 40834 40 CONTINUE 40835 IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN 40836 IF( NS.GT.1 .AND. S.NE.ZERO ) THEN 40837 CALL ZCOPY( NS, V, LDV, WORK, 1 ) 40838 DO 50 I = 1, NS 40839 WORK( I ) = DCONJG( WORK( I ) ) 40840 50 CONTINUE 40841 BETA = WORK( 1 ) 40842 CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU ) 40843 WORK( 1 ) = ONE 40844 CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) 40845 CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT, 40846 $ WORK( JW+1 ) ) 40847 CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, 40848 $ WORK( JW+1 ) ) 40849 CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, 40850 $ WORK( JW+1 ) ) 40851 CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), 40852 $ LWORK-JW, INFO ) 40853 END IF 40854 IF( KWTOP.GT.1 ) 40855 $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) 40856 CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) 40857 CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), 40858 $ LDH+1 ) 40859 IF( NS.GT.1 .AND. S.NE.ZERO ) 40860 $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, 40861 $ WORK( JW+1 ), LWORK-JW, INFO ) 40862 IF( WANTT ) THEN 40863 LTOP = 1 40864 ELSE 40865 LTOP = KTOP 40866 END IF 40867 DO 60 KROW = LTOP, KWTOP - 1, NV 40868 KLN = MIN( NV, KWTOP-KROW ) 40869 CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), 40870 $ LDH, V, LDV, ZERO, WV, LDWV ) 40871 CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 40872 60 CONTINUE 40873 IF( WANTT ) THEN 40874 DO 70 KCOL = KBOT + 1, N, NH 40875 KLN = MIN( NH, N-KCOL+1 ) 40876 CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, 40877 $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) 40878 CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), 40879 $ LDH ) 40880 70 CONTINUE 40881 END IF 40882 IF( WANTZ ) THEN 40883 DO 80 KROW = ILOZ, IHIZ, NV 40884 KLN = MIN( NV, IHIZ-KROW+1 ) 40885 CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), 40886 $ LDZ, V, LDV, ZERO, WV, LDWV ) 40887 CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), 40888 $ LDZ ) 40889 80 CONTINUE 40890 END IF 40891 END IF 40892 ND = JW - NS 40893 NS = NS - INFQR 40894 WORK( 1 ) = DCMPLX( LWKOPT, 0 ) 40895 END 40896! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlaqr4.f 40897 SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, 40898 $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) 40899 INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N 40900 LOGICAL WANTT, WANTZ 40901 COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) 40902 INTEGER NTINY 40903 PARAMETER ( NTINY = 11 ) 40904 INTEGER KEXNW 40905 PARAMETER ( KEXNW = 5 ) 40906 INTEGER KEXSH 40907 PARAMETER ( KEXSH = 6 ) 40908 DOUBLE PRECISION WILK1 40909 PARAMETER ( WILK1 = 0.75d0 ) 40910 COMPLEX*16 ZERO, ONE 40911 PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), 40912 $ ONE = ( 1.0d0, 0.0d0 ) ) 40913 DOUBLE PRECISION TWO 40914 PARAMETER ( TWO = 2.0d0 ) 40915 COMPLEX*16 AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2 40916 DOUBLE PRECISION S 40917 INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, 40918 $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, 40919 $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, 40920 $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD 40921 LOGICAL SORTED 40922 CHARACTER JBCMPZ*2 40923 INTEGER ILAENV 40924 EXTERNAL ILAENV 40925 COMPLEX*16 ZDUM( 1, 1 ) 40926 EXTERNAL ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5 40927 INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, 40928 $ SQRT 40929 DOUBLE PRECISION CABS1 40930 CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) 40931 INFO = 0 40932 IF( N.EQ.0 ) THEN 40933 WORK( 1 ) = ONE 40934 RETURN 40935 END IF 40936 IF( N.LE.NTINY ) THEN 40937 LWKOPT = 1 40938 IF( LWORK.NE.-1 ) 40939 $ CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, 40940 $ IHIZ, Z, LDZ, INFO ) 40941 ELSE 40942 INFO = 0 40943 IF( WANTT ) THEN 40944 JBCMPZ( 1: 1 ) = 'S' 40945 ELSE 40946 JBCMPZ( 1: 1 ) = 'E' 40947 END IF 40948 IF( WANTZ ) THEN 40949 JBCMPZ( 2: 2 ) = 'V' 40950 ELSE 40951 JBCMPZ( 2: 2 ) = 'N' 40952 END IF 40953 NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) 40954 NWR = MAX( 2, NWR ) 40955 NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) 40956 NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) 40957 NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO ) 40958 NSR = MAX( 2, NSR-MOD( NSR, 2 ) ) 40959 CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ, 40960 $ IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H, 40961 $ LDH, WORK, -1 ) 40962 LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) ) 40963 IF( LWORK.EQ.-1 ) THEN 40964 WORK( 1 ) = DCMPLX( LWKOPT, 0 ) 40965 RETURN 40966 END IF 40967 NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) 40968 NMIN = MAX( NTINY, NMIN ) 40969 NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) 40970 NIBBLE = MAX( 0, NIBBLE ) 40971 KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) 40972 KACC22 = MAX( 0, KACC22 ) 40973 KACC22 = MIN( 2, KACC22 ) 40974 NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) 40975 NW = NWMAX 40976 NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 ) 40977 NSMAX = NSMAX - MOD( NSMAX, 2 ) 40978 NDFL = 1 40979 ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) ) 40980 KBOT = IHI 40981 DO 70 IT = 1, ITMAX 40982 IF( KBOT.LT.ILO ) 40983 $ GO TO 80 40984 DO 10 K = KBOT, ILO + 1, -1 40985 IF( H( K, K-1 ).EQ.ZERO ) 40986 $ GO TO 20 40987 10 CONTINUE 40988 K = ILO 40989 20 CONTINUE 40990 KTOP = K 40991 NH = KBOT - KTOP + 1 40992 NWUPBD = MIN( NH, NWMAX ) 40993 IF( NDFL.LT.KEXNW ) THEN 40994 NW = MIN( NWUPBD, NWR ) 40995 ELSE 40996 NW = MIN( NWUPBD, 2*NW ) 40997 END IF 40998 IF( NW.LT.NWMAX ) THEN 40999 IF( NW.GE.NH-1 ) THEN 41000 NW = NH 41001 ELSE 41002 KWTOP = KBOT - NW + 1 41003 IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. 41004 $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 41005 END IF 41006 END IF 41007 IF( NDFL.LT.KEXNW ) THEN 41008 NDEC = -1 41009 ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN 41010 NDEC = NDEC + 1 41011 IF( NW-NDEC.LT.2 ) 41012 $ NDEC = 0 41013 NW = NW - NDEC 41014 END IF 41015 KV = N - NW + 1 41016 KT = NW + 1 41017 NHO = ( N-NW-1 ) - KT + 1 41018 KWV = NW + 2 41019 NVE = ( N-NW ) - KWV + 1 41020 CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, 41021 $ IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO, 41022 $ H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK, 41023 $ LWORK ) 41024 KBOT = KBOT - LD 41025 KS = KBOT - LS + 1 41026 IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT- 41027 $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN 41028 NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) ) 41029 NS = NS - MOD( NS, 2 ) 41030 IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN 41031 KS = KBOT - NS + 1 41032 DO 30 I = KBOT, KS + 1, -2 41033 W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) ) 41034 W( I-1 ) = W( I ) 41035 30 CONTINUE 41036 ELSE 41037 IF( KBOT-KS+1.LE.NS / 2 ) THEN 41038 KS = KBOT - NS + 1 41039 KT = N - NS + 1 41040 CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH, 41041 $ H( KT, 1 ), LDH ) 41042 CALL ZLAHQR( .false., .false., NS, 1, NS, 41043 $ H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM, 41044 $ 1, INF ) 41045 KS = KS + INF 41046 IF( KS.GE.KBOT ) THEN 41047 S = CABS1( H( KBOT-1, KBOT-1 ) ) + 41048 $ CABS1( H( KBOT, KBOT-1 ) ) + 41049 $ CABS1( H( KBOT-1, KBOT ) ) + 41050 $ CABS1( H( KBOT, KBOT ) ) 41051 AA = H( KBOT-1, KBOT-1 ) / S 41052 CC = H( KBOT, KBOT-1 ) / S 41053 BB = H( KBOT-1, KBOT ) / S 41054 DD = H( KBOT, KBOT ) / S 41055 TR2 = ( AA+DD ) / TWO 41056 DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC 41057 RTDISC = SQRT( -DET ) 41058 W( KBOT-1 ) = ( TR2+RTDISC )*S 41059 W( KBOT ) = ( TR2-RTDISC )*S 41060 KS = KBOT - 1 41061 END IF 41062 END IF 41063 IF( KBOT-KS+1.GT.NS ) THEN 41064 SORTED = .false. 41065 DO 50 K = KBOT, KS + 1, -1 41066 IF( SORTED ) 41067 $ GO TO 60 41068 SORTED = .true. 41069 DO 40 I = KS, K - 1 41070 IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) ) 41071 $ THEN 41072 SORTED = .false. 41073 SWAP = W( I ) 41074 W( I ) = W( I+1 ) 41075 W( I+1 ) = SWAP 41076 END IF 41077 40 CONTINUE 41078 50 CONTINUE 41079 60 CONTINUE 41080 END IF 41081 END IF 41082 IF( KBOT-KS+1.EQ.2 ) THEN 41083 IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT. 41084 $ CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN 41085 W( KBOT-1 ) = W( KBOT ) 41086 ELSE 41087 W( KBOT ) = W( KBOT-1 ) 41088 END IF 41089 END IF 41090 NS = MIN( NS, KBOT-KS+1 ) 41091 NS = NS - MOD( NS, 2 ) 41092 KS = KBOT - NS + 1 41093 KDU = 3*NS - 3 41094 KU = N - KDU + 1 41095 KWH = KDU + 1 41096 NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1 41097 KWV = KDU + 4 41098 NVE = N - KDU - KWV + 1 41099 CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS, 41100 $ W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK, 41101 $ 3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH, 41102 $ NHO, H( KU, KWH ), LDH ) 41103 END IF 41104 IF( LD.GT.0 ) THEN 41105 NDFL = 1 41106 ELSE 41107 NDFL = NDFL + 1 41108 END IF 41109 70 CONTINUE 41110 INFO = KBOT 41111 80 CONTINUE 41112 END IF 41113 WORK( 1 ) = DCMPLX( LWKOPT, 0 ) 41114 END 41115! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlaqr5.f 41116 SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, 41117 $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, 41118 $ WV, LDWV, NH, WH, LDWH ) 41119 INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, 41120 $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV 41121 LOGICAL WANTT, WANTZ 41122 COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), 41123 $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) 41124 COMPLEX*16 ZERO, ONE 41125 PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), 41126 $ ONE = ( 1.0d0, 0.0d0 ) ) 41127 DOUBLE PRECISION RZERO, RONE 41128 PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) 41129 COMPLEX*16 ALPHA, BETA, CDUM, REFSUM 41130 DOUBLE PRECISION H11, H12, H21, H22, SAFMAX, SAFMIN, SCL, 41131 $ SMLNUM, TST1, TST2, ULP 41132 INTEGER I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN, 41133 $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS, 41134 $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL, 41135 $ NS, NU 41136 LOGICAL ACCUM, BLK22, BMP22 41137 DOUBLE PRECISION DLAMCH 41138 EXTERNAL DLAMCH 41139 INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD 41140 COMPLEX*16 VT( 3 ) 41141 EXTERNAL DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET, 41142 $ ZTRMM 41143 DOUBLE PRECISION CABS1 41144 CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) 41145 IF( NSHFTS.LT.2 ) 41146 $ RETURN 41147 IF( KTOP.GE.KBOT ) 41148 $ RETURN 41149 NS = NSHFTS - MOD( NSHFTS, 2 ) 41150 SAFMIN = DLAMCH( 'SAFE MINIMUM' ) 41151 SAFMAX = RONE / SAFMIN 41152 CALL DLABAD( SAFMIN, SAFMAX ) 41153 ULP = DLAMCH( 'PRECISION' ) 41154 SMLNUM = SAFMIN*( DBLE( N ) / ULP ) 41155 ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 ) 41156 BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 ) 41157 IF( KTOP+2.LE.KBOT ) 41158 $ H( KTOP+2, KTOP ) = ZERO 41159 NBMPS = NS / 2 41160 KDU = 6*NBMPS - 3 41161 DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2 41162 NDCOL = INCOL + KDU 41163 IF( ACCUM ) 41164 $ CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU ) 41165 DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 ) 41166 MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 ) 41167 MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 ) 41168 M22 = MBOT + 1 41169 BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ. 41170 $ ( KBOT-2 ) 41171 DO 10 M = MTOP, MBOT 41172 K = KRCOL + 3*( M-1 ) 41173 IF( K.EQ.KTOP-1 ) THEN 41174 CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ), 41175 $ S( 2*M ), V( 1, M ) ) 41176 ALPHA = V( 1, M ) 41177 CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) ) 41178 ELSE 41179 BETA = H( K+1, K ) 41180 V( 2, M ) = H( K+2, K ) 41181 V( 3, M ) = H( K+3, K ) 41182 CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) 41183 IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. 41184 $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN 41185 H( K+1, K ) = BETA 41186 H( K+2, K ) = ZERO 41187 H( K+3, K ) = ZERO 41188 ELSE 41189 CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), 41190 $ S( 2*M ), VT ) 41191 ALPHA = VT( 1 ) 41192 CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) 41193 REFSUM = DCONJG( VT( 1 ) )* 41194 $ ( H( K+1, K )+DCONJG( VT( 2 ) )* 41195 $ H( K+2, K ) ) 41196 IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+ 41197 $ CABS1( REFSUM*VT( 3 ) ).GT.ULP* 41198 $ ( CABS1( H( K, K ) )+CABS1( H( K+1, 41199 $ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN 41200 H( K+1, K ) = BETA 41201 H( K+2, K ) = ZERO 41202 H( K+3, K ) = ZERO 41203 ELSE 41204 H( K+1, K ) = H( K+1, K ) - REFSUM 41205 H( K+2, K ) = ZERO 41206 H( K+3, K ) = ZERO 41207 V( 1, M ) = VT( 1 ) 41208 V( 2, M ) = VT( 2 ) 41209 V( 3, M ) = VT( 3 ) 41210 END IF 41211 END IF 41212 END IF 41213 10 CONTINUE 41214 K = KRCOL + 3*( M22-1 ) 41215 IF( BMP22 ) THEN 41216 IF( K.EQ.KTOP-1 ) THEN 41217 CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ), 41218 $ S( 2*M22 ), V( 1, M22 ) ) 41219 BETA = V( 1, M22 ) 41220 CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) 41221 ELSE 41222 BETA = H( K+1, K ) 41223 V( 2, M22 ) = H( K+2, K ) 41224 CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) ) 41225 H( K+1, K ) = BETA 41226 H( K+2, K ) = ZERO 41227 END IF 41228 END IF 41229 IF( ACCUM ) THEN 41230 JBOT = MIN( NDCOL, KBOT ) 41231 ELSE IF( WANTT ) THEN 41232 JBOT = N 41233 ELSE 41234 JBOT = KBOT 41235 END IF 41236 DO 30 J = MAX( KTOP, KRCOL ), JBOT 41237 MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 ) 41238 DO 20 M = MTOP, MEND 41239 K = KRCOL + 3*( M-1 ) 41240 REFSUM = DCONJG( V( 1, M ) )* 41241 $ ( H( K+1, J )+DCONJG( V( 2, M ) )* 41242 $ H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) ) 41243 H( K+1, J ) = H( K+1, J ) - REFSUM 41244 H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M ) 41245 H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M ) 41246 20 CONTINUE 41247 30 CONTINUE 41248 IF( BMP22 ) THEN 41249 K = KRCOL + 3*( M22-1 ) 41250 DO 40 J = MAX( K+1, KTOP ), JBOT 41251 REFSUM = DCONJG( V( 1, M22 ) )* 41252 $ ( H( K+1, J )+DCONJG( V( 2, M22 ) )* 41253 $ H( K+2, J ) ) 41254 H( K+1, J ) = H( K+1, J ) - REFSUM 41255 H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 ) 41256 40 CONTINUE 41257 END IF 41258 IF( ACCUM ) THEN 41259 JTOP = MAX( KTOP, INCOL ) 41260 ELSE IF( WANTT ) THEN 41261 JTOP = 1 41262 ELSE 41263 JTOP = KTOP 41264 END IF 41265 DO 80 M = MTOP, MBOT 41266 IF( V( 1, M ).NE.ZERO ) THEN 41267 K = KRCOL + 3*( M-1 ) 41268 DO 50 J = JTOP, MIN( KBOT, K+3 ) 41269 REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )* 41270 $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) ) 41271 H( J, K+1 ) = H( J, K+1 ) - REFSUM 41272 H( J, K+2 ) = H( J, K+2 ) - 41273 $ REFSUM*DCONJG( V( 2, M ) ) 41274 H( J, K+3 ) = H( J, K+3 ) - 41275 $ REFSUM*DCONJG( V( 3, M ) ) 41276 50 CONTINUE 41277 IF( ACCUM ) THEN 41278 KMS = K - INCOL 41279 DO 60 J = MAX( 1, KTOP-INCOL ), KDU 41280 REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )* 41281 $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) ) 41282 U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM 41283 U( J, KMS+2 ) = U( J, KMS+2 ) - 41284 $ REFSUM*DCONJG( V( 2, M ) ) 41285 U( J, KMS+3 ) = U( J, KMS+3 ) - 41286 $ REFSUM*DCONJG( V( 3, M ) ) 41287 60 CONTINUE 41288 ELSE IF( WANTZ ) THEN 41289 DO 70 J = ILOZ, IHIZ 41290 REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )* 41291 $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) ) 41292 Z( J, K+1 ) = Z( J, K+1 ) - REFSUM 41293 Z( J, K+2 ) = Z( J, K+2 ) - 41294 $ REFSUM*DCONJG( V( 2, M ) ) 41295 Z( J, K+3 ) = Z( J, K+3 ) - 41296 $ REFSUM*DCONJG( V( 3, M ) ) 41297 70 CONTINUE 41298 END IF 41299 END IF 41300 80 CONTINUE 41301 K = KRCOL + 3*( M22-1 ) 41302 IF( BMP22 ) THEN 41303 IF ( V( 1, M22 ).NE.ZERO ) THEN 41304 DO 90 J = JTOP, MIN( KBOT, K+3 ) 41305 REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )* 41306 $ H( J, K+2 ) ) 41307 H( J, K+1 ) = H( J, K+1 ) - REFSUM 41308 H( J, K+2 ) = H( J, K+2 ) - 41309 $ REFSUM*DCONJG( V( 2, M22 ) ) 41310 90 CONTINUE 41311 IF( ACCUM ) THEN 41312 KMS = K - INCOL 41313 DO 100 J = MAX( 1, KTOP-INCOL ), KDU 41314 REFSUM = V( 1, M22 )*( U( J, KMS+1 )+ 41315 $ V( 2, M22 )*U( J, KMS+2 ) ) 41316 U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM 41317 U( J, KMS+2 ) = U( J, KMS+2 ) - 41318 $ REFSUM*DCONJG( V( 2, M22 ) ) 41319 100 CONTINUE 41320 ELSE IF( WANTZ ) THEN 41321 DO 110 J = ILOZ, IHIZ 41322 REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )* 41323 $ Z( J, K+2 ) ) 41324 Z( J, K+1 ) = Z( J, K+1 ) - REFSUM 41325 Z( J, K+2 ) = Z( J, K+2 ) - 41326 $ REFSUM*DCONJG( V( 2, M22 ) ) 41327 110 CONTINUE 41328 END IF 41329 END IF 41330 END IF 41331 MSTART = MTOP 41332 IF( KRCOL+3*( MSTART-1 ).LT.KTOP ) 41333 $ MSTART = MSTART + 1 41334 MEND = MBOT 41335 IF( BMP22 ) 41336 $ MEND = MEND + 1 41337 IF( KRCOL.EQ.KBOT-2 ) 41338 $ MEND = MEND + 1 41339 DO 120 M = MSTART, MEND 41340 K = MIN( KBOT-1, KRCOL+3*( M-1 ) ) 41341 IF( H( K+1, K ).NE.ZERO ) THEN 41342 TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) ) 41343 IF( TST1.EQ.RZERO ) THEN 41344 IF( K.GE.KTOP+1 ) 41345 $ TST1 = TST1 + CABS1( H( K, K-1 ) ) 41346 IF( K.GE.KTOP+2 ) 41347 $ TST1 = TST1 + CABS1( H( K, K-2 ) ) 41348 IF( K.GE.KTOP+3 ) 41349 $ TST1 = TST1 + CABS1( H( K, K-3 ) ) 41350 IF( K.LE.KBOT-2 ) 41351 $ TST1 = TST1 + CABS1( H( K+2, K+1 ) ) 41352 IF( K.LE.KBOT-3 ) 41353 $ TST1 = TST1 + CABS1( H( K+3, K+1 ) ) 41354 IF( K.LE.KBOT-4 ) 41355 $ TST1 = TST1 + CABS1( H( K+4, K+1 ) ) 41356 END IF 41357 IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) ) 41358 $ THEN 41359 H12 = MAX( CABS1( H( K+1, K ) ), 41360 $ CABS1( H( K, K+1 ) ) ) 41361 H21 = MIN( CABS1( H( K+1, K ) ), 41362 $ CABS1( H( K, K+1 ) ) ) 41363 H11 = MAX( CABS1( H( K+1, K+1 ) ), 41364 $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) 41365 H22 = MIN( CABS1( H( K+1, K+1 ) ), 41366 $ CABS1( H( K, K )-H( K+1, K+1 ) ) ) 41367 SCL = H11 + H12 41368 TST2 = H22*( H11 / SCL ) 41369 IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE. 41370 $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO 41371 END IF 41372 END IF 41373 120 CONTINUE 41374 MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 ) 41375 DO 130 M = MTOP, MEND 41376 K = KRCOL + 3*( M-1 ) 41377 REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 ) 41378 H( K+4, K+1 ) = -REFSUM 41379 H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) ) 41380 H( K+4, K+3 ) = H( K+4, K+3 ) - 41381 $ REFSUM*DCONJG( V( 3, M ) ) 41382 130 CONTINUE 41383 140 CONTINUE 41384 IF( ACCUM ) THEN 41385 IF( WANTT ) THEN 41386 JTOP = 1 41387 JBOT = N 41388 ELSE 41389 JTOP = KTOP 41390 JBOT = KBOT 41391 END IF 41392 IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR. 41393 $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN 41394 K1 = MAX( 1, KTOP-INCOL ) 41395 NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1 41396 DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH 41397 JLEN = MIN( NH, JBOT-JCOL+1 ) 41398 CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ), 41399 $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH, 41400 $ LDWH ) 41401 CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH, 41402 $ H( INCOL+K1, JCOL ), LDH ) 41403 150 CONTINUE 41404 DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV 41405 JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW ) 41406 CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, 41407 $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ), 41408 $ LDU, ZERO, WV, LDWV ) 41409 CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, 41410 $ H( JROW, INCOL+K1 ), LDH ) 41411 160 CONTINUE 41412 IF( WANTZ ) THEN 41413 DO 170 JROW = ILOZ, IHIZ, NV 41414 JLEN = MIN( NV, IHIZ-JROW+1 ) 41415 CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE, 41416 $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ), 41417 $ LDU, ZERO, WV, LDWV ) 41418 CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV, 41419 $ Z( JROW, INCOL+K1 ), LDZ ) 41420 170 CONTINUE 41421 END IF 41422 ELSE 41423 I2 = ( KDU+1 ) / 2 41424 I4 = KDU 41425 J2 = I4 - I2 41426 J4 = KDU 41427 KZS = ( J4-J2 ) - ( NS+1 ) 41428 KNZ = NS + 1 41429 DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH 41430 JLEN = MIN( NH, JBOT-JCOL+1 ) 41431 CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ), 41432 $ LDH, WH( KZS+1, 1 ), LDWH ) 41433 CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH ) 41434 CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE, 41435 $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ), 41436 $ LDWH ) 41437 CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, 41438 $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) 41439 CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, 41440 $ WH( I2+1, 1 ), LDWH ) 41441 CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE, 41442 $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH ) 41443 CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE, 41444 $ U( J2+1, I2+1 ), LDU, 41445 $ H( INCOL+1+J2, JCOL ), LDH, ONE, 41446 $ WH( I2+1, 1 ), LDWH ) 41447 CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH, 41448 $ H( INCOL+1, JCOL ), LDH ) 41449 180 CONTINUE 41450 DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV 41451 JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW ) 41452 CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ), 41453 $ LDH, WV( 1, 1+KZS ), LDWV ) 41454 CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV ) 41455 CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, 41456 $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), 41457 $ LDWV ) 41458 CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, 41459 $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV, 41460 $ LDWV ) 41461 CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH, 41462 $ WV( 1, 1+I2 ), LDWV ) 41463 CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, 41464 $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV ) 41465 CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, 41466 $ H( JROW, INCOL+1+J2 ), LDH, 41467 $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ), 41468 $ LDWV ) 41469 CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, 41470 $ H( JROW, INCOL+1 ), LDH ) 41471 190 CONTINUE 41472 IF( WANTZ ) THEN 41473 DO 200 JROW = ILOZ, IHIZ, NV 41474 JLEN = MIN( NV, IHIZ-JROW+1 ) 41475 CALL ZLACPY( 'ALL', JLEN, KNZ, 41476 $ Z( JROW, INCOL+1+J2 ), LDZ, 41477 $ WV( 1, 1+KZS ), LDWV ) 41478 CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, 41479 $ LDWV ) 41480 CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE, 41481 $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ), 41482 $ LDWV ) 41483 CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE, 41484 $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE, 41485 $ WV, LDWV ) 41486 CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ), 41487 $ LDZ, WV( 1, 1+I2 ), LDWV ) 41488 CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE, 41489 $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), 41490 $ LDWV ) 41491 CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE, 41492 $ Z( JROW, INCOL+1+J2 ), LDZ, 41493 $ U( J2+1, I2+1 ), LDU, ONE, 41494 $ WV( 1, 1+I2 ), LDWV ) 41495 CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV, 41496 $ Z( JROW, INCOL+1 ), LDZ ) 41497 200 CONTINUE 41498 END IF 41499 END IF 41500 END IF 41501 210 CONTINUE 41502 END 41503! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlar1v.f 41504 SUBROUTINE ZLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, 41505 $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, 41506 $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) 41507 LOGICAL WANTNC 41508 INTEGER B1, BN, N, NEGCNT, R 41509 DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID, 41510 $ RQCORR, ZTZ 41511 INTEGER ISUPPZ( * ) 41512 DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ), 41513 $ WORK( * ) 41514 COMPLEX*16 Z( * ) 41515 DOUBLE PRECISION ZERO, ONE 41516 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 41517 COMPLEX*16 CONE 41518 PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) 41519 LOGICAL SAWNAN1, SAWNAN2 41520 INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1, 41521 $ R2 41522 DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP 41523 LOGICAL DISNAN 41524 DOUBLE PRECISION DLAMCH 41525 EXTERNAL DISNAN, DLAMCH 41526 INTRINSIC ABS, DBLE 41527 EPS = DLAMCH( 'Precision' ) 41528 IF( R.EQ.0 ) THEN 41529 R1 = B1 41530 R2 = BN 41531 ELSE 41532 R1 = R 41533 R2 = R 41534 END IF 41535 INDLPL = 0 41536 INDUMN = N 41537 INDS = 2*N + 1 41538 INDP = 3*N + 1 41539 IF( B1.EQ.1 ) THEN 41540 WORK( INDS ) = ZERO 41541 ELSE 41542 WORK( INDS+B1-1 ) = LLD( B1-1 ) 41543 END IF 41544 SAWNAN1 = .FALSE. 41545 NEG1 = 0 41546 S = WORK( INDS+B1-1 ) - LAMBDA 41547 DO 50 I = B1, R1 - 1 41548 DPLUS = D( I ) + S 41549 WORK( INDLPL+I ) = LD( I ) / DPLUS 41550 IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1 41551 WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) 41552 S = WORK( INDS+I ) - LAMBDA 41553 50 CONTINUE 41554 SAWNAN1 = DISNAN( S ) 41555 IF( SAWNAN1 ) GOTO 60 41556 DO 51 I = R1, R2 - 1 41557 DPLUS = D( I ) + S 41558 WORK( INDLPL+I ) = LD( I ) / DPLUS 41559 WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) 41560 S = WORK( INDS+I ) - LAMBDA 41561 51 CONTINUE 41562 SAWNAN1 = DISNAN( S ) 41563 60 CONTINUE 41564 IF( SAWNAN1 ) THEN 41565 NEG1 = 0 41566 S = WORK( INDS+B1-1 ) - LAMBDA 41567 DO 70 I = B1, R1 - 1 41568 DPLUS = D( I ) + S 41569 IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN 41570 WORK( INDLPL+I ) = LD( I ) / DPLUS 41571 IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1 41572 WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) 41573 IF( WORK( INDLPL+I ).EQ.ZERO ) 41574 $ WORK( INDS+I ) = LLD( I ) 41575 S = WORK( INDS+I ) - LAMBDA 41576 70 CONTINUE 41577 DO 71 I = R1, R2 - 1 41578 DPLUS = D( I ) + S 41579 IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN 41580 WORK( INDLPL+I ) = LD( I ) / DPLUS 41581 WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I ) 41582 IF( WORK( INDLPL+I ).EQ.ZERO ) 41583 $ WORK( INDS+I ) = LLD( I ) 41584 S = WORK( INDS+I ) - LAMBDA 41585 71 CONTINUE 41586 END IF 41587 SAWNAN2 = .FALSE. 41588 NEG2 = 0 41589 WORK( INDP+BN-1 ) = D( BN ) - LAMBDA 41590 DO 80 I = BN - 1, R1, -1 41591 DMINUS = LLD( I ) + WORK( INDP+I ) 41592 TMP = D( I ) / DMINUS 41593 IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1 41594 WORK( INDUMN+I ) = L( I )*TMP 41595 WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA 41596 80 CONTINUE 41597 TMP = WORK( INDP+R1-1 ) 41598 SAWNAN2 = DISNAN( TMP ) 41599 IF( SAWNAN2 ) THEN 41600 NEG2 = 0 41601 DO 100 I = BN-1, R1, -1 41602 DMINUS = LLD( I ) + WORK( INDP+I ) 41603 IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN 41604 TMP = D( I ) / DMINUS 41605 IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1 41606 WORK( INDUMN+I ) = L( I )*TMP 41607 WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA 41608 IF( TMP.EQ.ZERO ) 41609 $ WORK( INDP+I-1 ) = D( I ) - LAMBDA 41610 100 CONTINUE 41611 END IF 41612 MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 ) 41613 IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1 41614 IF( WANTNC ) THEN 41615 NEGCNT = NEG1 + NEG2 41616 ELSE 41617 NEGCNT = -1 41618 ENDIF 41619 IF( ABS(MINGMA).EQ.ZERO ) 41620 $ MINGMA = EPS*WORK( INDS+R1-1 ) 41621 R = R1 41622 DO 110 I = R1, R2 - 1 41623 TMP = WORK( INDS+I ) + WORK( INDP+I ) 41624 IF( TMP.EQ.ZERO ) 41625 $ TMP = EPS*WORK( INDS+I ) 41626 IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN 41627 MINGMA = TMP 41628 R = I + 1 41629 END IF 41630 110 CONTINUE 41631 ISUPPZ( 1 ) = B1 41632 ISUPPZ( 2 ) = BN 41633 Z( R ) = CONE 41634 ZTZ = ONE 41635 IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN 41636 DO 210 I = R-1, B1, -1 41637 Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) ) 41638 IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) 41639 $ THEN 41640 Z( I ) = ZERO 41641 ISUPPZ( 1 ) = I + 1 41642 GOTO 220 41643 ENDIF 41644 ZTZ = ZTZ + DBLE( Z( I )*Z( I ) ) 41645 210 CONTINUE 41646 220 CONTINUE 41647 ELSE 41648 DO 230 I = R - 1, B1, -1 41649 IF( Z( I+1 ).EQ.ZERO ) THEN 41650 Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 ) 41651 ELSE 41652 Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) ) 41653 END IF 41654 IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) 41655 $ THEN 41656 Z( I ) = ZERO 41657 ISUPPZ( 1 ) = I + 1 41658 GO TO 240 41659 END IF 41660 ZTZ = ZTZ + DBLE( Z( I )*Z( I ) ) 41661 230 CONTINUE 41662 240 CONTINUE 41663 ENDIF 41664 IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN 41665 DO 250 I = R, BN-1 41666 Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) ) 41667 IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) 41668 $ THEN 41669 Z( I+1 ) = ZERO 41670 ISUPPZ( 2 ) = I 41671 GO TO 260 41672 END IF 41673 ZTZ = ZTZ + DBLE( Z( I+1 )*Z( I+1 ) ) 41674 250 CONTINUE 41675 260 CONTINUE 41676 ELSE 41677 DO 270 I = R, BN - 1 41678 IF( Z( I ).EQ.ZERO ) THEN 41679 Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 ) 41680 ELSE 41681 Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) ) 41682 END IF 41683 IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL ) 41684 $ THEN 41685 Z( I+1 ) = ZERO 41686 ISUPPZ( 2 ) = I 41687 GO TO 280 41688 END IF 41689 ZTZ = ZTZ + DBLE( Z( I+1 )*Z( I+1 ) ) 41690 270 CONTINUE 41691 280 CONTINUE 41692 END IF 41693 TMP = ONE / ZTZ 41694 NRMINV = SQRT( TMP ) 41695 RESID = ABS( MINGMA )*NRMINV 41696 RQCORR = MINGMA*TMP 41697 RETURN 41698 END 41699! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlarf.f 41700 SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) 41701 CHARACTER SIDE 41702 INTEGER INCV, LDC, M, N 41703 COMPLEX*16 TAU 41704 COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) 41705 COMPLEX*16 ONE, ZERO 41706 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), 41707 $ ZERO = ( 0.0D+0, 0.0D+0 ) ) 41708 LOGICAL APPLYLEFT 41709 INTEGER I, LASTV, LASTC 41710 EXTERNAL ZGEMV, ZGERC 41711 LOGICAL LSAME 41712 INTEGER ILAZLR, ILAZLC 41713 EXTERNAL LSAME, ILAZLR, ILAZLC 41714 APPLYLEFT = LSAME( SIDE, 'L' ) 41715 LASTV = 0 41716 LASTC = 0 41717 IF( TAU.NE.ZERO ) THEN 41718 IF( APPLYLEFT ) THEN 41719 LASTV = M 41720 ELSE 41721 LASTV = N 41722 END IF 41723 IF( INCV.GT.0 ) THEN 41724 I = 1 + (LASTV-1) * INCV 41725 ELSE 41726 I = 1 41727 END IF 41728 DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO ) 41729 LASTV = LASTV - 1 41730 I = I - INCV 41731 END DO 41732 IF( APPLYLEFT ) THEN 41733 LASTC = ILAZLC(LASTV, N, C, LDC) 41734 ELSE 41735 LASTC = ILAZLR(M, LASTV, C, LDC) 41736 END IF 41737 END IF 41738 IF( APPLYLEFT ) THEN 41739 IF( LASTV.GT.0 ) THEN 41740 CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE, 41741 $ C, LDC, V, INCV, ZERO, WORK, 1 ) 41742 CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC ) 41743 END IF 41744 ELSE 41745 IF( LASTV.GT.0 ) THEN 41746 CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC, 41747 $ V, INCV, ZERO, WORK, 1 ) 41748 CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC ) 41749 END IF 41750 END IF 41751 RETURN 41752 END 41753! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlarfb.f 41754 SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, 41755 $ T, LDT, C, LDC, WORK, LDWORK ) 41756 CHARACTER DIRECT, SIDE, STOREV, TRANS 41757 INTEGER K, LDC, LDT, LDV, LDWORK, M, N 41758 COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), 41759 $ WORK( LDWORK, * ) 41760 COMPLEX*16 ONE 41761 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 41762 CHARACTER TRANST 41763 INTEGER I, J 41764 LOGICAL LSAME 41765 EXTERNAL LSAME 41766 EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM 41767 INTRINSIC DCONJG 41768 IF( M.LE.0 .OR. N.LE.0 ) 41769 $ RETURN 41770 IF( LSAME( TRANS, 'N' ) ) THEN 41771 TRANST = 'C' 41772 ELSE 41773 TRANST = 'N' 41774 END IF 41775 IF( LSAME( STOREV, 'C' ) ) THEN 41776 IF( LSAME( DIRECT, 'F' ) ) THEN 41777 IF( LSAME( SIDE, 'L' ) ) THEN 41778 DO 10 J = 1, K 41779 CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 41780 CALL ZLACGV( N, WORK( 1, J ), 1 ) 41781 10 CONTINUE 41782 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, 41783 $ K, ONE, V, LDV, WORK, LDWORK ) 41784 IF( M.GT.K ) THEN 41785 CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, 41786 $ K, M-K, ONE, C( K+1, 1 ), LDC, 41787 $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) 41788 END IF 41789 CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, 41790 $ ONE, T, LDT, WORK, LDWORK ) 41791 IF( M.GT.K ) THEN 41792 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 41793 $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, 41794 $ LDWORK, ONE, C( K+1, 1 ), LDC ) 41795 END IF 41796 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 41797 $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) 41798 DO 30 J = 1, K 41799 DO 20 I = 1, N 41800 C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 41801 20 CONTINUE 41802 30 CONTINUE 41803 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 41804 DO 40 J = 1, K 41805 CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 41806 40 CONTINUE 41807 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, 41808 $ K, ONE, V, LDV, WORK, LDWORK ) 41809 IF( N.GT.K ) THEN 41810 CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, 41811 $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, 41812 $ ONE, WORK, LDWORK ) 41813 END IF 41814 CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, 41815 $ ONE, T, LDT, WORK, LDWORK ) 41816 IF( N.GT.K ) THEN 41817 CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, 41818 $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ), 41819 $ LDV, ONE, C( 1, K+1 ), LDC ) 41820 END IF 41821 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 41822 $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) 41823 DO 60 J = 1, K 41824 DO 50 I = 1, M 41825 C( I, J ) = C( I, J ) - WORK( I, J ) 41826 50 CONTINUE 41827 60 CONTINUE 41828 END IF 41829 ELSE 41830 IF( LSAME( SIDE, 'L' ) ) THEN 41831 DO 70 J = 1, K 41832 CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 41833 CALL ZLACGV( N, WORK( 1, J ), 1 ) 41834 70 CONTINUE 41835 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, 41836 $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) 41837 IF( M.GT.K ) THEN 41838 CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, 41839 $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, 41840 $ LDWORK ) 41841 END IF 41842 CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, 41843 $ ONE, T, LDT, WORK, LDWORK ) 41844 IF( M.GT.K ) THEN 41845 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 41846 $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, 41847 $ ONE, C, LDC ) 41848 END IF 41849 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 41850 $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, 41851 $ LDWORK ) 41852 DO 90 J = 1, K 41853 DO 80 I = 1, N 41854 C( M-K+J, I ) = C( M-K+J, I ) - 41855 $ DCONJG( WORK( I, J ) ) 41856 80 CONTINUE 41857 90 CONTINUE 41858 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 41859 DO 100 J = 1, K 41860 CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 41861 100 CONTINUE 41862 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, 41863 $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) 41864 IF( N.GT.K ) THEN 41865 CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, 41866 $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) 41867 END IF 41868 CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, 41869 $ ONE, T, LDT, WORK, LDWORK ) 41870 IF( N.GT.K ) THEN 41871 CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, 41872 $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, 41873 $ C, LDC ) 41874 END IF 41875 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 41876 $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, 41877 $ LDWORK ) 41878 DO 120 J = 1, K 41879 DO 110 I = 1, M 41880 C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 41881 110 CONTINUE 41882 120 CONTINUE 41883 END IF 41884 END IF 41885 ELSE IF( LSAME( STOREV, 'R' ) ) THEN 41886 IF( LSAME( DIRECT, 'F' ) ) THEN 41887 IF( LSAME( SIDE, 'L' ) ) THEN 41888 DO 130 J = 1, K 41889 CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 41890 CALL ZLACGV( N, WORK( 1, J ), 1 ) 41891 130 CONTINUE 41892 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 41893 $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) 41894 IF( M.GT.K ) THEN 41895 CALL ZGEMM( 'Conjugate transpose', 41896 $ 'Conjugate transpose', N, K, M-K, ONE, 41897 $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, 41898 $ WORK, LDWORK ) 41899 END IF 41900 CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, 41901 $ ONE, T, LDT, WORK, LDWORK ) 41902 IF( M.GT.K ) THEN 41903 CALL ZGEMM( 'Conjugate transpose', 41904 $ 'Conjugate transpose', M-K, N, K, -ONE, 41905 $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, 41906 $ C( K+1, 1 ), LDC ) 41907 END IF 41908 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, 41909 $ K, ONE, V, LDV, WORK, LDWORK ) 41910 DO 150 J = 1, K 41911 DO 140 I = 1, N 41912 C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 41913 140 CONTINUE 41914 150 CONTINUE 41915 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 41916 DO 160 J = 1, K 41917 CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 41918 160 CONTINUE 41919 CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', 41920 $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) 41921 IF( N.GT.K ) THEN 41922 CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, 41923 $ K, N-K, ONE, C( 1, K+1 ), LDC, 41924 $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) 41925 END IF 41926 CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, 41927 $ ONE, T, LDT, WORK, LDWORK ) 41928 IF( N.GT.K ) THEN 41929 CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, 41930 $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, 41931 $ C( 1, K+1 ), LDC ) 41932 END IF 41933 CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, 41934 $ K, ONE, V, LDV, WORK, LDWORK ) 41935 DO 180 J = 1, K 41936 DO 170 I = 1, M 41937 C( I, J ) = C( I, J ) - WORK( I, J ) 41938 170 CONTINUE 41939 180 CONTINUE 41940 END IF 41941 ELSE 41942 IF( LSAME( SIDE, 'L' ) ) THEN 41943 DO 190 J = 1, K 41944 CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 41945 CALL ZLACGV( N, WORK( 1, J ), 1 ) 41946 190 CONTINUE 41947 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 41948 $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, 41949 $ LDWORK ) 41950 IF( M.GT.K ) THEN 41951 CALL ZGEMM( 'Conjugate transpose', 41952 $ 'Conjugate transpose', N, K, M-K, ONE, C, 41953 $ LDC, V, LDV, ONE, WORK, LDWORK ) 41954 END IF 41955 CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, 41956 $ ONE, T, LDT, WORK, LDWORK ) 41957 IF( M.GT.K ) THEN 41958 CALL ZGEMM( 'Conjugate transpose', 41959 $ 'Conjugate transpose', M-K, N, K, -ONE, V, 41960 $ LDV, WORK, LDWORK, ONE, C, LDC ) 41961 END IF 41962 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, 41963 $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) 41964 DO 210 J = 1, K 41965 DO 200 I = 1, N 41966 C( M-K+J, I ) = C( M-K+J, I ) - 41967 $ DCONJG( WORK( I, J ) ) 41968 200 CONTINUE 41969 210 CONTINUE 41970 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 41971 DO 220 J = 1, K 41972 CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 41973 220 CONTINUE 41974 CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', 41975 $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, 41976 $ LDWORK ) 41977 IF( N.GT.K ) THEN 41978 CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, 41979 $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK, 41980 $ LDWORK ) 41981 END IF 41982 CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, 41983 $ ONE, T, LDT, WORK, LDWORK ) 41984 IF( N.GT.K ) THEN 41985 CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, 41986 $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) 41987 END IF 41988 CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, 41989 $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) 41990 DO 240 J = 1, K 41991 DO 230 I = 1, M 41992 C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 41993 230 CONTINUE 41994 240 CONTINUE 41995 END IF 41996 END IF 41997 END IF 41998 RETURN 41999 END 42000! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlarfg.f 42001 SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) 42002 INTEGER INCX, N 42003 COMPLEX*16 ALPHA, TAU 42004 COMPLEX*16 X( * ) 42005 DOUBLE PRECISION ONE, ZERO 42006 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 42007 INTEGER J, KNT 42008 DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM 42009 DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 42010 COMPLEX*16 ZLADIV 42011 EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV 42012 INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN 42013 EXTERNAL ZDSCAL, ZSCAL 42014 IF( N.LE.0 ) THEN 42015 TAU = ZERO 42016 RETURN 42017 END IF 42018 XNORM = DZNRM2( N-1, X, INCX ) 42019 ALPHR = DBLE( ALPHA ) 42020 ALPHI = DIMAG( ALPHA ) 42021 IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN 42022 TAU = ZERO 42023 ELSE 42024 BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) 42025 SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) 42026 RSAFMN = ONE / SAFMIN 42027 KNT = 0 42028 IF( ABS( BETA ).LT.SAFMIN ) THEN 42029 10 CONTINUE 42030 KNT = KNT + 1 42031 CALL ZDSCAL( N-1, RSAFMN, X, INCX ) 42032 BETA = BETA*RSAFMN 42033 ALPHI = ALPHI*RSAFMN 42034 ALPHR = ALPHR*RSAFMN 42035 IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) ) 42036 $ GO TO 10 42037 XNORM = DZNRM2( N-1, X, INCX ) 42038 ALPHA = DCMPLX( ALPHR, ALPHI ) 42039 BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) 42040 END IF 42041 TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) 42042 ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) 42043 CALL ZSCAL( N-1, ALPHA, X, INCX ) 42044 DO 20 J = 1, KNT 42045 BETA = BETA*SAFMIN 42046 20 CONTINUE 42047 ALPHA = BETA 42048 END IF 42049 RETURN 42050 END 42051! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlarft.f 42052 SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) 42053 CHARACTER DIRECT, STOREV 42054 INTEGER K, LDT, LDV, N 42055 COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) 42056 COMPLEX*16 ONE, ZERO 42057 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), 42058 $ ZERO = ( 0.0D+0, 0.0D+0 ) ) 42059 INTEGER I, J, PREVLASTV, LASTV 42060 EXTERNAL ZGEMV, ZTRMV, ZGEMM 42061 LOGICAL LSAME 42062 EXTERNAL LSAME 42063 IF( N.EQ.0 ) 42064 $ RETURN 42065 IF( LSAME( DIRECT, 'F' ) ) THEN 42066 PREVLASTV = N 42067 DO I = 1, K 42068 PREVLASTV = MAX( PREVLASTV, I ) 42069 IF( TAU( I ).EQ.ZERO ) THEN 42070 DO J = 1, I 42071 T( J, I ) = ZERO 42072 END DO 42073 ELSE 42074 IF( LSAME( STOREV, 'C' ) ) THEN 42075 DO LASTV = N, I+1, -1 42076 IF( V( LASTV, I ).NE.ZERO ) EXIT 42077 END DO 42078 DO J = 1, I-1 42079 T( J, I ) = -TAU( I ) * CONJG( V( I , J ) ) 42080 END DO 42081 J = MIN( LASTV, PREVLASTV ) 42082 CALL ZGEMV( 'Conjugate transpose', J-I, I-1, 42083 $ -TAU( I ), V( I+1, 1 ), LDV, 42084 $ V( I+1, I ), 1, ONE, T( 1, I ), 1 ) 42085 ELSE 42086 DO LASTV = N, I+1, -1 42087 IF( V( I, LASTV ).NE.ZERO ) EXIT 42088 END DO 42089 DO J = 1, I-1 42090 T( J, I ) = -TAU( I ) * V( J , I ) 42091 END DO 42092 J = MIN( LASTV, PREVLASTV ) 42093 CALL ZGEMM( 'N', 'C', I-1, 1, J-I, -TAU( I ), 42094 $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, 42095 $ ONE, T( 1, I ), LDT ) 42096 END IF 42097 CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, 42098 $ LDT, T( 1, I ), 1 ) 42099 T( I, I ) = TAU( I ) 42100 IF( I.GT.1 ) THEN 42101 PREVLASTV = MAX( PREVLASTV, LASTV ) 42102 ELSE 42103 PREVLASTV = LASTV 42104 END IF 42105 END IF 42106 END DO 42107 ELSE 42108 PREVLASTV = 1 42109 DO I = K, 1, -1 42110 IF( TAU( I ).EQ.ZERO ) THEN 42111 DO J = I, K 42112 T( J, I ) = ZERO 42113 END DO 42114 ELSE 42115 IF( I.LT.K ) THEN 42116 IF( LSAME( STOREV, 'C' ) ) THEN 42117 DO LASTV = 1, I-1 42118 IF( V( LASTV, I ).NE.ZERO ) EXIT 42119 END DO 42120 DO J = I+1, K 42121 T( J, I ) = -TAU( I ) * CONJG( V( N-K+I , J ) ) 42122 END DO 42123 J = MAX( LASTV, PREVLASTV ) 42124 CALL ZGEMV( 'Conjugate transpose', N-K+I-J, K-I, 42125 $ -TAU( I ), V( J, I+1 ), LDV, V( J, I ), 42126 $ 1, ONE, T( I+1, I ), 1 ) 42127 ELSE 42128 DO LASTV = 1, I-1 42129 IF( V( I, LASTV ).NE.ZERO ) EXIT 42130 END DO 42131 DO J = I+1, K 42132 T( J, I ) = -TAU( I ) * V( J, N-K+I ) 42133 END DO 42134 J = MAX( LASTV, PREVLASTV ) 42135 CALL ZGEMM( 'N', 'C', K-I, 1, N-K+I-J, -TAU( I ), 42136 $ V( I+1, J ), LDV, V( I, J ), LDV, 42137 $ ONE, T( I+1, I ), LDT ) 42138 END IF 42139 CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, 42140 $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) 42141 IF( I.GT.1 ) THEN 42142 PREVLASTV = MIN( PREVLASTV, LASTV ) 42143 ELSE 42144 PREVLASTV = LASTV 42145 END IF 42146 END IF 42147 T( I, I ) = TAU( I ) 42148 END IF 42149 END DO 42150 END IF 42151 RETURN 42152 END 42153! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlarfx.f 42154 SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) 42155 CHARACTER SIDE 42156 INTEGER LDC, M, N 42157 COMPLEX*16 TAU 42158 COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) 42159 COMPLEX*16 ZERO, ONE 42160 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), 42161 $ ONE = ( 1.0D+0, 0.0D+0 ) ) 42162 INTEGER J 42163 COMPLEX*16 SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, 42164 $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 42165 LOGICAL LSAME 42166 EXTERNAL LSAME 42167 EXTERNAL ZLARF 42168 INTRINSIC DCONJG 42169 IF( TAU.EQ.ZERO ) 42170 $ RETURN 42171 IF( LSAME( SIDE, 'L' ) ) THEN 42172 GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, 42173 $ 170, 190 )M 42174 CALL ZLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) 42175 GO TO 410 42176 10 CONTINUE 42177 T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) ) 42178 DO 20 J = 1, N 42179 C( 1, J ) = T1*C( 1, J ) 42180 20 CONTINUE 42181 GO TO 410 42182 30 CONTINUE 42183 V1 = DCONJG( V( 1 ) ) 42184 T1 = TAU*DCONJG( V1 ) 42185 V2 = DCONJG( V( 2 ) ) 42186 T2 = TAU*DCONJG( V2 ) 42187 DO 40 J = 1, N 42188 SUM = V1*C( 1, J ) + V2*C( 2, J ) 42189 C( 1, J ) = C( 1, J ) - SUM*T1 42190 C( 2, J ) = C( 2, J ) - SUM*T2 42191 40 CONTINUE 42192 GO TO 410 42193 50 CONTINUE 42194 V1 = DCONJG( V( 1 ) ) 42195 T1 = TAU*DCONJG( V1 ) 42196 V2 = DCONJG( V( 2 ) ) 42197 T2 = TAU*DCONJG( V2 ) 42198 V3 = DCONJG( V( 3 ) ) 42199 T3 = TAU*DCONJG( V3 ) 42200 DO 60 J = 1, N 42201 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) 42202 C( 1, J ) = C( 1, J ) - SUM*T1 42203 C( 2, J ) = C( 2, J ) - SUM*T2 42204 C( 3, J ) = C( 3, J ) - SUM*T3 42205 60 CONTINUE 42206 GO TO 410 42207 70 CONTINUE 42208 V1 = DCONJG( V( 1 ) ) 42209 T1 = TAU*DCONJG( V1 ) 42210 V2 = DCONJG( V( 2 ) ) 42211 T2 = TAU*DCONJG( V2 ) 42212 V3 = DCONJG( V( 3 ) ) 42213 T3 = TAU*DCONJG( V3 ) 42214 V4 = DCONJG( V( 4 ) ) 42215 T4 = TAU*DCONJG( V4 ) 42216 DO 80 J = 1, N 42217 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 42218 $ V4*C( 4, J ) 42219 C( 1, J ) = C( 1, J ) - SUM*T1 42220 C( 2, J ) = C( 2, J ) - SUM*T2 42221 C( 3, J ) = C( 3, J ) - SUM*T3 42222 C( 4, J ) = C( 4, J ) - SUM*T4 42223 80 CONTINUE 42224 GO TO 410 42225 90 CONTINUE 42226 V1 = DCONJG( V( 1 ) ) 42227 T1 = TAU*DCONJG( V1 ) 42228 V2 = DCONJG( V( 2 ) ) 42229 T2 = TAU*DCONJG( V2 ) 42230 V3 = DCONJG( V( 3 ) ) 42231 T3 = TAU*DCONJG( V3 ) 42232 V4 = DCONJG( V( 4 ) ) 42233 T4 = TAU*DCONJG( V4 ) 42234 V5 = DCONJG( V( 5 ) ) 42235 T5 = TAU*DCONJG( V5 ) 42236 DO 100 J = 1, N 42237 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 42238 $ V4*C( 4, J ) + V5*C( 5, J ) 42239 C( 1, J ) = C( 1, J ) - SUM*T1 42240 C( 2, J ) = C( 2, J ) - SUM*T2 42241 C( 3, J ) = C( 3, J ) - SUM*T3 42242 C( 4, J ) = C( 4, J ) - SUM*T4 42243 C( 5, J ) = C( 5, J ) - SUM*T5 42244 100 CONTINUE 42245 GO TO 410 42246 110 CONTINUE 42247 V1 = DCONJG( V( 1 ) ) 42248 T1 = TAU*DCONJG( V1 ) 42249 V2 = DCONJG( V( 2 ) ) 42250 T2 = TAU*DCONJG( V2 ) 42251 V3 = DCONJG( V( 3 ) ) 42252 T3 = TAU*DCONJG( V3 ) 42253 V4 = DCONJG( V( 4 ) ) 42254 T4 = TAU*DCONJG( V4 ) 42255 V5 = DCONJG( V( 5 ) ) 42256 T5 = TAU*DCONJG( V5 ) 42257 V6 = DCONJG( V( 6 ) ) 42258 T6 = TAU*DCONJG( V6 ) 42259 DO 120 J = 1, N 42260 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 42261 $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) 42262 C( 1, J ) = C( 1, J ) - SUM*T1 42263 C( 2, J ) = C( 2, J ) - SUM*T2 42264 C( 3, J ) = C( 3, J ) - SUM*T3 42265 C( 4, J ) = C( 4, J ) - SUM*T4 42266 C( 5, J ) = C( 5, J ) - SUM*T5 42267 C( 6, J ) = C( 6, J ) - SUM*T6 42268 120 CONTINUE 42269 GO TO 410 42270 130 CONTINUE 42271 V1 = DCONJG( V( 1 ) ) 42272 T1 = TAU*DCONJG( V1 ) 42273 V2 = DCONJG( V( 2 ) ) 42274 T2 = TAU*DCONJG( V2 ) 42275 V3 = DCONJG( V( 3 ) ) 42276 T3 = TAU*DCONJG( V3 ) 42277 V4 = DCONJG( V( 4 ) ) 42278 T4 = TAU*DCONJG( V4 ) 42279 V5 = DCONJG( V( 5 ) ) 42280 T5 = TAU*DCONJG( V5 ) 42281 V6 = DCONJG( V( 6 ) ) 42282 T6 = TAU*DCONJG( V6 ) 42283 V7 = DCONJG( V( 7 ) ) 42284 T7 = TAU*DCONJG( V7 ) 42285 DO 140 J = 1, N 42286 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 42287 $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + 42288 $ V7*C( 7, J ) 42289 C( 1, J ) = C( 1, J ) - SUM*T1 42290 C( 2, J ) = C( 2, J ) - SUM*T2 42291 C( 3, J ) = C( 3, J ) - SUM*T3 42292 C( 4, J ) = C( 4, J ) - SUM*T4 42293 C( 5, J ) = C( 5, J ) - SUM*T5 42294 C( 6, J ) = C( 6, J ) - SUM*T6 42295 C( 7, J ) = C( 7, J ) - SUM*T7 42296 140 CONTINUE 42297 GO TO 410 42298 150 CONTINUE 42299 V1 = DCONJG( V( 1 ) ) 42300 T1 = TAU*DCONJG( V1 ) 42301 V2 = DCONJG( V( 2 ) ) 42302 T2 = TAU*DCONJG( V2 ) 42303 V3 = DCONJG( V( 3 ) ) 42304 T3 = TAU*DCONJG( V3 ) 42305 V4 = DCONJG( V( 4 ) ) 42306 T4 = TAU*DCONJG( V4 ) 42307 V5 = DCONJG( V( 5 ) ) 42308 T5 = TAU*DCONJG( V5 ) 42309 V6 = DCONJG( V( 6 ) ) 42310 T6 = TAU*DCONJG( V6 ) 42311 V7 = DCONJG( V( 7 ) ) 42312 T7 = TAU*DCONJG( V7 ) 42313 V8 = DCONJG( V( 8 ) ) 42314 T8 = TAU*DCONJG( V8 ) 42315 DO 160 J = 1, N 42316 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 42317 $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + 42318 $ V7*C( 7, J ) + V8*C( 8, J ) 42319 C( 1, J ) = C( 1, J ) - SUM*T1 42320 C( 2, J ) = C( 2, J ) - SUM*T2 42321 C( 3, J ) = C( 3, J ) - SUM*T3 42322 C( 4, J ) = C( 4, J ) - SUM*T4 42323 C( 5, J ) = C( 5, J ) - SUM*T5 42324 C( 6, J ) = C( 6, J ) - SUM*T6 42325 C( 7, J ) = C( 7, J ) - SUM*T7 42326 C( 8, J ) = C( 8, J ) - SUM*T8 42327 160 CONTINUE 42328 GO TO 410 42329 170 CONTINUE 42330 V1 = DCONJG( V( 1 ) ) 42331 T1 = TAU*DCONJG( V1 ) 42332 V2 = DCONJG( V( 2 ) ) 42333 T2 = TAU*DCONJG( V2 ) 42334 V3 = DCONJG( V( 3 ) ) 42335 T3 = TAU*DCONJG( V3 ) 42336 V4 = DCONJG( V( 4 ) ) 42337 T4 = TAU*DCONJG( V4 ) 42338 V5 = DCONJG( V( 5 ) ) 42339 T5 = TAU*DCONJG( V5 ) 42340 V6 = DCONJG( V( 6 ) ) 42341 T6 = TAU*DCONJG( V6 ) 42342 V7 = DCONJG( V( 7 ) ) 42343 T7 = TAU*DCONJG( V7 ) 42344 V8 = DCONJG( V( 8 ) ) 42345 T8 = TAU*DCONJG( V8 ) 42346 V9 = DCONJG( V( 9 ) ) 42347 T9 = TAU*DCONJG( V9 ) 42348 DO 180 J = 1, N 42349 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 42350 $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + 42351 $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) 42352 C( 1, J ) = C( 1, J ) - SUM*T1 42353 C( 2, J ) = C( 2, J ) - SUM*T2 42354 C( 3, J ) = C( 3, J ) - SUM*T3 42355 C( 4, J ) = C( 4, J ) - SUM*T4 42356 C( 5, J ) = C( 5, J ) - SUM*T5 42357 C( 6, J ) = C( 6, J ) - SUM*T6 42358 C( 7, J ) = C( 7, J ) - SUM*T7 42359 C( 8, J ) = C( 8, J ) - SUM*T8 42360 C( 9, J ) = C( 9, J ) - SUM*T9 42361 180 CONTINUE 42362 GO TO 410 42363 190 CONTINUE 42364 V1 = DCONJG( V( 1 ) ) 42365 T1 = TAU*DCONJG( V1 ) 42366 V2 = DCONJG( V( 2 ) ) 42367 T2 = TAU*DCONJG( V2 ) 42368 V3 = DCONJG( V( 3 ) ) 42369 T3 = TAU*DCONJG( V3 ) 42370 V4 = DCONJG( V( 4 ) ) 42371 T4 = TAU*DCONJG( V4 ) 42372 V5 = DCONJG( V( 5 ) ) 42373 T5 = TAU*DCONJG( V5 ) 42374 V6 = DCONJG( V( 6 ) ) 42375 T6 = TAU*DCONJG( V6 ) 42376 V7 = DCONJG( V( 7 ) ) 42377 T7 = TAU*DCONJG( V7 ) 42378 V8 = DCONJG( V( 8 ) ) 42379 T8 = TAU*DCONJG( V8 ) 42380 V9 = DCONJG( V( 9 ) ) 42381 T9 = TAU*DCONJG( V9 ) 42382 V10 = DCONJG( V( 10 ) ) 42383 T10 = TAU*DCONJG( V10 ) 42384 DO 200 J = 1, N 42385 SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + 42386 $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + 42387 $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + 42388 $ V10*C( 10, J ) 42389 C( 1, J ) = C( 1, J ) - SUM*T1 42390 C( 2, J ) = C( 2, J ) - SUM*T2 42391 C( 3, J ) = C( 3, J ) - SUM*T3 42392 C( 4, J ) = C( 4, J ) - SUM*T4 42393 C( 5, J ) = C( 5, J ) - SUM*T5 42394 C( 6, J ) = C( 6, J ) - SUM*T6 42395 C( 7, J ) = C( 7, J ) - SUM*T7 42396 C( 8, J ) = C( 8, J ) - SUM*T8 42397 C( 9, J ) = C( 9, J ) - SUM*T9 42398 C( 10, J ) = C( 10, J ) - SUM*T10 42399 200 CONTINUE 42400 GO TO 410 42401 ELSE 42402 GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, 42403 $ 370, 390 )N 42404 CALL ZLARF( SIDE, M, N, V, 1, TAU, C, LDC, WORK ) 42405 GO TO 410 42406 210 CONTINUE 42407 T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) ) 42408 DO 220 J = 1, M 42409 C( J, 1 ) = T1*C( J, 1 ) 42410 220 CONTINUE 42411 GO TO 410 42412 230 CONTINUE 42413 V1 = V( 1 ) 42414 T1 = TAU*DCONJG( V1 ) 42415 V2 = V( 2 ) 42416 T2 = TAU*DCONJG( V2 ) 42417 DO 240 J = 1, M 42418 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) 42419 C( J, 1 ) = C( J, 1 ) - SUM*T1 42420 C( J, 2 ) = C( J, 2 ) - SUM*T2 42421 240 CONTINUE 42422 GO TO 410 42423 250 CONTINUE 42424 V1 = V( 1 ) 42425 T1 = TAU*DCONJG( V1 ) 42426 V2 = V( 2 ) 42427 T2 = TAU*DCONJG( V2 ) 42428 V3 = V( 3 ) 42429 T3 = TAU*DCONJG( V3 ) 42430 DO 260 J = 1, M 42431 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) 42432 C( J, 1 ) = C( J, 1 ) - SUM*T1 42433 C( J, 2 ) = C( J, 2 ) - SUM*T2 42434 C( J, 3 ) = C( J, 3 ) - SUM*T3 42435 260 CONTINUE 42436 GO TO 410 42437 270 CONTINUE 42438 V1 = V( 1 ) 42439 T1 = TAU*DCONJG( V1 ) 42440 V2 = V( 2 ) 42441 T2 = TAU*DCONJG( V2 ) 42442 V3 = V( 3 ) 42443 T3 = TAU*DCONJG( V3 ) 42444 V4 = V( 4 ) 42445 T4 = TAU*DCONJG( V4 ) 42446 DO 280 J = 1, M 42447 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 42448 $ V4*C( J, 4 ) 42449 C( J, 1 ) = C( J, 1 ) - SUM*T1 42450 C( J, 2 ) = C( J, 2 ) - SUM*T2 42451 C( J, 3 ) = C( J, 3 ) - SUM*T3 42452 C( J, 4 ) = C( J, 4 ) - SUM*T4 42453 280 CONTINUE 42454 GO TO 410 42455 290 CONTINUE 42456 V1 = V( 1 ) 42457 T1 = TAU*DCONJG( V1 ) 42458 V2 = V( 2 ) 42459 T2 = TAU*DCONJG( V2 ) 42460 V3 = V( 3 ) 42461 T3 = TAU*DCONJG( V3 ) 42462 V4 = V( 4 ) 42463 T4 = TAU*DCONJG( V4 ) 42464 V5 = V( 5 ) 42465 T5 = TAU*DCONJG( V5 ) 42466 DO 300 J = 1, M 42467 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 42468 $ V4*C( J, 4 ) + V5*C( J, 5 ) 42469 C( J, 1 ) = C( J, 1 ) - SUM*T1 42470 C( J, 2 ) = C( J, 2 ) - SUM*T2 42471 C( J, 3 ) = C( J, 3 ) - SUM*T3 42472 C( J, 4 ) = C( J, 4 ) - SUM*T4 42473 C( J, 5 ) = C( J, 5 ) - SUM*T5 42474 300 CONTINUE 42475 GO TO 410 42476 310 CONTINUE 42477 V1 = V( 1 ) 42478 T1 = TAU*DCONJG( V1 ) 42479 V2 = V( 2 ) 42480 T2 = TAU*DCONJG( V2 ) 42481 V3 = V( 3 ) 42482 T3 = TAU*DCONJG( V3 ) 42483 V4 = V( 4 ) 42484 T4 = TAU*DCONJG( V4 ) 42485 V5 = V( 5 ) 42486 T5 = TAU*DCONJG( V5 ) 42487 V6 = V( 6 ) 42488 T6 = TAU*DCONJG( V6 ) 42489 DO 320 J = 1, M 42490 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 42491 $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) 42492 C( J, 1 ) = C( J, 1 ) - SUM*T1 42493 C( J, 2 ) = C( J, 2 ) - SUM*T2 42494 C( J, 3 ) = C( J, 3 ) - SUM*T3 42495 C( J, 4 ) = C( J, 4 ) - SUM*T4 42496 C( J, 5 ) = C( J, 5 ) - SUM*T5 42497 C( J, 6 ) = C( J, 6 ) - SUM*T6 42498 320 CONTINUE 42499 GO TO 410 42500 330 CONTINUE 42501 V1 = V( 1 ) 42502 T1 = TAU*DCONJG( V1 ) 42503 V2 = V( 2 ) 42504 T2 = TAU*DCONJG( V2 ) 42505 V3 = V( 3 ) 42506 T3 = TAU*DCONJG( V3 ) 42507 V4 = V( 4 ) 42508 T4 = TAU*DCONJG( V4 ) 42509 V5 = V( 5 ) 42510 T5 = TAU*DCONJG( V5 ) 42511 V6 = V( 6 ) 42512 T6 = TAU*DCONJG( V6 ) 42513 V7 = V( 7 ) 42514 T7 = TAU*DCONJG( V7 ) 42515 DO 340 J = 1, M 42516 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 42517 $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + 42518 $ V7*C( J, 7 ) 42519 C( J, 1 ) = C( J, 1 ) - SUM*T1 42520 C( J, 2 ) = C( J, 2 ) - SUM*T2 42521 C( J, 3 ) = C( J, 3 ) - SUM*T3 42522 C( J, 4 ) = C( J, 4 ) - SUM*T4 42523 C( J, 5 ) = C( J, 5 ) - SUM*T5 42524 C( J, 6 ) = C( J, 6 ) - SUM*T6 42525 C( J, 7 ) = C( J, 7 ) - SUM*T7 42526 340 CONTINUE 42527 GO TO 410 42528 350 CONTINUE 42529 V1 = V( 1 ) 42530 T1 = TAU*DCONJG( V1 ) 42531 V2 = V( 2 ) 42532 T2 = TAU*DCONJG( V2 ) 42533 V3 = V( 3 ) 42534 T3 = TAU*DCONJG( V3 ) 42535 V4 = V( 4 ) 42536 T4 = TAU*DCONJG( V4 ) 42537 V5 = V( 5 ) 42538 T5 = TAU*DCONJG( V5 ) 42539 V6 = V( 6 ) 42540 T6 = TAU*DCONJG( V6 ) 42541 V7 = V( 7 ) 42542 T7 = TAU*DCONJG( V7 ) 42543 V8 = V( 8 ) 42544 T8 = TAU*DCONJG( V8 ) 42545 DO 360 J = 1, M 42546 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 42547 $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + 42548 $ V7*C( J, 7 ) + V8*C( J, 8 ) 42549 C( J, 1 ) = C( J, 1 ) - SUM*T1 42550 C( J, 2 ) = C( J, 2 ) - SUM*T2 42551 C( J, 3 ) = C( J, 3 ) - SUM*T3 42552 C( J, 4 ) = C( J, 4 ) - SUM*T4 42553 C( J, 5 ) = C( J, 5 ) - SUM*T5 42554 C( J, 6 ) = C( J, 6 ) - SUM*T6 42555 C( J, 7 ) = C( J, 7 ) - SUM*T7 42556 C( J, 8 ) = C( J, 8 ) - SUM*T8 42557 360 CONTINUE 42558 GO TO 410 42559 370 CONTINUE 42560 V1 = V( 1 ) 42561 T1 = TAU*DCONJG( V1 ) 42562 V2 = V( 2 ) 42563 T2 = TAU*DCONJG( V2 ) 42564 V3 = V( 3 ) 42565 T3 = TAU*DCONJG( V3 ) 42566 V4 = V( 4 ) 42567 T4 = TAU*DCONJG( V4 ) 42568 V5 = V( 5 ) 42569 T5 = TAU*DCONJG( V5 ) 42570 V6 = V( 6 ) 42571 T6 = TAU*DCONJG( V6 ) 42572 V7 = V( 7 ) 42573 T7 = TAU*DCONJG( V7 ) 42574 V8 = V( 8 ) 42575 T8 = TAU*DCONJG( V8 ) 42576 V9 = V( 9 ) 42577 T9 = TAU*DCONJG( V9 ) 42578 DO 380 J = 1, M 42579 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 42580 $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + 42581 $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) 42582 C( J, 1 ) = C( J, 1 ) - SUM*T1 42583 C( J, 2 ) = C( J, 2 ) - SUM*T2 42584 C( J, 3 ) = C( J, 3 ) - SUM*T3 42585 C( J, 4 ) = C( J, 4 ) - SUM*T4 42586 C( J, 5 ) = C( J, 5 ) - SUM*T5 42587 C( J, 6 ) = C( J, 6 ) - SUM*T6 42588 C( J, 7 ) = C( J, 7 ) - SUM*T7 42589 C( J, 8 ) = C( J, 8 ) - SUM*T8 42590 C( J, 9 ) = C( J, 9 ) - SUM*T9 42591 380 CONTINUE 42592 GO TO 410 42593 390 CONTINUE 42594 V1 = V( 1 ) 42595 T1 = TAU*DCONJG( V1 ) 42596 V2 = V( 2 ) 42597 T2 = TAU*DCONJG( V2 ) 42598 V3 = V( 3 ) 42599 T3 = TAU*DCONJG( V3 ) 42600 V4 = V( 4 ) 42601 T4 = TAU*DCONJG( V4 ) 42602 V5 = V( 5 ) 42603 T5 = TAU*DCONJG( V5 ) 42604 V6 = V( 6 ) 42605 T6 = TAU*DCONJG( V6 ) 42606 V7 = V( 7 ) 42607 T7 = TAU*DCONJG( V7 ) 42608 V8 = V( 8 ) 42609 T8 = TAU*DCONJG( V8 ) 42610 V9 = V( 9 ) 42611 T9 = TAU*DCONJG( V9 ) 42612 V10 = V( 10 ) 42613 T10 = TAU*DCONJG( V10 ) 42614 DO 400 J = 1, M 42615 SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + 42616 $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + 42617 $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + 42618 $ V10*C( J, 10 ) 42619 C( J, 1 ) = C( J, 1 ) - SUM*T1 42620 C( J, 2 ) = C( J, 2 ) - SUM*T2 42621 C( J, 3 ) = C( J, 3 ) - SUM*T3 42622 C( J, 4 ) = C( J, 4 ) - SUM*T4 42623 C( J, 5 ) = C( J, 5 ) - SUM*T5 42624 C( J, 6 ) = C( J, 6 ) - SUM*T6 42625 C( J, 7 ) = C( J, 7 ) - SUM*T7 42626 C( J, 8 ) = C( J, 8 ) - SUM*T8 42627 C( J, 9 ) = C( J, 9 ) - SUM*T9 42628 C( J, 10 ) = C( J, 10 ) - SUM*T10 42629 400 CONTINUE 42630 GO TO 410 42631 END IF 42632 410 CONTINUE 42633 RETURN 42634 END 42635! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlarfy.f 42636 SUBROUTINE ZLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) 42637 CHARACTER UPLO 42638 INTEGER INCV, LDC, N 42639 COMPLEX*16 TAU 42640 COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) 42641 COMPLEX*16 ONE, ZERO, HALF 42642 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), 42643 $ ZERO = ( 0.0D+0, 0.0D+0 ), 42644 $ HALF = ( 0.5D+0, 0.0D+0 ) ) 42645 COMPLEX*16 ALPHA 42646 EXTERNAL ZAXPY, ZHEMV, ZHER2 42647 COMPLEX*16 ZDOTC 42648 EXTERNAL ZDOTC 42649 IF( TAU.EQ.ZERO ) 42650 $ RETURN 42651 CALL ZHEMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) 42652 ALPHA = -HALF*TAU*ZDOTC( N, WORK, 1, V, INCV ) 42653 CALL ZAXPY( N, ALPHA, V, INCV, WORK, 1 ) 42654 CALL ZHER2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC ) 42655 RETURN 42656 END 42657! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlarrv.f 42658 SUBROUTINE ZLARRV( N, VL, VU, D, L, PIVMIN, 42659 $ ISPLIT, M, DOL, DOU, MINRGP, 42660 $ RTOL1, RTOL2, W, WERR, WGAP, 42661 $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, 42662 $ WORK, IWORK, INFO ) 42663 INTEGER DOL, DOU, INFO, LDZ, M, N 42664 DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU 42665 INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ), 42666 $ ISUPPZ( * ), IWORK( * ) 42667 DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ), 42668 $ WGAP( * ), WORK( * ) 42669 COMPLEX*16 Z( LDZ, * ) 42670 INTEGER MAXITR 42671 PARAMETER ( MAXITR = 10 ) 42672 COMPLEX*16 CZERO 42673 PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) ) 42674 DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, HALF 42675 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, 42676 $ TWO = 2.0D0, THREE = 3.0D0, 42677 $ FOUR = 4.0D0, HALF = 0.5D0) 42678 LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ 42679 INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1, 42680 $ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG, 42681 $ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER, 42682 $ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS, 42683 $ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST, 42684 $ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST, 42685 $ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX, 42686 $ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU, 42687 $ ZUSEDW 42688 INTEGER INDIN1, INDIN2 42689 DOUBLE PRECISION BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU, 42690 $ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID, 42691 $ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF, 42692 $ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ 42693 DOUBLE PRECISION DLAMCH 42694 EXTERNAL DLAMCH 42695 EXTERNAL DCOPY, DLARRB, DLARRF, ZDSCAL, ZLAR1V, 42696 $ ZLASET 42697 INTRINSIC ABS, DBLE, MAX, MIN 42698 INTRINSIC DCMPLX 42699 INFO = 0 42700 IF( N.LE.0 ) THEN 42701 RETURN 42702 END IF 42703 INDLD = N+1 42704 INDLLD= 2*N+1 42705 INDIN1 = 3*N + 1 42706 INDIN2 = 4*N + 1 42707 INDWRK = 5*N + 1 42708 MINWSIZE = 12 * N 42709 DO 5 I= 1,MINWSIZE 42710 WORK( I ) = ZERO 42711 5 CONTINUE 42712 IINDR = 0 42713 IINDC1 = N 42714 IINDC2 = 2*N 42715 IINDWK = 3*N + 1 42716 MINIWSIZE = 7 * N 42717 DO 10 I= 1,MINIWSIZE 42718 IWORK( I ) = 0 42719 10 CONTINUE 42720 ZUSEDL = 1 42721 IF(DOL.GT.1) THEN 42722 ZUSEDL = DOL-1 42723 ENDIF 42724 ZUSEDU = M 42725 IF(DOU.LT.M) THEN 42726 ZUSEDU = DOU+1 42727 ENDIF 42728 ZUSEDW = ZUSEDU - ZUSEDL + 1 42729 CALL ZLASET( 'Full', N, ZUSEDW, CZERO, CZERO, 42730 $ Z(1,ZUSEDL), LDZ ) 42731 EPS = DLAMCH( 'Precision' ) 42732 RQTOL = TWO * EPS 42733 TRYRQC = .TRUE. 42734 IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN 42735 ELSE 42736 RTOL1 = FOUR * EPS 42737 RTOL2 = FOUR * EPS 42738 ENDIF 42739 DONE = 0 42740 IBEGIN = 1 42741 WBEGIN = 1 42742 DO 170 JBLK = 1, IBLOCK( M ) 42743 IEND = ISPLIT( JBLK ) 42744 SIGMA = L( IEND ) 42745 WEND = WBEGIN - 1 42746 15 CONTINUE 42747 IF( WEND.LT.M ) THEN 42748 IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN 42749 WEND = WEND + 1 42750 GO TO 15 42751 END IF 42752 END IF 42753 IF( WEND.LT.WBEGIN ) THEN 42754 IBEGIN = IEND + 1 42755 GO TO 170 42756 ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN 42757 IBEGIN = IEND + 1 42758 WBEGIN = WEND + 1 42759 GO TO 170 42760 END IF 42761 GL = GERS( 2*IBEGIN-1 ) 42762 GU = GERS( 2*IBEGIN ) 42763 DO 20 I = IBEGIN+1 , IEND 42764 GL = MIN( GERS( 2*I-1 ), GL ) 42765 GU = MAX( GERS( 2*I ), GU ) 42766 20 CONTINUE 42767 SPDIAM = GU - GL 42768 OLDIEN = IBEGIN - 1 42769 IN = IEND - IBEGIN + 1 42770 IM = WEND - WBEGIN + 1 42771 IF( IBEGIN.EQ.IEND ) THEN 42772 DONE = DONE+1 42773 Z( IBEGIN, WBEGIN ) = DCMPLX( ONE, ZERO ) 42774 ISUPPZ( 2*WBEGIN-1 ) = IBEGIN 42775 ISUPPZ( 2*WBEGIN ) = IBEGIN 42776 W( WBEGIN ) = W( WBEGIN ) + SIGMA 42777 WORK( WBEGIN ) = W( WBEGIN ) 42778 IBEGIN = IEND + 1 42779 WBEGIN = WBEGIN + 1 42780 GO TO 170 42781 END IF 42782 CALL DCOPY( IM, W( WBEGIN ), 1, 42783 $ WORK( WBEGIN ), 1 ) 42784 DO 30 I=1,IM 42785 W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA 42786 30 CONTINUE 42787 NDEPTH = 0 42788 PARITY = 1 42789 NCLUS = 1 42790 IWORK( IINDC1+1 ) = 1 42791 IWORK( IINDC1+2 ) = IM 42792 IDONE = 0 42793 40 CONTINUE 42794 IF( IDONE.LT.IM ) THEN 42795 IF( NDEPTH.GT.M ) THEN 42796 INFO = -2 42797 RETURN 42798 ENDIF 42799 OLDNCL = NCLUS 42800 NCLUS = 0 42801 PARITY = 1 - PARITY 42802 IF( PARITY.EQ.0 ) THEN 42803 OLDCLS = IINDC1 42804 NEWCLS = IINDC2 42805 ELSE 42806 OLDCLS = IINDC2 42807 NEWCLS = IINDC1 42808 END IF 42809 DO 150 I = 1, OLDNCL 42810 J = OLDCLS + 2*I 42811 OLDFST = IWORK( J-1 ) 42812 OLDLST = IWORK( J ) 42813 IF( NDEPTH.GT.0 ) THEN 42814 IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN 42815 J = WBEGIN + OLDFST - 1 42816 ELSE 42817 IF(WBEGIN+OLDFST-1.LT.DOL) THEN 42818 J = DOL - 1 42819 ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN 42820 J = DOU 42821 ELSE 42822 J = WBEGIN + OLDFST - 1 42823 ENDIF 42824 ENDIF 42825 DO 45 K = 1, IN - 1 42826 D( IBEGIN+K-1 ) = DBLE( Z( IBEGIN+K-1, 42827 $ J ) ) 42828 L( IBEGIN+K-1 ) = DBLE( Z( IBEGIN+K-1, 42829 $ J+1 ) ) 42830 45 CONTINUE 42831 D( IEND ) = DBLE( Z( IEND, J ) ) 42832 SIGMA = DBLE( Z( IEND, J+1 ) ) 42833 CALL ZLASET( 'Full', IN, 2, CZERO, CZERO, 42834 $ Z( IBEGIN, J), LDZ ) 42835 END IF 42836 DO 50 J = IBEGIN, IEND-1 42837 TMP = D( J )*L( J ) 42838 WORK( INDLD-1+J ) = TMP 42839 WORK( INDLLD-1+J ) = TMP*L( J ) 42840 50 CONTINUE 42841 IF( NDEPTH.GT.0 ) THEN 42842 P = INDEXW( WBEGIN-1+OLDFST ) 42843 Q = INDEXW( WBEGIN-1+OLDLST ) 42844 OFFSET = INDEXW( WBEGIN ) - 1 42845 CALL DLARRB( IN, D( IBEGIN ), 42846 $ WORK(INDLLD+IBEGIN-1), 42847 $ P, Q, RTOL1, RTOL2, OFFSET, 42848 $ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN), 42849 $ WORK( INDWRK ), IWORK( IINDWK ), 42850 $ PIVMIN, SPDIAM, IN, IINFO ) 42851 IF( IINFO.NE.0 ) THEN 42852 INFO = -1 42853 RETURN 42854 ENDIF 42855 IF( OLDFST.GT.1) THEN 42856 WGAP( WBEGIN+OLDFST-2 ) = 42857 $ MAX(WGAP(WBEGIN+OLDFST-2), 42858 $ W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1) 42859 $ - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) ) 42860 ENDIF 42861 IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN 42862 WGAP( WBEGIN+OLDLST-1 ) = 42863 $ MAX(WGAP(WBEGIN+OLDLST-1), 42864 $ W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST) 42865 $ - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) ) 42866 ENDIF 42867 DO 53 J=OLDFST,OLDLST 42868 W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA 42869 53 CONTINUE 42870 END IF 42871 NEWFST = OLDFST 42872 DO 140 J = OLDFST, OLDLST 42873 IF( J.EQ.OLDLST ) THEN 42874 NEWLST = J 42875 ELSE IF ( WGAP( WBEGIN + J -1).GE. 42876 $ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN 42877 NEWLST = J 42878 ELSE 42879 GOTO 140 42880 END IF 42881 NEWSIZ = NEWLST - NEWFST + 1 42882 IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN 42883 NEWFTT = WBEGIN + NEWFST - 1 42884 ELSE 42885 IF(WBEGIN+NEWFST-1.LT.DOL) THEN 42886 NEWFTT = DOL - 1 42887 ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN 42888 NEWFTT = DOU 42889 ELSE 42890 NEWFTT = WBEGIN + NEWFST - 1 42891 ENDIF 42892 ENDIF 42893 IF( NEWSIZ.GT.1) THEN 42894 IF( NEWFST.EQ.1 ) THEN 42895 LGAP = MAX( ZERO, 42896 $ W(WBEGIN)-WERR(WBEGIN) - VL ) 42897 ELSE 42898 LGAP = WGAP( WBEGIN+NEWFST-2 ) 42899 ENDIF 42900 RGAP = WGAP( WBEGIN+NEWLST-1 ) 42901 DO 55 K =1,2 42902 IF(K.EQ.1) THEN 42903 P = INDEXW( WBEGIN-1+NEWFST ) 42904 ELSE 42905 P = INDEXW( WBEGIN-1+NEWLST ) 42906 ENDIF 42907 OFFSET = INDEXW( WBEGIN ) - 1 42908 CALL DLARRB( IN, D(IBEGIN), 42909 $ WORK( INDLLD+IBEGIN-1 ),P,P, 42910 $ RQTOL, RQTOL, OFFSET, 42911 $ WORK(WBEGIN),WGAP(WBEGIN), 42912 $ WERR(WBEGIN),WORK( INDWRK ), 42913 $ IWORK( IINDWK ), PIVMIN, SPDIAM, 42914 $ IN, IINFO ) 42915 55 CONTINUE 42916 IF((WBEGIN+NEWLST-1.LT.DOL).OR. 42917 $ (WBEGIN+NEWFST-1.GT.DOU)) THEN 42918 IDONE = IDONE + NEWLST - NEWFST + 1 42919 GOTO 139 42920 ENDIF 42921 CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ), 42922 $ WORK(INDLD+IBEGIN-1), 42923 $ NEWFST, NEWLST, WORK(WBEGIN), 42924 $ WGAP(WBEGIN), WERR(WBEGIN), 42925 $ SPDIAM, LGAP, RGAP, PIVMIN, TAU, 42926 $ WORK( INDIN1 ), WORK( INDIN2 ), 42927 $ WORK( INDWRK ), IINFO ) 42928 DO 56 K = 1, IN-1 42929 Z( IBEGIN+K-1, NEWFTT ) = 42930 $ DCMPLX( WORK( INDIN1+K-1 ), ZERO ) 42931 Z( IBEGIN+K-1, NEWFTT+1 ) = 42932 $ DCMPLX( WORK( INDIN2+K-1 ), ZERO ) 42933 56 CONTINUE 42934 Z( IEND, NEWFTT ) = 42935 $ DCMPLX( WORK( INDIN1+IN-1 ), ZERO ) 42936 IF( IINFO.EQ.0 ) THEN 42937 SSIGMA = SIGMA + TAU 42938 Z( IEND, NEWFTT+1 ) = DCMPLX( SSIGMA, ZERO ) 42939 DO 116 K = NEWFST, NEWLST 42940 FUDGE = 42941 $ THREE*EPS*ABS(WORK(WBEGIN+K-1)) 42942 WORK( WBEGIN + K - 1 ) = 42943 $ WORK( WBEGIN + K - 1) - TAU 42944 FUDGE = FUDGE + 42945 $ FOUR*EPS*ABS(WORK(WBEGIN+K-1)) 42946 WERR( WBEGIN + K - 1 ) = 42947 $ WERR( WBEGIN + K - 1 ) + FUDGE 42948 116 CONTINUE 42949 NCLUS = NCLUS + 1 42950 K = NEWCLS + 2*NCLUS 42951 IWORK( K-1 ) = NEWFST 42952 IWORK( K ) = NEWLST 42953 ELSE 42954 INFO = -2 42955 RETURN 42956 ENDIF 42957 ELSE 42958 ITER = 0 42959 TOL = FOUR * LOG(DBLE(IN)) * EPS 42960 K = NEWFST 42961 WINDEX = WBEGIN + K - 1 42962 WINDMN = MAX(WINDEX - 1,1) 42963 WINDPL = MIN(WINDEX + 1,M) 42964 LAMBDA = WORK( WINDEX ) 42965 DONE = DONE + 1 42966 IF((WINDEX.LT.DOL).OR. 42967 $ (WINDEX.GT.DOU)) THEN 42968 ESKIP = .TRUE. 42969 GOTO 125 42970 ELSE 42971 ESKIP = .FALSE. 42972 ENDIF 42973 LEFT = WORK( WINDEX ) - WERR( WINDEX ) 42974 RIGHT = WORK( WINDEX ) + WERR( WINDEX ) 42975 INDEIG = INDEXW( WINDEX ) 42976 IF( K .EQ. 1) THEN 42977 LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT)) 42978 ELSE 42979 LGAP = WGAP(WINDMN) 42980 ENDIF 42981 IF( K .EQ. IM) THEN 42982 RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT)) 42983 ELSE 42984 RGAP = WGAP(WINDEX) 42985 ENDIF 42986 GAP = MIN( LGAP, RGAP ) 42987 IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN 42988 GAPTOL = ZERO 42989 ELSE 42990 GAPTOL = GAP * EPS 42991 ENDIF 42992 ISUPMN = IN 42993 ISUPMX = 1 42994 SAVGAP = WGAP(WINDEX) 42995 WGAP(WINDEX) = GAP 42996 USEDBS = .FALSE. 42997 USEDRQ = .FALSE. 42998 NEEDBS = .NOT.TRYRQC 42999 120 CONTINUE 43000 IF(NEEDBS) THEN 43001 USEDBS = .TRUE. 43002 ITMP1 = IWORK( IINDR+WINDEX ) 43003 OFFSET = INDEXW( WBEGIN ) - 1 43004 CALL DLARRB( IN, D(IBEGIN), 43005 $ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG, 43006 $ ZERO, TWO*EPS, OFFSET, 43007 $ WORK(WBEGIN),WGAP(WBEGIN), 43008 $ WERR(WBEGIN),WORK( INDWRK ), 43009 $ IWORK( IINDWK ), PIVMIN, SPDIAM, 43010 $ ITMP1, IINFO ) 43011 IF( IINFO.NE.0 ) THEN 43012 INFO = -3 43013 RETURN 43014 ENDIF 43015 LAMBDA = WORK( WINDEX ) 43016 IWORK( IINDR+WINDEX ) = 0 43017 ENDIF 43018 CALL ZLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ), 43019 $ L( IBEGIN ), WORK(INDLD+IBEGIN-1), 43020 $ WORK(INDLLD+IBEGIN-1), 43021 $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ), 43022 $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA, 43023 $ IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ), 43024 $ NRMINV, RESID, RQCORR, WORK( INDWRK ) ) 43025 IF(ITER .EQ. 0) THEN 43026 BSTRES = RESID 43027 BSTW = LAMBDA 43028 ELSEIF(RESID.LT.BSTRES) THEN 43029 BSTRES = RESID 43030 BSTW = LAMBDA 43031 ENDIF 43032 ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 )) 43033 ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX )) 43034 ITER = ITER + 1 43035 IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT. 43036 $ RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS) 43037 $ THEN 43038 IF(INDEIG.LE.NEGCNT) THEN 43039 SGNDEF = -ONE 43040 ELSE 43041 SGNDEF = ONE 43042 ENDIF 43043 IF( ( RQCORR*SGNDEF.GE.ZERO ) 43044 $ .AND.( LAMBDA + RQCORR.LE. RIGHT) 43045 $ .AND.( LAMBDA + RQCORR.GE. LEFT) 43046 $ ) THEN 43047 USEDRQ = .TRUE. 43048 IF(SGNDEF.EQ.ONE) THEN 43049 LEFT = LAMBDA 43050 ELSE 43051 RIGHT = LAMBDA 43052 ENDIF 43053 WORK( WINDEX ) = 43054 $ HALF * (RIGHT + LEFT) 43055 LAMBDA = LAMBDA + RQCORR 43056 WERR( WINDEX ) = 43057 $ HALF * (RIGHT-LEFT) 43058 ELSE 43059 NEEDBS = .TRUE. 43060 ENDIF 43061 IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN 43062 USEDBS = .TRUE. 43063 GOTO 120 43064 ELSEIF( ITER.LT.MAXITR ) THEN 43065 GOTO 120 43066 ELSEIF( ITER.EQ.MAXITR ) THEN 43067 NEEDBS = .TRUE. 43068 GOTO 120 43069 ELSE 43070 INFO = 5 43071 RETURN 43072 END IF 43073 ELSE 43074 STP2II = .FALSE. 43075 IF(USEDRQ .AND. USEDBS .AND. 43076 $ BSTRES.LE.RESID) THEN 43077 LAMBDA = BSTW 43078 STP2II = .TRUE. 43079 ENDIF 43080 IF (STP2II) THEN 43081 CALL ZLAR1V( IN, 1, IN, LAMBDA, 43082 $ D( IBEGIN ), L( IBEGIN ), 43083 $ WORK(INDLD+IBEGIN-1), 43084 $ WORK(INDLLD+IBEGIN-1), 43085 $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ), 43086 $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA, 43087 $ IWORK( IINDR+WINDEX ), 43088 $ ISUPPZ( 2*WINDEX-1 ), 43089 $ NRMINV, RESID, RQCORR, WORK( INDWRK ) ) 43090 ENDIF 43091 WORK( WINDEX ) = LAMBDA 43092 END IF 43093 ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN 43094 ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN 43095 ZFROM = ISUPPZ( 2*WINDEX-1 ) 43096 ZTO = ISUPPZ( 2*WINDEX ) 43097 ISUPMN = ISUPMN + OLDIEN 43098 ISUPMX = ISUPMX + OLDIEN 43099 IF(ISUPMN.LT.ZFROM) THEN 43100 DO 122 II = ISUPMN,ZFROM-1 43101 Z( II, WINDEX ) = ZERO 43102 122 CONTINUE 43103 ENDIF 43104 IF(ISUPMX.GT.ZTO) THEN 43105 DO 123 II = ZTO+1,ISUPMX 43106 Z( II, WINDEX ) = ZERO 43107 123 CONTINUE 43108 ENDIF 43109 CALL ZDSCAL( ZTO-ZFROM+1, NRMINV, 43110 $ Z( ZFROM, WINDEX ), 1 ) 43111 125 CONTINUE 43112 W( WINDEX ) = LAMBDA+SIGMA 43113 IF(.NOT.ESKIP) THEN 43114 IF( K.GT.1) THEN 43115 WGAP( WINDMN ) = MAX( WGAP(WINDMN), 43116 $ W(WINDEX)-WERR(WINDEX) 43117 $ - W(WINDMN)-WERR(WINDMN) ) 43118 ENDIF 43119 IF( WINDEX.LT.WEND ) THEN 43120 WGAP( WINDEX ) = MAX( SAVGAP, 43121 $ W( WINDPL )-WERR( WINDPL ) 43122 $ - W( WINDEX )-WERR( WINDEX) ) 43123 ENDIF 43124 ENDIF 43125 IDONE = IDONE + 1 43126 ENDIF 43127 139 CONTINUE 43128 NEWFST = J + 1 43129 140 CONTINUE 43130 150 CONTINUE 43131 NDEPTH = NDEPTH + 1 43132 GO TO 40 43133 END IF 43134 IBEGIN = IEND + 1 43135 WBEGIN = WEND + 1 43136 170 CONTINUE 43137 RETURN 43138 END 43139! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlartg.f 43140 SUBROUTINE ZLARTG( F, G, CS, SN, R ) 43141 DOUBLE PRECISION CS 43142 COMPLEX*16 F, G, R, SN 43143 DOUBLE PRECISION TWO, ONE, ZERO 43144 PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) 43145 COMPLEX*16 CZERO 43146 PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) 43147 INTEGER COUNT, I 43148 DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, 43149 $ SAFMN2, SAFMX2, SCALE 43150 COMPLEX*16 FF, FS, GS 43151 DOUBLE PRECISION DLAMCH, DLAPY2 43152 LOGICAL DISNAN 43153 EXTERNAL DLAMCH, DLAPY2, DISNAN 43154 INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, 43155 $ MAX, SQRT 43156 DOUBLE PRECISION ABS1, ABSSQ 43157 ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) 43158 ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 43159 SAFMIN = DLAMCH( 'S' ) 43160 EPS = DLAMCH( 'E' ) 43161 SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / 43162 $ LOG( DLAMCH( 'B' ) ) / TWO ) 43163 SAFMX2 = ONE / SAFMN2 43164 SCALE = MAX( ABS1( F ), ABS1( G ) ) 43165 FS = F 43166 GS = G 43167 COUNT = 0 43168 IF( SCALE.GE.SAFMX2 ) THEN 43169 10 CONTINUE 43170 COUNT = COUNT + 1 43171 FS = FS*SAFMN2 43172 GS = GS*SAFMN2 43173 SCALE = SCALE*SAFMN2 43174 IF( SCALE.GE.SAFMX2 ) 43175 $ GO TO 10 43176 ELSE IF( SCALE.LE.SAFMN2 ) THEN 43177 IF( G.EQ.CZERO.OR.DISNAN( ABS( G ) ) ) THEN 43178 CS = ONE 43179 SN = CZERO 43180 R = F 43181 RETURN 43182 END IF 43183 20 CONTINUE 43184 COUNT = COUNT - 1 43185 FS = FS*SAFMX2 43186 GS = GS*SAFMX2 43187 SCALE = SCALE*SAFMX2 43188 IF( SCALE.LE.SAFMN2 ) 43189 $ GO TO 20 43190 END IF 43191 F2 = ABSSQ( FS ) 43192 G2 = ABSSQ( GS ) 43193 IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN 43194 IF( F.EQ.CZERO ) THEN 43195 CS = ZERO 43196 R = DLAPY2( DBLE( G ), DIMAG( G ) ) 43197 D = DLAPY2( DBLE( GS ), DIMAG( GS ) ) 43198 SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D ) 43199 RETURN 43200 END IF 43201 F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) ) 43202 G2S = SQRT( G2 ) 43203 CS = F2S / G2S 43204 IF( ABS1( F ).GT.ONE ) THEN 43205 D = DLAPY2( DBLE( F ), DIMAG( F ) ) 43206 FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D ) 43207 ELSE 43208 DR = SAFMX2*DBLE( F ) 43209 DI = SAFMX2*DIMAG( F ) 43210 D = DLAPY2( DR, DI ) 43211 FF = DCMPLX( DR / D, DI / D ) 43212 END IF 43213 SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S ) 43214 R = CS*F + SN*G 43215 ELSE 43216 F2S = SQRT( ONE+G2 / F2 ) 43217 R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) ) 43218 CS = ONE / F2S 43219 D = F2 + G2 43220 SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D ) 43221 SN = SN*DCONJG( GS ) 43222 IF( COUNT.NE.0 ) THEN 43223 IF( COUNT.GT.0 ) THEN 43224 DO 30 I = 1, COUNT 43225 R = R*SAFMX2 43226 30 CONTINUE 43227 ELSE 43228 DO 40 I = 1, -COUNT 43229 R = R*SAFMN2 43230 40 CONTINUE 43231 END IF 43232 END IF 43233 END IF 43234 RETURN 43235 END 43236! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlascl.f 43237 SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) 43238 CHARACTER TYPE 43239 INTEGER INFO, KL, KU, LDA, M, N 43240 DOUBLE PRECISION CFROM, CTO 43241 COMPLEX*16 A( LDA, * ) 43242 DOUBLE PRECISION ZERO, ONE 43243 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 43244 LOGICAL DONE 43245 INTEGER I, ITYPE, J, K1, K2, K3, K4 43246 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM 43247 LOGICAL LSAME, DISNAN 43248 DOUBLE PRECISION DLAMCH 43249 EXTERNAL LSAME, DLAMCH, DISNAN 43250 INTRINSIC ABS, MAX, MIN 43251 EXTERNAL XERBLA 43252 INFO = 0 43253 IF( LSAME( TYPE, 'G' ) ) THEN 43254 ITYPE = 0 43255 ELSE IF( LSAME( TYPE, 'L' ) ) THEN 43256 ITYPE = 1 43257 ELSE IF( LSAME( TYPE, 'U' ) ) THEN 43258 ITYPE = 2 43259 ELSE IF( LSAME( TYPE, 'H' ) ) THEN 43260 ITYPE = 3 43261 ELSE IF( LSAME( TYPE, 'B' ) ) THEN 43262 ITYPE = 4 43263 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN 43264 ITYPE = 5 43265 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN 43266 ITYPE = 6 43267 ELSE 43268 ITYPE = -1 43269 END IF 43270 IF( ITYPE.EQ.-1 ) THEN 43271 INFO = -1 43272 ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN 43273 INFO = -4 43274 ELSE IF( DISNAN(CTO) ) THEN 43275 INFO = -5 43276 ELSE IF( M.LT.0 ) THEN 43277 INFO = -6 43278 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. 43279 $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN 43280 INFO = -7 43281 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN 43282 INFO = -9 43283 ELSE IF( ITYPE.GE.4 ) THEN 43284 IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN 43285 INFO = -2 43286 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. 43287 $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) 43288 $ THEN 43289 INFO = -3 43290 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. 43291 $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. 43292 $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN 43293 INFO = -9 43294 END IF 43295 END IF 43296 IF( INFO.NE.0 ) THEN 43297 CALL XERBLA( 'ZLASCL', -INFO ) 43298 RETURN 43299 END IF 43300 IF( N.EQ.0 .OR. M.EQ.0 ) 43301 $ RETURN 43302 SMLNUM = DLAMCH( 'S' ) 43303 BIGNUM = ONE / SMLNUM 43304 CFROMC = CFROM 43305 CTOC = CTO 43306 10 CONTINUE 43307 CFROM1 = CFROMC*SMLNUM 43308 IF( CFROM1.EQ.CFROMC ) THEN 43309 MUL = CTOC / CFROMC 43310 DONE = .TRUE. 43311 CTO1 = CTOC 43312 ELSE 43313 CTO1 = CTOC / BIGNUM 43314 IF( CTO1.EQ.CTOC ) THEN 43315 MUL = CTOC 43316 DONE = .TRUE. 43317 CFROMC = ONE 43318 ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN 43319 MUL = SMLNUM 43320 DONE = .FALSE. 43321 CFROMC = CFROM1 43322 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN 43323 MUL = BIGNUM 43324 DONE = .FALSE. 43325 CTOC = CTO1 43326 ELSE 43327 MUL = CTOC / CFROMC 43328 DONE = .TRUE. 43329 END IF 43330 END IF 43331 IF( ITYPE.EQ.0 ) THEN 43332 DO 30 J = 1, N 43333 DO 20 I = 1, M 43334 A( I, J ) = A( I, J )*MUL 43335 20 CONTINUE 43336 30 CONTINUE 43337 ELSE IF( ITYPE.EQ.1 ) THEN 43338 DO 50 J = 1, N 43339 DO 40 I = J, M 43340 A( I, J ) = A( I, J )*MUL 43341 40 CONTINUE 43342 50 CONTINUE 43343 ELSE IF( ITYPE.EQ.2 ) THEN 43344 DO 70 J = 1, N 43345 DO 60 I = 1, MIN( J, M ) 43346 A( I, J ) = A( I, J )*MUL 43347 60 CONTINUE 43348 70 CONTINUE 43349 ELSE IF( ITYPE.EQ.3 ) THEN 43350 DO 90 J = 1, N 43351 DO 80 I = 1, MIN( J+1, M ) 43352 A( I, J ) = A( I, J )*MUL 43353 80 CONTINUE 43354 90 CONTINUE 43355 ELSE IF( ITYPE.EQ.4 ) THEN 43356 K3 = KL + 1 43357 K4 = N + 1 43358 DO 110 J = 1, N 43359 DO 100 I = 1, MIN( K3, K4-J ) 43360 A( I, J ) = A( I, J )*MUL 43361 100 CONTINUE 43362 110 CONTINUE 43363 ELSE IF( ITYPE.EQ.5 ) THEN 43364 K1 = KU + 2 43365 K3 = KU + 1 43366 DO 130 J = 1, N 43367 DO 120 I = MAX( K1-J, 1 ), K3 43368 A( I, J ) = A( I, J )*MUL 43369 120 CONTINUE 43370 130 CONTINUE 43371 ELSE IF( ITYPE.EQ.6 ) THEN 43372 K1 = KL + KU + 2 43373 K2 = KL + 1 43374 K3 = 2*KL + KU + 1 43375 K4 = KL + KU + 1 + M 43376 DO 150 J = 1, N 43377 DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) 43378 A( I, J ) = A( I, J )*MUL 43379 140 CONTINUE 43380 150 CONTINUE 43381 END IF 43382 IF( .NOT.DONE ) 43383 $ GO TO 10 43384 RETURN 43385 END 43386! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlaset.f 43387 SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) 43388 CHARACTER UPLO 43389 INTEGER LDA, M, N 43390 COMPLEX*16 ALPHA, BETA 43391 COMPLEX*16 A( LDA, * ) 43392 INTEGER I, J 43393 LOGICAL LSAME 43394 EXTERNAL LSAME 43395 INTRINSIC MIN 43396 IF( LSAME( UPLO, 'U' ) ) THEN 43397 DO 20 J = 2, N 43398 DO 10 I = 1, MIN( J-1, M ) 43399 A( I, J ) = ALPHA 43400 10 CONTINUE 43401 20 CONTINUE 43402 DO 30 I = 1, MIN( N, M ) 43403 A( I, I ) = BETA 43404 30 CONTINUE 43405 ELSE IF( LSAME( UPLO, 'L' ) ) THEN 43406 DO 50 J = 1, MIN( M, N ) 43407 DO 40 I = J + 1, M 43408 A( I, J ) = ALPHA 43409 40 CONTINUE 43410 50 CONTINUE 43411 DO 60 I = 1, MIN( N, M ) 43412 A( I, I ) = BETA 43413 60 CONTINUE 43414 ELSE 43415 DO 80 J = 1, N 43416 DO 70 I = 1, M 43417 A( I, J ) = ALPHA 43418 70 CONTINUE 43419 80 CONTINUE 43420 DO 90 I = 1, MIN( M, N ) 43421 A( I, I ) = BETA 43422 90 CONTINUE 43423 END IF 43424 RETURN 43425 END 43426! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlasr.f 43427 SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) 43428 CHARACTER DIRECT, PIVOT, SIDE 43429 INTEGER LDA, M, N 43430 DOUBLE PRECISION C( * ), S( * ) 43431 COMPLEX*16 A( LDA, * ) 43432 DOUBLE PRECISION ONE, ZERO 43433 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 43434 INTEGER I, INFO, J 43435 DOUBLE PRECISION CTEMP, STEMP 43436 COMPLEX*16 TEMP 43437 INTRINSIC MAX 43438 LOGICAL LSAME 43439 EXTERNAL LSAME 43440 EXTERNAL XERBLA 43441 INFO = 0 43442 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN 43443 INFO = 1 43444 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, 43445 $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN 43446 INFO = 2 43447 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) 43448 $ THEN 43449 INFO = 3 43450 ELSE IF( M.LT.0 ) THEN 43451 INFO = 4 43452 ELSE IF( N.LT.0 ) THEN 43453 INFO = 5 43454 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 43455 INFO = 9 43456 END IF 43457 IF( INFO.NE.0 ) THEN 43458 CALL XERBLA( 'ZLASR ', INFO ) 43459 RETURN 43460 END IF 43461 IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) 43462 $ RETURN 43463 IF( LSAME( SIDE, 'L' ) ) THEN 43464 IF( LSAME( PIVOT, 'V' ) ) THEN 43465 IF( LSAME( DIRECT, 'F' ) ) THEN 43466 DO 20 J = 1, M - 1 43467 CTEMP = C( J ) 43468 STEMP = S( J ) 43469 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43470 DO 10 I = 1, N 43471 TEMP = A( J+1, I ) 43472 A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) 43473 A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 43474 10 CONTINUE 43475 END IF 43476 20 CONTINUE 43477 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 43478 DO 40 J = M - 1, 1, -1 43479 CTEMP = C( J ) 43480 STEMP = S( J ) 43481 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43482 DO 30 I = 1, N 43483 TEMP = A( J+1, I ) 43484 A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) 43485 A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 43486 30 CONTINUE 43487 END IF 43488 40 CONTINUE 43489 END IF 43490 ELSE IF( LSAME( PIVOT, 'T' ) ) THEN 43491 IF( LSAME( DIRECT, 'F' ) ) THEN 43492 DO 60 J = 2, M 43493 CTEMP = C( J-1 ) 43494 STEMP = S( J-1 ) 43495 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43496 DO 50 I = 1, N 43497 TEMP = A( J, I ) 43498 A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) 43499 A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 43500 50 CONTINUE 43501 END IF 43502 60 CONTINUE 43503 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 43504 DO 80 J = M, 2, -1 43505 CTEMP = C( J-1 ) 43506 STEMP = S( J-1 ) 43507 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43508 DO 70 I = 1, N 43509 TEMP = A( J, I ) 43510 A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) 43511 A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 43512 70 CONTINUE 43513 END IF 43514 80 CONTINUE 43515 END IF 43516 ELSE IF( LSAME( PIVOT, 'B' ) ) THEN 43517 IF( LSAME( DIRECT, 'F' ) ) THEN 43518 DO 100 J = 1, M - 1 43519 CTEMP = C( J ) 43520 STEMP = S( J ) 43521 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43522 DO 90 I = 1, N 43523 TEMP = A( J, I ) 43524 A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP 43525 A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 43526 90 CONTINUE 43527 END IF 43528 100 CONTINUE 43529 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 43530 DO 120 J = M - 1, 1, -1 43531 CTEMP = C( J ) 43532 STEMP = S( J ) 43533 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43534 DO 110 I = 1, N 43535 TEMP = A( J, I ) 43536 A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP 43537 A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 43538 110 CONTINUE 43539 END IF 43540 120 CONTINUE 43541 END IF 43542 END IF 43543 ELSE IF( LSAME( SIDE, 'R' ) ) THEN 43544 IF( LSAME( PIVOT, 'V' ) ) THEN 43545 IF( LSAME( DIRECT, 'F' ) ) THEN 43546 DO 140 J = 1, N - 1 43547 CTEMP = C( J ) 43548 STEMP = S( J ) 43549 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43550 DO 130 I = 1, M 43551 TEMP = A( I, J+1 ) 43552 A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) 43553 A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 43554 130 CONTINUE 43555 END IF 43556 140 CONTINUE 43557 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 43558 DO 160 J = N - 1, 1, -1 43559 CTEMP = C( J ) 43560 STEMP = S( J ) 43561 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43562 DO 150 I = 1, M 43563 TEMP = A( I, J+1 ) 43564 A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) 43565 A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 43566 150 CONTINUE 43567 END IF 43568 160 CONTINUE 43569 END IF 43570 ELSE IF( LSAME( PIVOT, 'T' ) ) THEN 43571 IF( LSAME( DIRECT, 'F' ) ) THEN 43572 DO 180 J = 2, N 43573 CTEMP = C( J-1 ) 43574 STEMP = S( J-1 ) 43575 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43576 DO 170 I = 1, M 43577 TEMP = A( I, J ) 43578 A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) 43579 A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 43580 170 CONTINUE 43581 END IF 43582 180 CONTINUE 43583 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 43584 DO 200 J = N, 2, -1 43585 CTEMP = C( J-1 ) 43586 STEMP = S( J-1 ) 43587 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43588 DO 190 I = 1, M 43589 TEMP = A( I, J ) 43590 A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) 43591 A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 43592 190 CONTINUE 43593 END IF 43594 200 CONTINUE 43595 END IF 43596 ELSE IF( LSAME( PIVOT, 'B' ) ) THEN 43597 IF( LSAME( DIRECT, 'F' ) ) THEN 43598 DO 220 J = 1, N - 1 43599 CTEMP = C( J ) 43600 STEMP = S( J ) 43601 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43602 DO 210 I = 1, M 43603 TEMP = A( I, J ) 43604 A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP 43605 A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 43606 210 CONTINUE 43607 END IF 43608 220 CONTINUE 43609 ELSE IF( LSAME( DIRECT, 'B' ) ) THEN 43610 DO 240 J = N - 1, 1, -1 43611 CTEMP = C( J ) 43612 STEMP = S( J ) 43613 IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN 43614 DO 230 I = 1, M 43615 TEMP = A( I, J ) 43616 A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP 43617 A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 43618 230 CONTINUE 43619 END IF 43620 240 CONTINUE 43621 END IF 43622 END IF 43623 END IF 43624 RETURN 43625 END 43626! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlassq.f 43627 SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) 43628 INTEGER INCX, N 43629 DOUBLE PRECISION SCALE, SUMSQ 43630 COMPLEX*16 X( * ) 43631 DOUBLE PRECISION ZERO 43632 PARAMETER ( ZERO = 0.0D+0 ) 43633 INTEGER IX 43634 DOUBLE PRECISION TEMP1 43635 LOGICAL DISNAN 43636 EXTERNAL DISNAN 43637 INTRINSIC ABS, DBLE, DIMAG 43638 IF( N.GT.0 ) THEN 43639 DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX 43640 TEMP1 = ABS( DBLE( X( IX ) ) ) 43641 IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN 43642 IF( SCALE.LT.TEMP1 ) THEN 43643 SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 43644 SCALE = TEMP1 43645 ELSE 43646 SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 43647 END IF 43648 END IF 43649 TEMP1 = ABS( DIMAG( X( IX ) ) ) 43650 IF( TEMP1.GT.ZERO.OR.DISNAN( TEMP1 ) ) THEN 43651 IF( SCALE.LT.TEMP1 ) THEN 43652 SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 43653 SCALE = TEMP1 43654 ELSE 43655 SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 43656 END IF 43657 END IF 43658 10 CONTINUE 43659 END IF 43660 RETURN 43661 END 43662! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlaswp.f 43663 SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) 43664 INTEGER INCX, K1, K2, LDA, N 43665 INTEGER IPIV( * ) 43666 COMPLEX*16 A( LDA, * ) 43667 INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 43668 COMPLEX*16 TEMP 43669 IF( INCX.GT.0 ) THEN 43670 IX0 = K1 43671 I1 = K1 43672 I2 = K2 43673 INC = 1 43674 ELSE IF( INCX.LT.0 ) THEN 43675 IX0 = K1 + ( K1-K2 )*INCX 43676 I1 = K2 43677 I2 = K1 43678 INC = -1 43679 ELSE 43680 RETURN 43681 END IF 43682 N32 = ( N / 32 )*32 43683 IF( N32.NE.0 ) THEN 43684 DO 30 J = 1, N32, 32 43685 IX = IX0 43686 DO 20 I = I1, I2, INC 43687 IP = IPIV( IX ) 43688 IF( IP.NE.I ) THEN 43689 DO 10 K = J, J + 31 43690 TEMP = A( I, K ) 43691 A( I, K ) = A( IP, K ) 43692 A( IP, K ) = TEMP 43693 10 CONTINUE 43694 END IF 43695 IX = IX + INCX 43696 20 CONTINUE 43697 30 CONTINUE 43698 END IF 43699 IF( N32.NE.N ) THEN 43700 N32 = N32 + 1 43701 IX = IX0 43702 DO 50 I = I1, I2, INC 43703 IP = IPIV( IX ) 43704 IF( IP.NE.I ) THEN 43705 DO 40 K = N32, N 43706 TEMP = A( I, K ) 43707 A( I, K ) = A( IP, K ) 43708 A( IP, K ) = TEMP 43709 40 CONTINUE 43710 END IF 43711 IX = IX + INCX 43712 50 CONTINUE 43713 END IF 43714 RETURN 43715 END 43716! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlatrd.f 43717 SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) 43718 CHARACTER UPLO 43719 INTEGER LDA, LDW, N, NB 43720 DOUBLE PRECISION E( * ) 43721 COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * ) 43722 COMPLEX*16 ZERO, ONE, HALF 43723 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), 43724 $ ONE = ( 1.0D+0, 0.0D+0 ), 43725 $ HALF = ( 0.5D+0, 0.0D+0 ) ) 43726 INTEGER I, IW 43727 COMPLEX*16 ALPHA 43728 EXTERNAL ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL 43729 LOGICAL LSAME 43730 COMPLEX*16 ZDOTC 43731 EXTERNAL LSAME, ZDOTC 43732 INTRINSIC DBLE, MIN 43733 IF( N.LE.0 ) 43734 $ RETURN 43735 IF( LSAME( UPLO, 'U' ) ) THEN 43736 DO 10 I = N, N - NB + 1, -1 43737 IW = I - N + NB 43738 IF( I.LT.N ) THEN 43739 A( I, I ) = DBLE( A( I, I ) ) 43740 CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) 43741 CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), 43742 $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) 43743 CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) 43744 CALL ZLACGV( N-I, A( I, I+1 ), LDA ) 43745 CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), 43746 $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) 43747 CALL ZLACGV( N-I, A( I, I+1 ), LDA ) 43748 A( I, I ) = DBLE( A( I, I ) ) 43749 END IF 43750 IF( I.GT.1 ) THEN 43751 ALPHA = A( I-1, I ) 43752 CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) ) 43753 E( I-1 ) = ALPHA 43754 A( I-1, I ) = ONE 43755 CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, 43756 $ ZERO, W( 1, IW ), 1 ) 43757 IF( I.LT.N ) THEN 43758 CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, 43759 $ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO, 43760 $ W( I+1, IW ), 1 ) 43761 CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, 43762 $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, 43763 $ W( 1, IW ), 1 ) 43764 CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, 43765 $ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO, 43766 $ W( I+1, IW ), 1 ) 43767 CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, 43768 $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, 43769 $ W( 1, IW ), 1 ) 43770 END IF 43771 CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) 43772 ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1, 43773 $ A( 1, I ), 1 ) 43774 CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) 43775 END IF 43776 10 CONTINUE 43777 ELSE 43778 DO 20 I = 1, NB 43779 A( I, I ) = DBLE( A( I, I ) ) 43780 CALL ZLACGV( I-1, W( I, 1 ), LDW ) 43781 CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), 43782 $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) 43783 CALL ZLACGV( I-1, W( I, 1 ), LDW ) 43784 CALL ZLACGV( I-1, A( I, 1 ), LDA ) 43785 CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), 43786 $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) 43787 CALL ZLACGV( I-1, A( I, 1 ), LDA ) 43788 A( I, I ) = DBLE( A( I, I ) ) 43789 IF( I.LT.N ) THEN 43790 ALPHA = A( I+1, I ) 43791 CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, 43792 $ TAU( I ) ) 43793 E( I ) = ALPHA 43794 A( I+1, I ) = ONE 43795 CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, 43796 $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) 43797 CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, 43798 $ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO, 43799 $ W( 1, I ), 1 ) 43800 CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), 43801 $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) 43802 CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, 43803 $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, 43804 $ W( 1, I ), 1 ) 43805 CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), 43806 $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) 43807 CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) 43808 ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1, 43809 $ A( I+1, I ), 1 ) 43810 CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) 43811 END IF 43812 20 CONTINUE 43813 END IF 43814 RETURN 43815 END 43816! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zlatrs.f 43817 SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, 43818 $ CNORM, INFO ) 43819 CHARACTER DIAG, NORMIN, TRANS, UPLO 43820 INTEGER INFO, LDA, N 43821 DOUBLE PRECISION SCALE 43822 DOUBLE PRECISION CNORM( * ) 43823 COMPLEX*16 A( LDA, * ), X( * ) 43824 DOUBLE PRECISION ZERO, HALF, ONE, TWO 43825 PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, 43826 $ TWO = 2.0D+0 ) 43827 LOGICAL NOTRAN, NOUNIT, UPPER 43828 INTEGER I, IMAX, J, JFIRST, JINC, JLAST 43829 DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, 43830 $ XBND, XJ, XMAX 43831 COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM 43832 LOGICAL LSAME 43833 INTEGER IDAMAX, IZAMAX 43834 DOUBLE PRECISION DLAMCH, DZASUM 43835 COMPLEX*16 ZDOTC, ZDOTU, ZLADIV 43836 EXTERNAL LSAME, IDAMAX, IZAMAX, DLAMCH, DZASUM, ZDOTC, 43837 $ ZDOTU, ZLADIV 43838 EXTERNAL DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV, DLABAD 43839 INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN 43840 DOUBLE PRECISION CABS1, CABS2 43841 CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) 43842 CABS2( ZDUM ) = ABS( DBLE( ZDUM ) / 2.D0 ) + 43843 $ ABS( DIMAG( ZDUM ) / 2.D0 ) 43844 INFO = 0 43845 UPPER = LSAME( UPLO, 'U' ) 43846 NOTRAN = LSAME( TRANS, 'N' ) 43847 NOUNIT = LSAME( DIAG, 'N' ) 43848 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 43849 INFO = -1 43850 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. 43851 $ LSAME( TRANS, 'C' ) ) THEN 43852 INFO = -2 43853 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN 43854 INFO = -3 43855 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. 43856 $ LSAME( NORMIN, 'N' ) ) THEN 43857 INFO = -4 43858 ELSE IF( N.LT.0 ) THEN 43859 INFO = -5 43860 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 43861 INFO = -7 43862 END IF 43863 IF( INFO.NE.0 ) THEN 43864 CALL XERBLA( 'ZLATRS', -INFO ) 43865 RETURN 43866 END IF 43867 IF( N.EQ.0 ) 43868 $ RETURN 43869 SMLNUM = DLAMCH( 'Safe minimum' ) 43870 BIGNUM = ONE / SMLNUM 43871 CALL DLABAD( SMLNUM, BIGNUM ) 43872 SMLNUM = SMLNUM / DLAMCH( 'Precision' ) 43873 BIGNUM = ONE / SMLNUM 43874 SCALE = ONE 43875 IF( LSAME( NORMIN, 'N' ) ) THEN 43876 IF( UPPER ) THEN 43877 DO 10 J = 1, N 43878 CNORM( J ) = DZASUM( J-1, A( 1, J ), 1 ) 43879 10 CONTINUE 43880 ELSE 43881 DO 20 J = 1, N - 1 43882 CNORM( J ) = DZASUM( N-J, A( J+1, J ), 1 ) 43883 20 CONTINUE 43884 CNORM( N ) = ZERO 43885 END IF 43886 END IF 43887 IMAX = IDAMAX( N, CNORM, 1 ) 43888 TMAX = CNORM( IMAX ) 43889 IF( TMAX.LE.BIGNUM*HALF ) THEN 43890 TSCAL = ONE 43891 ELSE 43892 TSCAL = HALF / ( SMLNUM*TMAX ) 43893 CALL DSCAL( N, TSCAL, CNORM, 1 ) 43894 END IF 43895 XMAX = ZERO 43896 DO 30 J = 1, N 43897 XMAX = MAX( XMAX, CABS2( X( J ) ) ) 43898 30 CONTINUE 43899 XBND = XMAX 43900 IF( NOTRAN ) THEN 43901 IF( UPPER ) THEN 43902 JFIRST = N 43903 JLAST = 1 43904 JINC = -1 43905 ELSE 43906 JFIRST = 1 43907 JLAST = N 43908 JINC = 1 43909 END IF 43910 IF( TSCAL.NE.ONE ) THEN 43911 GROW = ZERO 43912 GO TO 60 43913 END IF 43914 IF( NOUNIT ) THEN 43915 GROW = HALF / MAX( XBND, SMLNUM ) 43916 XBND = GROW 43917 DO 40 J = JFIRST, JLAST, JINC 43918 IF( GROW.LE.SMLNUM ) 43919 $ GO TO 60 43920 TJJS = A( J, J ) 43921 TJJ = CABS1( TJJS ) 43922 IF( TJJ.GE.SMLNUM ) THEN 43923 XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) 43924 ELSE 43925 XBND = ZERO 43926 END IF 43927 IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN 43928 GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) 43929 ELSE 43930 GROW = ZERO 43931 END IF 43932 40 CONTINUE 43933 GROW = XBND 43934 ELSE 43935 GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) 43936 DO 50 J = JFIRST, JLAST, JINC 43937 IF( GROW.LE.SMLNUM ) 43938 $ GO TO 60 43939 GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 43940 50 CONTINUE 43941 END IF 43942 60 CONTINUE 43943 ELSE 43944 IF( UPPER ) THEN 43945 JFIRST = 1 43946 JLAST = N 43947 JINC = 1 43948 ELSE 43949 JFIRST = N 43950 JLAST = 1 43951 JINC = -1 43952 END IF 43953 IF( TSCAL.NE.ONE ) THEN 43954 GROW = ZERO 43955 GO TO 90 43956 END IF 43957 IF( NOUNIT ) THEN 43958 GROW = HALF / MAX( XBND, SMLNUM ) 43959 XBND = GROW 43960 DO 70 J = JFIRST, JLAST, JINC 43961 IF( GROW.LE.SMLNUM ) 43962 $ GO TO 90 43963 XJ = ONE + CNORM( J ) 43964 GROW = MIN( GROW, XBND / XJ ) 43965 TJJS = A( J, J ) 43966 TJJ = CABS1( TJJS ) 43967 IF( TJJ.GE.SMLNUM ) THEN 43968 IF( XJ.GT.TJJ ) 43969 $ XBND = XBND*( TJJ / XJ ) 43970 ELSE 43971 XBND = ZERO 43972 END IF 43973 70 CONTINUE 43974 GROW = MIN( GROW, XBND ) 43975 ELSE 43976 GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) 43977 DO 80 J = JFIRST, JLAST, JINC 43978 IF( GROW.LE.SMLNUM ) 43979 $ GO TO 90 43980 XJ = ONE + CNORM( J ) 43981 GROW = GROW / XJ 43982 80 CONTINUE 43983 END IF 43984 90 CONTINUE 43985 END IF 43986 IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN 43987 CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) 43988 ELSE 43989 IF( XMAX.GT.BIGNUM*HALF ) THEN 43990 SCALE = ( BIGNUM*HALF ) / XMAX 43991 CALL ZDSCAL( N, SCALE, X, 1 ) 43992 XMAX = BIGNUM 43993 ELSE 43994 XMAX = XMAX*TWO 43995 END IF 43996 IF( NOTRAN ) THEN 43997 DO 120 J = JFIRST, JLAST, JINC 43998 XJ = CABS1( X( J ) ) 43999 IF( NOUNIT ) THEN 44000 TJJS = A( J, J )*TSCAL 44001 ELSE 44002 TJJS = TSCAL 44003 IF( TSCAL.EQ.ONE ) 44004 $ GO TO 110 44005 END IF 44006 TJJ = CABS1( TJJS ) 44007 IF( TJJ.GT.SMLNUM ) THEN 44008 IF( TJJ.LT.ONE ) THEN 44009 IF( XJ.GT.TJJ*BIGNUM ) THEN 44010 REC = ONE / XJ 44011 CALL ZDSCAL( N, REC, X, 1 ) 44012 SCALE = SCALE*REC 44013 XMAX = XMAX*REC 44014 END IF 44015 END IF 44016 X( J ) = ZLADIV( X( J ), TJJS ) 44017 XJ = CABS1( X( J ) ) 44018 ELSE IF( TJJ.GT.ZERO ) THEN 44019 IF( XJ.GT.TJJ*BIGNUM ) THEN 44020 REC = ( TJJ*BIGNUM ) / XJ 44021 IF( CNORM( J ).GT.ONE ) THEN 44022 REC = REC / CNORM( J ) 44023 END IF 44024 CALL ZDSCAL( N, REC, X, 1 ) 44025 SCALE = SCALE*REC 44026 XMAX = XMAX*REC 44027 END IF 44028 X( J ) = ZLADIV( X( J ), TJJS ) 44029 XJ = CABS1( X( J ) ) 44030 ELSE 44031 DO 100 I = 1, N 44032 X( I ) = ZERO 44033 100 CONTINUE 44034 X( J ) = ONE 44035 XJ = ONE 44036 SCALE = ZERO 44037 XMAX = ZERO 44038 END IF 44039 110 CONTINUE 44040 IF( XJ.GT.ONE ) THEN 44041 REC = ONE / XJ 44042 IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN 44043 REC = REC*HALF 44044 CALL ZDSCAL( N, REC, X, 1 ) 44045 SCALE = SCALE*REC 44046 END IF 44047 ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN 44048 CALL ZDSCAL( N, HALF, X, 1 ) 44049 SCALE = SCALE*HALF 44050 END IF 44051 IF( UPPER ) THEN 44052 IF( J.GT.1 ) THEN 44053 CALL ZAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, 44054 $ 1 ) 44055 I = IZAMAX( J-1, X, 1 ) 44056 XMAX = CABS1( X( I ) ) 44057 END IF 44058 ELSE 44059 IF( J.LT.N ) THEN 44060 CALL ZAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, 44061 $ X( J+1 ), 1 ) 44062 I = J + IZAMAX( N-J, X( J+1 ), 1 ) 44063 XMAX = CABS1( X( I ) ) 44064 END IF 44065 END IF 44066 120 CONTINUE 44067 ELSE IF( LSAME( TRANS, 'T' ) ) THEN 44068 DO 170 J = JFIRST, JLAST, JINC 44069 XJ = CABS1( X( J ) ) 44070 USCAL = TSCAL 44071 REC = ONE / MAX( XMAX, ONE ) 44072 IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN 44073 REC = REC*HALF 44074 IF( NOUNIT ) THEN 44075 TJJS = A( J, J )*TSCAL 44076 ELSE 44077 TJJS = TSCAL 44078 END IF 44079 TJJ = CABS1( TJJS ) 44080 IF( TJJ.GT.ONE ) THEN 44081 REC = MIN( ONE, REC*TJJ ) 44082 USCAL = ZLADIV( USCAL, TJJS ) 44083 END IF 44084 IF( REC.LT.ONE ) THEN 44085 CALL ZDSCAL( N, REC, X, 1 ) 44086 SCALE = SCALE*REC 44087 XMAX = XMAX*REC 44088 END IF 44089 END IF 44090 CSUMJ = ZERO 44091 IF( USCAL.EQ.DCMPLX( ONE ) ) THEN 44092 IF( UPPER ) THEN 44093 CSUMJ = ZDOTU( J-1, A( 1, J ), 1, X, 1 ) 44094 ELSE IF( J.LT.N ) THEN 44095 CSUMJ = ZDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) 44096 END IF 44097 ELSE 44098 IF( UPPER ) THEN 44099 DO 130 I = 1, J - 1 44100 CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 44101 130 CONTINUE 44102 ELSE IF( J.LT.N ) THEN 44103 DO 140 I = J + 1, N 44104 CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 44105 140 CONTINUE 44106 END IF 44107 END IF 44108 IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN 44109 X( J ) = X( J ) - CSUMJ 44110 XJ = CABS1( X( J ) ) 44111 IF( NOUNIT ) THEN 44112 TJJS = A( J, J )*TSCAL 44113 ELSE 44114 TJJS = TSCAL 44115 IF( TSCAL.EQ.ONE ) 44116 $ GO TO 160 44117 END IF 44118 TJJ = CABS1( TJJS ) 44119 IF( TJJ.GT.SMLNUM ) THEN 44120 IF( TJJ.LT.ONE ) THEN 44121 IF( XJ.GT.TJJ*BIGNUM ) THEN 44122 REC = ONE / XJ 44123 CALL ZDSCAL( N, REC, X, 1 ) 44124 SCALE = SCALE*REC 44125 XMAX = XMAX*REC 44126 END IF 44127 END IF 44128 X( J ) = ZLADIV( X( J ), TJJS ) 44129 ELSE IF( TJJ.GT.ZERO ) THEN 44130 IF( XJ.GT.TJJ*BIGNUM ) THEN 44131 REC = ( TJJ*BIGNUM ) / XJ 44132 CALL ZDSCAL( N, REC, X, 1 ) 44133 SCALE = SCALE*REC 44134 XMAX = XMAX*REC 44135 END IF 44136 X( J ) = ZLADIV( X( J ), TJJS ) 44137 ELSE 44138 DO 150 I = 1, N 44139 X( I ) = ZERO 44140 150 CONTINUE 44141 X( J ) = ONE 44142 SCALE = ZERO 44143 XMAX = ZERO 44144 END IF 44145 160 CONTINUE 44146 ELSE 44147 X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ 44148 END IF 44149 XMAX = MAX( XMAX, CABS1( X( J ) ) ) 44150 170 CONTINUE 44151 ELSE 44152 DO 220 J = JFIRST, JLAST, JINC 44153 XJ = CABS1( X( J ) ) 44154 USCAL = TSCAL 44155 REC = ONE / MAX( XMAX, ONE ) 44156 IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN 44157 REC = REC*HALF 44158 IF( NOUNIT ) THEN 44159 TJJS = DCONJG( A( J, J ) )*TSCAL 44160 ELSE 44161 TJJS = TSCAL 44162 END IF 44163 TJJ = CABS1( TJJS ) 44164 IF( TJJ.GT.ONE ) THEN 44165 REC = MIN( ONE, REC*TJJ ) 44166 USCAL = ZLADIV( USCAL, TJJS ) 44167 END IF 44168 IF( REC.LT.ONE ) THEN 44169 CALL ZDSCAL( N, REC, X, 1 ) 44170 SCALE = SCALE*REC 44171 XMAX = XMAX*REC 44172 END IF 44173 END IF 44174 CSUMJ = ZERO 44175 IF( USCAL.EQ.DCMPLX( ONE ) ) THEN 44176 IF( UPPER ) THEN 44177 CSUMJ = ZDOTC( J-1, A( 1, J ), 1, X, 1 ) 44178 ELSE IF( J.LT.N ) THEN 44179 CSUMJ = ZDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) 44180 END IF 44181 ELSE 44182 IF( UPPER ) THEN 44183 DO 180 I = 1, J - 1 44184 CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* 44185 $ X( I ) 44186 180 CONTINUE 44187 ELSE IF( J.LT.N ) THEN 44188 DO 190 I = J + 1, N 44189 CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* 44190 $ X( I ) 44191 190 CONTINUE 44192 END IF 44193 END IF 44194 IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN 44195 X( J ) = X( J ) - CSUMJ 44196 XJ = CABS1( X( J ) ) 44197 IF( NOUNIT ) THEN 44198 TJJS = DCONJG( A( J, J ) )*TSCAL 44199 ELSE 44200 TJJS = TSCAL 44201 IF( TSCAL.EQ.ONE ) 44202 $ GO TO 210 44203 END IF 44204 TJJ = CABS1( TJJS ) 44205 IF( TJJ.GT.SMLNUM ) THEN 44206 IF( TJJ.LT.ONE ) THEN 44207 IF( XJ.GT.TJJ*BIGNUM ) THEN 44208 REC = ONE / XJ 44209 CALL ZDSCAL( N, REC, X, 1 ) 44210 SCALE = SCALE*REC 44211 XMAX = XMAX*REC 44212 END IF 44213 END IF 44214 X( J ) = ZLADIV( X( J ), TJJS ) 44215 ELSE IF( TJJ.GT.ZERO ) THEN 44216 IF( XJ.GT.TJJ*BIGNUM ) THEN 44217 REC = ( TJJ*BIGNUM ) / XJ 44218 CALL ZDSCAL( N, REC, X, 1 ) 44219 SCALE = SCALE*REC 44220 XMAX = XMAX*REC 44221 END IF 44222 X( J ) = ZLADIV( X( J ), TJJS ) 44223 ELSE 44224 DO 200 I = 1, N 44225 X( I ) = ZERO 44226 200 CONTINUE 44227 X( J ) = ONE 44228 SCALE = ZERO 44229 XMAX = ZERO 44230 END IF 44231 210 CONTINUE 44232 ELSE 44233 X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ 44234 END IF 44235 XMAX = MAX( XMAX, CABS1( X( J ) ) ) 44236 220 CONTINUE 44237 END IF 44238 SCALE = SCALE / TSCAL 44239 END IF 44240 IF( TSCAL.NE.ONE ) THEN 44241 CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) 44242 END IF 44243 RETURN 44244 END 44245! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zpotrf.f 44246 SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) 44247 CHARACTER UPLO 44248 INTEGER INFO, LDA, N 44249 COMPLEX*16 A( LDA, * ) 44250 DOUBLE PRECISION ONE 44251 COMPLEX*16 CONE 44252 PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) ) 44253 LOGICAL UPPER 44254 INTEGER J, JB, NB 44255 LOGICAL LSAME 44256 INTEGER ILAENV 44257 EXTERNAL LSAME, ILAENV 44258 EXTERNAL XERBLA, ZGEMM, ZHERK, ZPOTRF2, ZTRSM 44259 INTRINSIC MAX, MIN 44260 INFO = 0 44261 UPPER = LSAME( UPLO, 'U' ) 44262 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 44263 INFO = -1 44264 ELSE IF( N.LT.0 ) THEN 44265 INFO = -2 44266 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 44267 INFO = -4 44268 END IF 44269 IF( INFO.NE.0 ) THEN 44270 CALL XERBLA( 'ZPOTRF', -INFO ) 44271 RETURN 44272 END IF 44273 IF( N.EQ.0 ) 44274 $ RETURN 44275 NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 ) 44276 IF( NB.LE.1 .OR. NB.GE.N ) THEN 44277 CALL ZPOTRF2( UPLO, N, A, LDA, INFO ) 44278 ELSE 44279 IF( UPPER ) THEN 44280 DO 10 J = 1, N, NB 44281 JB = MIN( NB, N-J+1 ) 44282 CALL ZHERK( 'Upper', 'Conjugate transpose', JB, J-1, 44283 $ -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA ) 44284 CALL ZPOTRF2( 'Upper', JB, A( J, J ), LDA, INFO ) 44285 IF( INFO.NE.0 ) 44286 $ GO TO 30 44287 IF( J+JB.LE.N ) THEN 44288 CALL ZGEMM( 'Conjugate transpose', 'No transpose', JB, 44289 $ N-J-JB+1, J-1, -CONE, A( 1, J ), LDA, 44290 $ A( 1, J+JB ), LDA, CONE, A( J, J+JB ), 44291 $ LDA ) 44292 CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose', 44293 $ 'Non-unit', JB, N-J-JB+1, CONE, A( J, J ), 44294 $ LDA, A( J, J+JB ), LDA ) 44295 END IF 44296 10 CONTINUE 44297 ELSE 44298 DO 20 J = 1, N, NB 44299 JB = MIN( NB, N-J+1 ) 44300 CALL ZHERK( 'Lower', 'No transpose', JB, J-1, -ONE, 44301 $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) 44302 CALL ZPOTRF2( 'Lower', JB, A( J, J ), LDA, INFO ) 44303 IF( INFO.NE.0 ) 44304 $ GO TO 30 44305 IF( J+JB.LE.N ) THEN 44306 CALL ZGEMM( 'No transpose', 'Conjugate transpose', 44307 $ N-J-JB+1, JB, J-1, -CONE, A( J+JB, 1 ), 44308 $ LDA, A( J, 1 ), LDA, CONE, A( J+JB, J ), 44309 $ LDA ) 44310 CALL ZTRSM( 'Right', 'Lower', 'Conjugate transpose', 44311 $ 'Non-unit', N-J-JB+1, JB, CONE, A( J, J ), 44312 $ LDA, A( J+JB, J ), LDA ) 44313 END IF 44314 20 CONTINUE 44315 END IF 44316 END IF 44317 GO TO 40 44318 30 CONTINUE 44319 INFO = INFO + J - 1 44320 40 CONTINUE 44321 RETURN 44322 END 44323! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zpotrf2.f 44324 RECURSIVE SUBROUTINE ZPOTRF2( UPLO, N, A, LDA, INFO ) 44325 CHARACTER UPLO 44326 INTEGER INFO, LDA, N 44327 COMPLEX*16 A( LDA, * ) 44328 DOUBLE PRECISION ONE, ZERO 44329 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 44330 COMPLEX*16 CONE 44331 PARAMETER ( CONE = (1.0D+0, 0.0D+0) ) 44332 LOGICAL UPPER 44333 INTEGER N1, N2, IINFO 44334 DOUBLE PRECISION AJJ 44335 LOGICAL LSAME, DISNAN 44336 EXTERNAL LSAME, DISNAN 44337 EXTERNAL ZHERK, ZTRSM, XERBLA 44338 INTRINSIC MAX, DBLE, SQRT 44339 INFO = 0 44340 UPPER = LSAME( UPLO, 'U' ) 44341 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 44342 INFO = -1 44343 ELSE IF( N.LT.0 ) THEN 44344 INFO = -2 44345 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 44346 INFO = -4 44347 END IF 44348 IF( INFO.NE.0 ) THEN 44349 CALL XERBLA( 'ZPOTRF2', -INFO ) 44350 RETURN 44351 END IF 44352 IF( N.EQ.0 ) 44353 $ RETURN 44354 IF( N.EQ.1 ) THEN 44355 AJJ = DBLE( A( 1, 1 ) ) 44356 IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN 44357 INFO = 1 44358 RETURN 44359 END IF 44360 A( 1, 1 ) = SQRT( AJJ ) 44361 ELSE 44362 N1 = N/2 44363 N2 = N-N1 44364 CALL ZPOTRF2( UPLO, N1, A( 1, 1 ), LDA, IINFO ) 44365 IF ( IINFO.NE.0 ) THEN 44366 INFO = IINFO 44367 RETURN 44368 END IF 44369 IF( UPPER ) THEN 44370 CALL ZTRSM( 'L', 'U', 'C', 'N', N1, N2, CONE, 44371 $ A( 1, 1 ), LDA, A( 1, N1+1 ), LDA ) 44372 CALL ZHERK( UPLO, 'C', N2, N1, -ONE, A( 1, N1+1 ), LDA, 44373 $ ONE, A( N1+1, N1+1 ), LDA ) 44374 CALL ZPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) 44375 IF ( IINFO.NE.0 ) THEN 44376 INFO = IINFO + N1 44377 RETURN 44378 END IF 44379 ELSE 44380 CALL ZTRSM( 'R', 'L', 'C', 'N', N2, N1, CONE, 44381 $ A( 1, 1 ), LDA, A( N1+1, 1 ), LDA ) 44382 CALL ZHERK( UPLO, 'N', N2, N1, -ONE, A( N1+1, 1 ), LDA, 44383 $ ONE, A( N1+1, N1+1 ), LDA ) 44384 CALL ZPOTRF2( UPLO, N2, A( N1+1, N1+1 ), LDA, IINFO ) 44385 IF ( IINFO.NE.0 ) THEN 44386 INFO = IINFO + N1 44387 RETURN 44388 END IF 44389 END IF 44390 END IF 44391 RETURN 44392 END 44393! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zpotrs.f 44394 SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) 44395 CHARACTER UPLO 44396 INTEGER INFO, LDA, LDB, N, NRHS 44397 COMPLEX*16 A( LDA, * ), B( LDB, * ) 44398 COMPLEX*16 ONE 44399 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 44400 LOGICAL UPPER 44401 LOGICAL LSAME 44402 EXTERNAL LSAME 44403 EXTERNAL XERBLA, ZTRSM 44404 INTRINSIC MAX 44405 INFO = 0 44406 UPPER = LSAME( UPLO, 'U' ) 44407 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 44408 INFO = -1 44409 ELSE IF( N.LT.0 ) THEN 44410 INFO = -2 44411 ELSE IF( NRHS.LT.0 ) THEN 44412 INFO = -3 44413 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 44414 INFO = -5 44415 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 44416 INFO = -7 44417 END IF 44418 IF( INFO.NE.0 ) THEN 44419 CALL XERBLA( 'ZPOTRS', -INFO ) 44420 RETURN 44421 END IF 44422 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 44423 $ RETURN 44424 IF( UPPER ) THEN 44425 CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose', 'Non-unit', 44426 $ N, NRHS, ONE, A, LDA, B, LDB ) 44427 CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, 44428 $ NRHS, ONE, A, LDA, B, LDB ) 44429 ELSE 44430 CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, 44431 $ NRHS, ONE, A, LDA, B, LDB ) 44432 CALL ZTRSM( 'Left', 'Lower', 'Conjugate transpose', 'Non-unit', 44433 $ N, NRHS, ONE, A, LDA, B, LDB ) 44434 END IF 44435 RETURN 44436 END 44437! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zpptrf.f 44438 SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) 44439 CHARACTER UPLO 44440 INTEGER INFO, N 44441 COMPLEX*16 AP( * ) 44442 DOUBLE PRECISION ZERO, ONE 44443 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 44444 LOGICAL UPPER 44445 INTEGER J, JC, JJ 44446 DOUBLE PRECISION AJJ 44447 LOGICAL LSAME 44448 COMPLEX*16 ZDOTC 44449 EXTERNAL LSAME, ZDOTC 44450 EXTERNAL XERBLA, ZDSCAL, ZHPR, ZTPSV 44451 INTRINSIC DBLE, SQRT 44452 INFO = 0 44453 UPPER = LSAME( UPLO, 'U' ) 44454 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 44455 INFO = -1 44456 ELSE IF( N.LT.0 ) THEN 44457 INFO = -2 44458 END IF 44459 IF( INFO.NE.0 ) THEN 44460 CALL XERBLA( 'ZPPTRF', -INFO ) 44461 RETURN 44462 END IF 44463 IF( N.EQ.0 ) 44464 $ RETURN 44465 IF( UPPER ) THEN 44466 JJ = 0 44467 DO 10 J = 1, N 44468 JC = JJ + 1 44469 JJ = JJ + J 44470 IF( J.GT.1 ) 44471 $ CALL ZTPSV( 'Upper', 'Conjugate transpose', 'Non-unit', 44472 $ J-1, AP, AP( JC ), 1 ) 44473 AJJ = DBLE( AP( JJ ) ) - ZDOTC( J-1, AP( JC ), 1, AP( JC ), 44474 $ 1 ) 44475 IF( AJJ.LE.ZERO ) THEN 44476 AP( JJ ) = AJJ 44477 GO TO 30 44478 END IF 44479 AP( JJ ) = SQRT( AJJ ) 44480 10 CONTINUE 44481 ELSE 44482 JJ = 1 44483 DO 20 J = 1, N 44484 AJJ = DBLE( AP( JJ ) ) 44485 IF( AJJ.LE.ZERO ) THEN 44486 AP( JJ ) = AJJ 44487 GO TO 30 44488 END IF 44489 AJJ = SQRT( AJJ ) 44490 AP( JJ ) = AJJ 44491 IF( J.LT.N ) THEN 44492 CALL ZDSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 ) 44493 CALL ZHPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1, 44494 $ AP( JJ+N-J+1 ) ) 44495 JJ = JJ + N - J + 1 44496 END IF 44497 20 CONTINUE 44498 END IF 44499 GO TO 40 44500 30 CONTINUE 44501 INFO = J 44502 40 CONTINUE 44503 RETURN 44504 END 44505! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zrot.f 44506 SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) 44507 INTEGER INCX, INCY, N 44508 DOUBLE PRECISION C 44509 COMPLEX*16 S 44510 COMPLEX*16 CX( * ), CY( * ) 44511 INTEGER I, IX, IY 44512 COMPLEX*16 STEMP 44513 INTRINSIC DCONJG 44514 IF( N.LE.0 ) 44515 $ RETURN 44516 IF( INCX.EQ.1 .AND. INCY.EQ.1 ) 44517 $ GO TO 20 44518 IX = 1 44519 IY = 1 44520 IF( INCX.LT.0 ) 44521 $ IX = ( -N+1 )*INCX + 1 44522 IF( INCY.LT.0 ) 44523 $ IY = ( -N+1 )*INCY + 1 44524 DO 10 I = 1, N 44525 STEMP = C*CX( IX ) + S*CY( IY ) 44526 CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX ) 44527 CX( IX ) = STEMP 44528 IX = IX + INCX 44529 IY = IY + INCY 44530 10 CONTINUE 44531 RETURN 44532 20 CONTINUE 44533 DO 30 I = 1, N 44534 STEMP = C*CX( I ) + S*CY( I ) 44535 CY( I ) = C*CY( I ) - DCONJG( S )*CX( I ) 44536 CX( I ) = STEMP 44537 30 CONTINUE 44538 RETURN 44539 END 44540! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zstedc.f 44541 SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, 44542 $ LRWORK, IWORK, LIWORK, INFO ) 44543 CHARACTER COMPZ 44544 INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N 44545 INTEGER IWORK( * ) 44546 DOUBLE PRECISION D( * ), E( * ), RWORK( * ) 44547 COMPLEX*16 WORK( * ), Z( LDZ, * ) 44548 DOUBLE PRECISION ZERO, ONE, TWO 44549 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) 44550 LOGICAL LQUERY 44551 INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN, LL, 44552 $ LRWMIN, LWMIN, M, SMLSIZ, START 44553 DOUBLE PRECISION EPS, ORGNRM, P, TINY 44554 LOGICAL LSAME 44555 INTEGER ILAENV 44556 DOUBLE PRECISION DLAMCH, DLANST 44557 EXTERNAL LSAME, ILAENV, DLAMCH, DLANST 44558 EXTERNAL DLASCL, DLASET, DSTEDC, DSTEQR, DSTERF, XERBLA, 44559 $ ZLACPY, ZLACRM, ZLAED0, ZSTEQR, ZSWAP 44560 INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT 44561 INFO = 0 44562 LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 44563 IF( LSAME( COMPZ, 'N' ) ) THEN 44564 ICOMPZ = 0 44565 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN 44566 ICOMPZ = 1 44567 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN 44568 ICOMPZ = 2 44569 ELSE 44570 ICOMPZ = -1 44571 END IF 44572 IF( ICOMPZ.LT.0 ) THEN 44573 INFO = -1 44574 ELSE IF( N.LT.0 ) THEN 44575 INFO = -2 44576 ELSE IF( ( LDZ.LT.1 ) .OR. 44577 $ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN 44578 INFO = -6 44579 END IF 44580 IF( INFO.EQ.0 ) THEN 44581 SMLSIZ = ILAENV( 9, 'ZSTEDC', ' ', 0, 0, 0, 0 ) 44582 IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN 44583 LWMIN = 1 44584 LIWMIN = 1 44585 LRWMIN = 1 44586 ELSE IF( N.LE.SMLSIZ ) THEN 44587 LWMIN = 1 44588 LIWMIN = 1 44589 LRWMIN = 2*( N - 1 ) 44590 ELSE IF( ICOMPZ.EQ.1 ) THEN 44591 LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) ) 44592 IF( 2**LGN.LT.N ) 44593 $ LGN = LGN + 1 44594 IF( 2**LGN.LT.N ) 44595 $ LGN = LGN + 1 44596 LWMIN = N*N 44597 LRWMIN = 1 + 3*N + 2*N*LGN + 4*N**2 44598 LIWMIN = 6 + 6*N + 5*N*LGN 44599 ELSE IF( ICOMPZ.EQ.2 ) THEN 44600 LWMIN = 1 44601 LRWMIN = 1 + 4*N + 2*N**2 44602 LIWMIN = 3 + 5*N 44603 END IF 44604 WORK( 1 ) = LWMIN 44605 RWORK( 1 ) = LRWMIN 44606 IWORK( 1 ) = LIWMIN 44607 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 44608 INFO = -8 44609 ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN 44610 INFO = -10 44611 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 44612 INFO = -12 44613 END IF 44614 END IF 44615 IF( INFO.NE.0 ) THEN 44616 CALL XERBLA( 'ZSTEDC', -INFO ) 44617 RETURN 44618 ELSE IF( LQUERY ) THEN 44619 RETURN 44620 END IF 44621 IF( N.EQ.0 ) 44622 $ RETURN 44623 IF( N.EQ.1 ) THEN 44624 IF( ICOMPZ.NE.0 ) 44625 $ Z( 1, 1 ) = ONE 44626 RETURN 44627 END IF 44628 IF( ICOMPZ.EQ.0 ) THEN 44629 CALL DSTERF( N, D, E, INFO ) 44630 GO TO 70 44631 END IF 44632 IF( N.LE.SMLSIZ ) THEN 44633 CALL ZSTEQR( COMPZ, N, D, E, Z, LDZ, RWORK, INFO ) 44634 ELSE 44635 IF( ICOMPZ.EQ.2 ) THEN 44636 CALL DLASET( 'Full', N, N, ZERO, ONE, RWORK, N ) 44637 LL = N*N + 1 44638 CALL DSTEDC( 'I', N, D, E, RWORK, N, 44639 $ RWORK( LL ), LRWORK-LL+1, IWORK, LIWORK, INFO ) 44640 DO 20 J = 1, N 44641 DO 10 I = 1, N 44642 Z( I, J ) = RWORK( ( J-1 )*N+I ) 44643 10 CONTINUE 44644 20 CONTINUE 44645 GO TO 70 44646 END IF 44647 ORGNRM = DLANST( 'M', N, D, E ) 44648 IF( ORGNRM.EQ.ZERO ) 44649 $ GO TO 70 44650 EPS = DLAMCH( 'Epsilon' ) 44651 START = 1 44652 30 CONTINUE 44653 IF( START.LE.N ) THEN 44654 FINISH = START 44655 40 CONTINUE 44656 IF( FINISH.LT.N ) THEN 44657 TINY = EPS*SQRT( ABS( D( FINISH ) ) )* 44658 $ SQRT( ABS( D( FINISH+1 ) ) ) 44659 IF( ABS( E( FINISH ) ).GT.TINY ) THEN 44660 FINISH = FINISH + 1 44661 GO TO 40 44662 END IF 44663 END IF 44664 M = FINISH - START + 1 44665 IF( M.GT.SMLSIZ ) THEN 44666 ORGNRM = DLANST( 'M', M, D( START ), E( START ) ) 44667 CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M, 44668 $ INFO ) 44669 CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ), 44670 $ M-1, INFO ) 44671 CALL ZLAED0( N, M, D( START ), E( START ), Z( 1, START ), 44672 $ LDZ, WORK, N, RWORK, IWORK, INFO ) 44673 IF( INFO.GT.0 ) THEN 44674 INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + 44675 $ MOD( INFO, ( M+1 ) ) + START - 1 44676 GO TO 70 44677 END IF 44678 CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M, 44679 $ INFO ) 44680 ELSE 44681 CALL DSTEQR( 'I', M, D( START ), E( START ), RWORK, M, 44682 $ RWORK( M*M+1 ), INFO ) 44683 CALL ZLACRM( N, M, Z( 1, START ), LDZ, RWORK, M, WORK, N, 44684 $ RWORK( M*M+1 ) ) 44685 CALL ZLACPY( 'A', N, M, WORK, N, Z( 1, START ), LDZ ) 44686 IF( INFO.GT.0 ) THEN 44687 INFO = START*( N+1 ) + FINISH 44688 GO TO 70 44689 END IF 44690 END IF 44691 START = FINISH + 1 44692 GO TO 30 44693 END IF 44694 DO 60 II = 2, N 44695 I = II - 1 44696 K = I 44697 P = D( I ) 44698 DO 50 J = II, N 44699 IF( D( J ).LT.P ) THEN 44700 K = J 44701 P = D( J ) 44702 END IF 44703 50 CONTINUE 44704 IF( K.NE.I ) THEN 44705 D( K ) = D( I ) 44706 D( I ) = P 44707 CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) 44708 END IF 44709 60 CONTINUE 44710 END IF 44711 70 CONTINUE 44712 WORK( 1 ) = LWMIN 44713 RWORK( 1 ) = LRWMIN 44714 IWORK( 1 ) = LIWMIN 44715 RETURN 44716 END 44717! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zstein.f 44718 SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, 44719 $ IWORK, IFAIL, INFO ) 44720 INTEGER INFO, LDZ, M, N 44721 INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), 44722 $ IWORK( * ) 44723 DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) 44724 COMPLEX*16 Z( LDZ, * ) 44725 COMPLEX*16 CZERO, CONE 44726 PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), 44727 $ CONE = ( 1.0D+0, 0.0D+0 ) ) 44728 DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1 44729 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, 44730 $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 ) 44731 INTEGER MAXITS, EXTRA 44732 PARAMETER ( MAXITS = 5, EXTRA = 2 ) 44733 INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, 44734 $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, 44735 $ JBLK, JMAX, JR, NBLK, NRMCHK 44736 DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, 44737 $ SCL, SEP, TOL, XJ, XJM, ZTR 44738 INTEGER ISEED( 4 ) 44739 INTEGER IDAMAX 44740 DOUBLE PRECISION DLAMCH, DNRM2 44741 EXTERNAL IDAMAX, DLAMCH, DNRM2 44742 EXTERNAL DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, XERBLA 44743 INTRINSIC ABS, DBLE, DCMPLX, MAX, SQRT 44744 INFO = 0 44745 DO 10 I = 1, M 44746 IFAIL( I ) = 0 44747 10 CONTINUE 44748 IF( N.LT.0 ) THEN 44749 INFO = -1 44750 ELSE IF( M.LT.0 .OR. M.GT.N ) THEN 44751 INFO = -4 44752 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN 44753 INFO = -9 44754 ELSE 44755 DO 20 J = 2, M 44756 IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN 44757 INFO = -6 44758 GO TO 30 44759 END IF 44760 IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) 44761 $ THEN 44762 INFO = -5 44763 GO TO 30 44764 END IF 44765 20 CONTINUE 44766 30 CONTINUE 44767 END IF 44768 IF( INFO.NE.0 ) THEN 44769 CALL XERBLA( 'ZSTEIN', -INFO ) 44770 RETURN 44771 END IF 44772 IF( N.EQ.0 .OR. M.EQ.0 ) THEN 44773 RETURN 44774 ELSE IF( N.EQ.1 ) THEN 44775 Z( 1, 1 ) = CONE 44776 RETURN 44777 END IF 44778 EPS = DLAMCH( 'Precision' ) 44779 DO 40 I = 1, 4 44780 ISEED( I ) = 1 44781 40 CONTINUE 44782 INDRV1 = 0 44783 INDRV2 = INDRV1 + N 44784 INDRV3 = INDRV2 + N 44785 INDRV4 = INDRV3 + N 44786 INDRV5 = INDRV4 + N 44787 J1 = 1 44788 DO 180 NBLK = 1, IBLOCK( M ) 44789 IF( NBLK.EQ.1 ) THEN 44790 B1 = 1 44791 ELSE 44792 B1 = ISPLIT( NBLK-1 ) + 1 44793 END IF 44794 BN = ISPLIT( NBLK ) 44795 BLKSIZ = BN - B1 + 1 44796 IF( BLKSIZ.EQ.1 ) 44797 $ GO TO 60 44798 GPIND = J1 44799 ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) ) 44800 ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) ) 44801 DO 50 I = B1 + 1, BN - 1 44802 ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ 44803 $ ABS( E( I ) ) ) 44804 50 CONTINUE 44805 ORTOL = ODM3*ONENRM 44806 DTPCRT = SQRT( ODM1 / BLKSIZ ) 44807 60 CONTINUE 44808 JBLK = 0 44809 DO 170 J = J1, M 44810 IF( IBLOCK( J ).NE.NBLK ) THEN 44811 J1 = J 44812 GO TO 180 44813 END IF 44814 JBLK = JBLK + 1 44815 XJ = W( J ) 44816 IF( BLKSIZ.EQ.1 ) THEN 44817 WORK( INDRV1+1 ) = ONE 44818 GO TO 140 44819 END IF 44820 IF( JBLK.GT.1 ) THEN 44821 EPS1 = ABS( EPS*XJ ) 44822 PERTOL = TEN*EPS1 44823 SEP = XJ - XJM 44824 IF( SEP.LT.PERTOL ) 44825 $ XJ = XJM + PERTOL 44826 END IF 44827 ITS = 0 44828 NRMCHK = 0 44829 CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) ) 44830 CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 ) 44831 CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 ) 44832 CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 ) 44833 TOL = ZERO 44834 CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), 44835 $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, 44836 $ IINFO ) 44837 70 CONTINUE 44838 ITS = ITS + 1 44839 IF( ITS.GT.MAXITS ) 44840 $ GO TO 120 44841 JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) 44842 SCL = BLKSIZ*ONENRM*MAX( EPS, 44843 $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / 44844 $ ABS( WORK( INDRV1+JMAX ) ) 44845 CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) 44846 CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), 44847 $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, 44848 $ WORK( INDRV1+1 ), TOL, IINFO ) 44849 IF( JBLK.EQ.1 ) 44850 $ GO TO 110 44851 IF( ABS( XJ-XJM ).GT.ORTOL ) 44852 $ GPIND = J 44853 IF( GPIND.NE.J ) THEN 44854 DO 100 I = GPIND, J - 1 44855 ZTR = ZERO 44856 DO 80 JR = 1, BLKSIZ 44857 ZTR = ZTR + WORK( INDRV1+JR )* 44858 $ DBLE( Z( B1-1+JR, I ) ) 44859 80 CONTINUE 44860 DO 90 JR = 1, BLKSIZ 44861 WORK( INDRV1+JR ) = WORK( INDRV1+JR ) - 44862 $ ZTR*DBLE( Z( B1-1+JR, I ) ) 44863 90 CONTINUE 44864 100 CONTINUE 44865 END IF 44866 110 CONTINUE 44867 JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) 44868 NRM = ABS( WORK( INDRV1+JMAX ) ) 44869 IF( NRM.LT.DTPCRT ) 44870 $ GO TO 70 44871 NRMCHK = NRMCHK + 1 44872 IF( NRMCHK.LT.EXTRA+1 ) 44873 $ GO TO 70 44874 GO TO 130 44875 120 CONTINUE 44876 INFO = INFO + 1 44877 IFAIL( INFO ) = J 44878 130 CONTINUE 44879 SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 ) 44880 JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) 44881 IF( WORK( INDRV1+JMAX ).LT.ZERO ) 44882 $ SCL = -SCL 44883 CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) 44884 140 CONTINUE 44885 DO 150 I = 1, N 44886 Z( I, J ) = CZERO 44887 150 CONTINUE 44888 DO 160 I = 1, BLKSIZ 44889 Z( B1+I-1, J ) = DCMPLX( WORK( INDRV1+I ), ZERO ) 44890 160 CONTINUE 44891 XJM = XJ 44892 170 CONTINUE 44893 180 CONTINUE 44894 RETURN 44895 END 44896! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zstemr.f 44897 SUBROUTINE ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, 44898 $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, 44899 $ IWORK, LIWORK, INFO ) 44900 CHARACTER JOBZ, RANGE 44901 LOGICAL TRYRAC 44902 INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N 44903 DOUBLE PRECISION VL, VU 44904 INTEGER ISUPPZ( * ), IWORK( * ) 44905 DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) 44906 COMPLEX*16 Z( LDZ, * ) 44907 DOUBLE PRECISION ZERO, ONE, FOUR, MINRGP 44908 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, 44909 $ FOUR = 4.0D0, 44910 $ MINRGP = 1.0D-3 ) 44911 LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY 44912 INTEGER I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW, 44913 $ IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD, 44914 $ INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP, 44915 $ ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT, 44916 $ NZCMIN, OFFSET, WBEGIN, WEND 44917 DOUBLE PRECISION BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN, 44918 $ RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN, 44919 $ THRESH, TMP, TNRM, WL, WU 44920 LOGICAL LSAME 44921 DOUBLE PRECISION DLAMCH, DLANST 44922 EXTERNAL LSAME, DLAMCH, DLANST 44923 EXTERNAL DCOPY, DLAE2, DLAEV2, DLARRC, DLARRE, DLARRJ, 44924 $ DLARRR, DLASRT, DSCAL, XERBLA, ZLARRV, ZSWAP 44925 INTRINSIC MAX, MIN, SQRT 44926 WANTZ = LSAME( JOBZ, 'V' ) 44927 ALLEIG = LSAME( RANGE, 'A' ) 44928 VALEIG = LSAME( RANGE, 'V' ) 44929 INDEIG = LSAME( RANGE, 'I' ) 44930 LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) ) 44931 ZQUERY = ( NZC.EQ.-1 ) 44932 IF( WANTZ ) THEN 44933 LWMIN = 18*N 44934 LIWMIN = 10*N 44935 ELSE 44936 LWMIN = 12*N 44937 LIWMIN = 8*N 44938 ENDIF 44939 WL = ZERO 44940 WU = ZERO 44941 IIL = 0 44942 IIU = 0 44943 NSPLIT = 0 44944 IF( VALEIG ) THEN 44945 WL = VL 44946 WU = VU 44947 ELSEIF( INDEIG ) THEN 44948 IIL = IL 44949 IIU = IU 44950 ENDIF 44951 INFO = 0 44952 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN 44953 INFO = -1 44954 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN 44955 INFO = -2 44956 ELSE IF( N.LT.0 ) THEN 44957 INFO = -3 44958 ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN 44959 INFO = -7 44960 ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN 44961 INFO = -8 44962 ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN 44963 INFO = -9 44964 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 44965 INFO = -13 44966 ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 44967 INFO = -17 44968 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 44969 INFO = -19 44970 END IF 44971 SAFMIN = DLAMCH( 'Safe minimum' ) 44972 EPS = DLAMCH( 'Precision' ) 44973 SMLNUM = SAFMIN / EPS 44974 BIGNUM = ONE / SMLNUM 44975 RMIN = SQRT( SMLNUM ) 44976 RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) 44977 IF( INFO.EQ.0 ) THEN 44978 WORK( 1 ) = LWMIN 44979 IWORK( 1 ) = LIWMIN 44980 IF( WANTZ .AND. ALLEIG ) THEN 44981 NZCMIN = N 44982 ELSE IF( WANTZ .AND. VALEIG ) THEN 44983 CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN, 44984 $ NZCMIN, ITMP, ITMP2, INFO ) 44985 ELSE IF( WANTZ .AND. INDEIG ) THEN 44986 NZCMIN = IIU-IIL+1 44987 ELSE 44988 NZCMIN = 0 44989 ENDIF 44990 IF( ZQUERY .AND. INFO.EQ.0 ) THEN 44991 Z( 1,1 ) = NZCMIN 44992 ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN 44993 INFO = -14 44994 END IF 44995 END IF 44996 IF( INFO.NE.0 ) THEN 44997 CALL XERBLA( 'ZSTEMR', -INFO ) 44998 RETURN 44999 ELSE IF( LQUERY .OR. ZQUERY ) THEN 45000 RETURN 45001 END IF 45002 M = 0 45003 IF( N.EQ.0 ) 45004 $ RETURN 45005 IF( N.EQ.1 ) THEN 45006 IF( ALLEIG .OR. INDEIG ) THEN 45007 M = 1 45008 W( 1 ) = D( 1 ) 45009 ELSE 45010 IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN 45011 M = 1 45012 W( 1 ) = D( 1 ) 45013 END IF 45014 END IF 45015 IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN 45016 Z( 1, 1 ) = ONE 45017 ISUPPZ(1) = 1 45018 ISUPPZ(2) = 1 45019 END IF 45020 RETURN 45021 END IF 45022 IF( N.EQ.2 ) THEN 45023 IF( .NOT.WANTZ ) THEN 45024 CALL DLAE2( D(1), E(1), D(2), R1, R2 ) 45025 ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN 45026 CALL DLAEV2( D(1), E(1), D(2), R1, R2, CS, SN ) 45027 END IF 45028 IF( ALLEIG.OR. 45029 $ (VALEIG.AND.(R2.GT.WL).AND. 45030 $ (R2.LE.WU)).OR. 45031 $ (INDEIG.AND.(IIL.EQ.1)) ) THEN 45032 M = M+1 45033 W( M ) = R2 45034 IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN 45035 Z( 1, M ) = -SN 45036 Z( 2, M ) = CS 45037 IF (SN.NE.ZERO) THEN 45038 IF (CS.NE.ZERO) THEN 45039 ISUPPZ(2*M-1) = 1 45040 ISUPPZ(2*M) = 2 45041 ELSE 45042 ISUPPZ(2*M-1) = 1 45043 ISUPPZ(2*M) = 1 45044 END IF 45045 ELSE 45046 ISUPPZ(2*M-1) = 2 45047 ISUPPZ(2*M) = 2 45048 END IF 45049 ENDIF 45050 ENDIF 45051 IF( ALLEIG.OR. 45052 $ (VALEIG.AND.(R1.GT.WL).AND. 45053 $ (R1.LE.WU)).OR. 45054 $ (INDEIG.AND.(IIU.EQ.2)) ) THEN 45055 M = M+1 45056 W( M ) = R1 45057 IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN 45058 Z( 1, M ) = CS 45059 Z( 2, M ) = SN 45060 IF (SN.NE.ZERO) THEN 45061 IF (CS.NE.ZERO) THEN 45062 ISUPPZ(2*M-1) = 1 45063 ISUPPZ(2*M) = 2 45064 ELSE 45065 ISUPPZ(2*M-1) = 1 45066 ISUPPZ(2*M) = 1 45067 END IF 45068 ELSE 45069 ISUPPZ(2*M-1) = 2 45070 ISUPPZ(2*M) = 2 45071 END IF 45072 ENDIF 45073 ENDIF 45074 ELSE 45075 INDGRS = 1 45076 INDERR = 2*N + 1 45077 INDGP = 3*N + 1 45078 INDD = 4*N + 1 45079 INDE2 = 5*N + 1 45080 INDWRK = 6*N + 1 45081 IINSPL = 1 45082 IINDBL = N + 1 45083 IINDW = 2*N + 1 45084 IINDWK = 3*N + 1 45085 SCALE = ONE 45086 TNRM = DLANST( 'M', N, D, E ) 45087 IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN 45088 SCALE = RMIN / TNRM 45089 ELSE IF( TNRM.GT.RMAX ) THEN 45090 SCALE = RMAX / TNRM 45091 END IF 45092 IF( SCALE.NE.ONE ) THEN 45093 CALL DSCAL( N, SCALE, D, 1 ) 45094 CALL DSCAL( N-1, SCALE, E, 1 ) 45095 TNRM = TNRM*SCALE 45096 IF( VALEIG ) THEN 45097 WL = WL*SCALE 45098 WU = WU*SCALE 45099 ENDIF 45100 END IF 45101 IF( TRYRAC ) THEN 45102 CALL DLARRR( N, D, E, IINFO ) 45103 ELSE 45104 IINFO = -1 45105 ENDIF 45106 IF (IINFO.EQ.0) THEN 45107 THRESH = EPS 45108 ELSE 45109 THRESH = -EPS 45110 TRYRAC = .FALSE. 45111 ENDIF 45112 IF( TRYRAC ) THEN 45113 CALL DCOPY(N,D,1,WORK(INDD),1) 45114 ENDIF 45115 DO 5 J = 1, N-1 45116 WORK( INDE2+J-1 ) = E(J)**2 45117 5 CONTINUE 45118 IF( .NOT.WANTZ ) THEN 45119 RTOL1 = FOUR * EPS 45120 RTOL2 = FOUR * EPS 45121 ELSE 45122 RTOL1 = SQRT(EPS) 45123 RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS ) 45124 ENDIF 45125 CALL DLARRE( RANGE, N, WL, WU, IIL, IIU, D, E, 45126 $ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT, 45127 $ IWORK( IINSPL ), M, W, WORK( INDERR ), 45128 $ WORK( INDGP ), IWORK( IINDBL ), 45129 $ IWORK( IINDW ), WORK( INDGRS ), PIVMIN, 45130 $ WORK( INDWRK ), IWORK( IINDWK ), IINFO ) 45131 IF( IINFO.NE.0 ) THEN 45132 INFO = 10 + ABS( IINFO ) 45133 RETURN 45134 END IF 45135 IF( WANTZ ) THEN 45136 CALL ZLARRV( N, WL, WU, D, E, 45137 $ PIVMIN, IWORK( IINSPL ), M, 45138 $ 1, M, MINRGP, RTOL1, RTOL2, 45139 $ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ), 45140 $ IWORK( IINDW ), WORK( INDGRS ), Z, LDZ, 45141 $ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO ) 45142 IF( IINFO.NE.0 ) THEN 45143 INFO = 20 + ABS( IINFO ) 45144 RETURN 45145 END IF 45146 ELSE 45147 DO 20 J = 1, M 45148 ITMP = IWORK( IINDBL+J-1 ) 45149 W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) ) 45150 20 CONTINUE 45151 END IF 45152 IF ( TRYRAC ) THEN 45153 IBEGIN = 1 45154 WBEGIN = 1 45155 DO 39 JBLK = 1, IWORK( IINDBL+M-1 ) 45156 IEND = IWORK( IINSPL+JBLK-1 ) 45157 IN = IEND - IBEGIN + 1 45158 WEND = WBEGIN - 1 45159 36 CONTINUE 45160 IF( WEND.LT.M ) THEN 45161 IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN 45162 WEND = WEND + 1 45163 GO TO 36 45164 END IF 45165 END IF 45166 IF( WEND.LT.WBEGIN ) THEN 45167 IBEGIN = IEND + 1 45168 GO TO 39 45169 END IF 45170 OFFSET = IWORK(IINDW+WBEGIN-1)-1 45171 IFIRST = IWORK(IINDW+WBEGIN-1) 45172 ILAST = IWORK(IINDW+WEND-1) 45173 RTOL2 = FOUR * EPS 45174 CALL DLARRJ( IN, 45175 $ WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1), 45176 $ IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN), 45177 $ WORK( INDERR+WBEGIN-1 ), 45178 $ WORK( INDWRK ), IWORK( IINDWK ), PIVMIN, 45179 $ TNRM, IINFO ) 45180 IBEGIN = IEND + 1 45181 WBEGIN = WEND + 1 45182 39 CONTINUE 45183 ENDIF 45184 IF( SCALE.NE.ONE ) THEN 45185 CALL DSCAL( M, ONE / SCALE, W, 1 ) 45186 END IF 45187 END IF 45188 IF( NSPLIT.GT.1 .OR. N.EQ.2 ) THEN 45189 IF( .NOT. WANTZ ) THEN 45190 CALL DLASRT( 'I', M, W, IINFO ) 45191 IF( IINFO.NE.0 ) THEN 45192 INFO = 3 45193 RETURN 45194 END IF 45195 ELSE 45196 DO 60 J = 1, M - 1 45197 I = 0 45198 TMP = W( J ) 45199 DO 50 JJ = J + 1, M 45200 IF( W( JJ ).LT.TMP ) THEN 45201 I = JJ 45202 TMP = W( JJ ) 45203 END IF 45204 50 CONTINUE 45205 IF( I.NE.0 ) THEN 45206 W( I ) = W( J ) 45207 W( J ) = TMP 45208 IF( WANTZ ) THEN 45209 CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) 45210 ITMP = ISUPPZ( 2*I-1 ) 45211 ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 ) 45212 ISUPPZ( 2*J-1 ) = ITMP 45213 ITMP = ISUPPZ( 2*I ) 45214 ISUPPZ( 2*I ) = ISUPPZ( 2*J ) 45215 ISUPPZ( 2*J ) = ITMP 45216 END IF 45217 END IF 45218 60 CONTINUE 45219 END IF 45220 ENDIF 45221 WORK( 1 ) = LWMIN 45222 IWORK( 1 ) = LIWMIN 45223 RETURN 45224 END 45225! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zsteqr.f 45226 SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) 45227 CHARACTER COMPZ 45228 INTEGER INFO, LDZ, N 45229 DOUBLE PRECISION D( * ), E( * ), WORK( * ) 45230 COMPLEX*16 Z( LDZ, * ) 45231 DOUBLE PRECISION ZERO, ONE, TWO, THREE 45232 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 45233 $ THREE = 3.0D0 ) 45234 COMPLEX*16 CZERO, CONE 45235 PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), 45236 $ CONE = ( 1.0D0, 0.0D0 ) ) 45237 INTEGER MAXIT 45238 PARAMETER ( MAXIT = 30 ) 45239 INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, 45240 $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, 45241 $ NM1, NMAXIT 45242 DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, 45243 $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST 45244 LOGICAL LSAME 45245 DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 45246 EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 45247 EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA, 45248 $ ZLASET, ZLASR, ZSWAP 45249 INTRINSIC ABS, MAX, SIGN, SQRT 45250 INFO = 0 45251 IF( LSAME( COMPZ, 'N' ) ) THEN 45252 ICOMPZ = 0 45253 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN 45254 ICOMPZ = 1 45255 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN 45256 ICOMPZ = 2 45257 ELSE 45258 ICOMPZ = -1 45259 END IF 45260 IF( ICOMPZ.LT.0 ) THEN 45261 INFO = -1 45262 ELSE IF( N.LT.0 ) THEN 45263 INFO = -2 45264 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, 45265 $ N ) ) ) THEN 45266 INFO = -6 45267 END IF 45268 IF( INFO.NE.0 ) THEN 45269 CALL XERBLA( 'ZSTEQR', -INFO ) 45270 RETURN 45271 END IF 45272 IF( N.EQ.0 ) 45273 $ RETURN 45274 IF( N.EQ.1 ) THEN 45275 IF( ICOMPZ.EQ.2 ) 45276 $ Z( 1, 1 ) = CONE 45277 RETURN 45278 END IF 45279 EPS = DLAMCH( 'E' ) 45280 EPS2 = EPS**2 45281 SAFMIN = DLAMCH( 'S' ) 45282 SAFMAX = ONE / SAFMIN 45283 SSFMAX = SQRT( SAFMAX ) / THREE 45284 SSFMIN = SQRT( SAFMIN ) / EPS2 45285 IF( ICOMPZ.EQ.2 ) 45286 $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) 45287 NMAXIT = N*MAXIT 45288 JTOT = 0 45289 L1 = 1 45290 NM1 = N - 1 45291 10 CONTINUE 45292 IF( L1.GT.N ) 45293 $ GO TO 160 45294 IF( L1.GT.1 ) 45295 $ E( L1-1 ) = ZERO 45296 IF( L1.LE.NM1 ) THEN 45297 DO 20 M = L1, NM1 45298 TST = ABS( E( M ) ) 45299 IF( TST.EQ.ZERO ) 45300 $ GO TO 30 45301 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ 45302 $ 1 ) ) ) )*EPS ) THEN 45303 E( M ) = ZERO 45304 GO TO 30 45305 END IF 45306 20 CONTINUE 45307 END IF 45308 M = N 45309 30 CONTINUE 45310 L = L1 45311 LSV = L 45312 LEND = M 45313 LENDSV = LEND 45314 L1 = M + 1 45315 IF( LEND.EQ.L ) 45316 $ GO TO 10 45317 ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) 45318 ISCALE = 0 45319 IF( ANORM.EQ.ZERO ) 45320 $ GO TO 10 45321 IF( ANORM.GT.SSFMAX ) THEN 45322 ISCALE = 1 45323 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, 45324 $ INFO ) 45325 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, 45326 $ INFO ) 45327 ELSE IF( ANORM.LT.SSFMIN ) THEN 45328 ISCALE = 2 45329 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, 45330 $ INFO ) 45331 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, 45332 $ INFO ) 45333 END IF 45334 IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN 45335 LEND = LSV 45336 L = LENDSV 45337 END IF 45338 IF( LEND.GT.L ) THEN 45339 40 CONTINUE 45340 IF( L.NE.LEND ) THEN 45341 LENDM1 = LEND - 1 45342 DO 50 M = L, LENDM1 45343 TST = ABS( E( M ) )**2 45344 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ 45345 $ SAFMIN )GO TO 60 45346 50 CONTINUE 45347 END IF 45348 M = LEND 45349 60 CONTINUE 45350 IF( M.LT.LEND ) 45351 $ E( M ) = ZERO 45352 P = D( L ) 45353 IF( M.EQ.L ) 45354 $ GO TO 80 45355 IF( M.EQ.L+1 ) THEN 45356 IF( ICOMPZ.GT.0 ) THEN 45357 CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) 45358 WORK( L ) = C 45359 WORK( N-1+L ) = S 45360 CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ), 45361 $ WORK( N-1+L ), Z( 1, L ), LDZ ) 45362 ELSE 45363 CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) 45364 END IF 45365 D( L ) = RT1 45366 D( L+1 ) = RT2 45367 E( L ) = ZERO 45368 L = L + 2 45369 IF( L.LE.LEND ) 45370 $ GO TO 40 45371 GO TO 140 45372 END IF 45373 IF( JTOT.EQ.NMAXIT ) 45374 $ GO TO 140 45375 JTOT = JTOT + 1 45376 G = ( D( L+1 )-P ) / ( TWO*E( L ) ) 45377 R = DLAPY2( G, ONE ) 45378 G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) 45379 S = ONE 45380 C = ONE 45381 P = ZERO 45382 MM1 = M - 1 45383 DO 70 I = MM1, L, -1 45384 F = S*E( I ) 45385 B = C*E( I ) 45386 CALL DLARTG( G, F, C, S, R ) 45387 IF( I.NE.M-1 ) 45388 $ E( I+1 ) = R 45389 G = D( I+1 ) - P 45390 R = ( D( I )-G )*S + TWO*C*B 45391 P = S*R 45392 D( I+1 ) = G + P 45393 G = C*R - B 45394 IF( ICOMPZ.GT.0 ) THEN 45395 WORK( I ) = C 45396 WORK( N-1+I ) = -S 45397 END IF 45398 70 CONTINUE 45399 IF( ICOMPZ.GT.0 ) THEN 45400 MM = M - L + 1 45401 CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), 45402 $ Z( 1, L ), LDZ ) 45403 END IF 45404 D( L ) = D( L ) - P 45405 E( L ) = G 45406 GO TO 40 45407 80 CONTINUE 45408 D( L ) = P 45409 L = L + 1 45410 IF( L.LE.LEND ) 45411 $ GO TO 40 45412 GO TO 140 45413 ELSE 45414 90 CONTINUE 45415 IF( L.NE.LEND ) THEN 45416 LENDP1 = LEND + 1 45417 DO 100 M = L, LENDP1, -1 45418 TST = ABS( E( M-1 ) )**2 45419 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ 45420 $ SAFMIN )GO TO 110 45421 100 CONTINUE 45422 END IF 45423 M = LEND 45424 110 CONTINUE 45425 IF( M.GT.LEND ) 45426 $ E( M-1 ) = ZERO 45427 P = D( L ) 45428 IF( M.EQ.L ) 45429 $ GO TO 130 45430 IF( M.EQ.L-1 ) THEN 45431 IF( ICOMPZ.GT.0 ) THEN 45432 CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) 45433 WORK( M ) = C 45434 WORK( N-1+M ) = S 45435 CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ), 45436 $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) 45437 ELSE 45438 CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) 45439 END IF 45440 D( L-1 ) = RT1 45441 D( L ) = RT2 45442 E( L-1 ) = ZERO 45443 L = L - 2 45444 IF( L.GE.LEND ) 45445 $ GO TO 90 45446 GO TO 140 45447 END IF 45448 IF( JTOT.EQ.NMAXIT ) 45449 $ GO TO 140 45450 JTOT = JTOT + 1 45451 G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) 45452 R = DLAPY2( G, ONE ) 45453 G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) 45454 S = ONE 45455 C = ONE 45456 P = ZERO 45457 LM1 = L - 1 45458 DO 120 I = M, LM1 45459 F = S*E( I ) 45460 B = C*E( I ) 45461 CALL DLARTG( G, F, C, S, R ) 45462 IF( I.NE.M ) 45463 $ E( I-1 ) = R 45464 G = D( I ) - P 45465 R = ( D( I+1 )-G )*S + TWO*C*B 45466 P = S*R 45467 D( I ) = G + P 45468 G = C*R - B 45469 IF( ICOMPZ.GT.0 ) THEN 45470 WORK( I ) = C 45471 WORK( N-1+I ) = S 45472 END IF 45473 120 CONTINUE 45474 IF( ICOMPZ.GT.0 ) THEN 45475 MM = L - M + 1 45476 CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), 45477 $ Z( 1, M ), LDZ ) 45478 END IF 45479 D( L ) = D( L ) - P 45480 E( LM1 ) = G 45481 GO TO 90 45482 130 CONTINUE 45483 D( L ) = P 45484 L = L - 1 45485 IF( L.GE.LEND ) 45486 $ GO TO 90 45487 GO TO 140 45488 END IF 45489 140 CONTINUE 45490 IF( ISCALE.EQ.1 ) THEN 45491 CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, 45492 $ D( LSV ), N, INFO ) 45493 CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), 45494 $ N, INFO ) 45495 ELSE IF( ISCALE.EQ.2 ) THEN 45496 CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, 45497 $ D( LSV ), N, INFO ) 45498 CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), 45499 $ N, INFO ) 45500 END IF 45501 IF( JTOT.EQ.NMAXIT ) THEN 45502 DO 150 I = 1, N - 1 45503 IF( E( I ).NE.ZERO ) 45504 $ INFO = INFO + 1 45505 150 CONTINUE 45506 RETURN 45507 END IF 45508 GO TO 10 45509 160 CONTINUE 45510 IF( ICOMPZ.EQ.0 ) THEN 45511 CALL DLASRT( 'I', N, D, INFO ) 45512 ELSE 45513 DO 180 II = 2, N 45514 I = II - 1 45515 K = I 45516 P = D( I ) 45517 DO 170 J = II, N 45518 IF( D( J ).LT.P ) THEN 45519 K = J 45520 P = D( J ) 45521 END IF 45522 170 CONTINUE 45523 IF( K.NE.I ) THEN 45524 D( K ) = D( I ) 45525 D( I ) = P 45526 CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) 45527 END IF 45528 180 CONTINUE 45529 END IF 45530 RETURN 45531 END 45532! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zsytrs.f 45533 SUBROUTINE ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) 45534 CHARACTER UPLO 45535 INTEGER INFO, LDA, LDB, N, NRHS 45536 INTEGER IPIV( * ) 45537 COMPLEX*16 A( LDA, * ), B( LDB, * ) 45538 COMPLEX*16 ONE 45539 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 45540 LOGICAL UPPER 45541 INTEGER J, K, KP 45542 COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM 45543 LOGICAL LSAME 45544 EXTERNAL LSAME 45545 EXTERNAL XERBLA, ZGEMV, ZGERU, ZSCAL, ZSWAP 45546 INTRINSIC MAX 45547 INFO = 0 45548 UPPER = LSAME( UPLO, 'U' ) 45549 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 45550 INFO = -1 45551 ELSE IF( N.LT.0 ) THEN 45552 INFO = -2 45553 ELSE IF( NRHS.LT.0 ) THEN 45554 INFO = -3 45555 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 45556 INFO = -5 45557 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 45558 INFO = -8 45559 END IF 45560 IF( INFO.NE.0 ) THEN 45561 CALL XERBLA( 'ZSYTRS', -INFO ) 45562 RETURN 45563 END IF 45564 IF( N.EQ.0 .OR. NRHS.EQ.0 ) 45565 $ RETURN 45566 IF( UPPER ) THEN 45567 K = N 45568 10 CONTINUE 45569 IF( K.LT.1 ) 45570 $ GO TO 30 45571 IF( IPIV( K ).GT.0 ) THEN 45572 KP = IPIV( K ) 45573 IF( KP.NE.K ) 45574 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 45575 CALL ZGERU( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 45576 $ B( 1, 1 ), LDB ) 45577 CALL ZSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) 45578 K = K - 1 45579 ELSE 45580 KP = -IPIV( K ) 45581 IF( KP.NE.K-1 ) 45582 $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) 45583 CALL ZGERU( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB, 45584 $ B( 1, 1 ), LDB ) 45585 CALL ZGERU( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ), 45586 $ LDB, B( 1, 1 ), LDB ) 45587 AKM1K = A( K-1, K ) 45588 AKM1 = A( K-1, K-1 ) / AKM1K 45589 AK = A( K, K ) / AKM1K 45590 DENOM = AKM1*AK - ONE 45591 DO 20 J = 1, NRHS 45592 BKM1 = B( K-1, J ) / AKM1K 45593 BK = B( K, J ) / AKM1K 45594 B( K-1, J ) = ( AK*BKM1-BK ) / DENOM 45595 B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM 45596 20 CONTINUE 45597 K = K - 2 45598 END IF 45599 GO TO 10 45600 30 CONTINUE 45601 K = 1 45602 40 CONTINUE 45603 IF( K.GT.N ) 45604 $ GO TO 50 45605 IF( IPIV( K ).GT.0 ) THEN 45606 CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), 45607 $ 1, ONE, B( K, 1 ), LDB ) 45608 KP = IPIV( K ) 45609 IF( KP.NE.K ) 45610 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 45611 K = K + 1 45612 ELSE 45613 CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ), 45614 $ 1, ONE, B( K, 1 ), LDB ) 45615 CALL ZGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, 45616 $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB ) 45617 KP = -IPIV( K ) 45618 IF( KP.NE.K ) 45619 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 45620 K = K + 2 45621 END IF 45622 GO TO 40 45623 50 CONTINUE 45624 ELSE 45625 K = 1 45626 60 CONTINUE 45627 IF( K.GT.N ) 45628 $ GO TO 80 45629 IF( IPIV( K ).GT.0 ) THEN 45630 KP = IPIV( K ) 45631 IF( KP.NE.K ) 45632 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 45633 IF( K.LT.N ) 45634 $ CALL ZGERU( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ), 45635 $ LDB, B( K+1, 1 ), LDB ) 45636 CALL ZSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB ) 45637 K = K + 1 45638 ELSE 45639 KP = -IPIV( K ) 45640 IF( KP.NE.K+1 ) 45641 $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) 45642 IF( K.LT.N-1 ) THEN 45643 CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ), 45644 $ LDB, B( K+2, 1 ), LDB ) 45645 CALL ZGERU( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1, 45646 $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) 45647 END IF 45648 AKM1K = A( K+1, K ) 45649 AKM1 = A( K, K ) / AKM1K 45650 AK = A( K+1, K+1 ) / AKM1K 45651 DENOM = AKM1*AK - ONE 45652 DO 70 J = 1, NRHS 45653 BKM1 = B( K, J ) / AKM1K 45654 BK = B( K+1, J ) / AKM1K 45655 B( K, J ) = ( AK*BKM1-BK ) / DENOM 45656 B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM 45657 70 CONTINUE 45658 K = K + 2 45659 END IF 45660 GO TO 60 45661 80 CONTINUE 45662 K = N 45663 90 CONTINUE 45664 IF( K.LT.1 ) 45665 $ GO TO 100 45666 IF( IPIV( K ).GT.0 ) THEN 45667 IF( K.LT.N ) 45668 $ CALL ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 45669 $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) 45670 KP = IPIV( K ) 45671 IF( KP.NE.K ) 45672 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 45673 K = K - 1 45674 ELSE 45675 IF( K.LT.N ) THEN 45676 CALL ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 45677 $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) 45678 CALL ZGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), 45679 $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ), 45680 $ LDB ) 45681 END IF 45682 KP = -IPIV( K ) 45683 IF( KP.NE.K ) 45684 $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 45685 K = K - 2 45686 END IF 45687 GO TO 90 45688 100 CONTINUE 45689 END IF 45690 RETURN 45691 END 45692! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ztrevc3.f 45693 SUBROUTINE ZTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, 45694 $ LDVR, MM, M, WORK, LWORK, RWORK, LRWORK, INFO) 45695 IMPLICIT NONE 45696 CHARACTER HOWMNY, SIDE 45697 INTEGER INFO, LDT, LDVL, LDVR, LWORK, LRWORK, M, MM, N 45698 LOGICAL SELECT( * ) 45699 DOUBLE PRECISION RWORK( * ) 45700 COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), 45701 $ WORK( * ) 45702 DOUBLE PRECISION ZERO, ONE 45703 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 45704 COMPLEX*16 CZERO, CONE 45705 PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), 45706 $ CONE = ( 1.0D+0, 0.0D+0 ) ) 45707 INTEGER NBMIN, NBMAX 45708 PARAMETER ( NBMIN = 8, NBMAX = 128 ) 45709 LOGICAL ALLV, BOTHV, LEFTV, LQUERY, OVER, RIGHTV, SOMEV 45710 INTEGER I, II, IS, J, K, KI, IV, MAXWRK, NB 45711 DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL 45712 COMPLEX*16 CDUM 45713 LOGICAL LSAME 45714 INTEGER ILAENV, IZAMAX 45715 DOUBLE PRECISION DLAMCH, DZASUM 45716 EXTERNAL LSAME, ILAENV, IZAMAX, DLAMCH, DZASUM 45717 EXTERNAL XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS, 45718 $ ZGEMM, DLABAD, ZLASET, ZLACPY 45719 INTRINSIC ABS, DBLE, DCMPLX, CONJG, AIMAG, MAX 45720 DOUBLE PRECISION CABS1 45721 CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( AIMAG( CDUM ) ) 45722 BOTHV = LSAME( SIDE, 'B' ) 45723 RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV 45724 LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV 45725 ALLV = LSAME( HOWMNY, 'A' ) 45726 OVER = LSAME( HOWMNY, 'B' ) 45727 SOMEV = LSAME( HOWMNY, 'S' ) 45728 IF( SOMEV ) THEN 45729 M = 0 45730 DO 10 J = 1, N 45731 IF( SELECT( J ) ) 45732 $ M = M + 1 45733 10 CONTINUE 45734 ELSE 45735 M = N 45736 END IF 45737 INFO = 0 45738 NB = ILAENV( 1, 'ZTREVC', SIDE // HOWMNY, N, -1, -1, -1 ) 45739 MAXWRK = N + 2*N*NB 45740 WORK(1) = MAXWRK 45741 RWORK(1) = N 45742 LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 ) 45743 IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN 45744 INFO = -1 45745 ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN 45746 INFO = -2 45747 ELSE IF( N.LT.0 ) THEN 45748 INFO = -4 45749 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN 45750 INFO = -6 45751 ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN 45752 INFO = -8 45753 ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN 45754 INFO = -10 45755 ELSE IF( MM.LT.M ) THEN 45756 INFO = -11 45757 ELSE IF( LWORK.LT.MAX( 1, 2*N ) .AND. .NOT.LQUERY ) THEN 45758 INFO = -14 45759 ELSE IF ( LRWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 45760 INFO = -16 45761 END IF 45762 IF( INFO.NE.0 ) THEN 45763 CALL XERBLA( 'ZTREVC3', -INFO ) 45764 RETURN 45765 ELSE IF( LQUERY ) THEN 45766 RETURN 45767 END IF 45768 IF( N.EQ.0 ) 45769 $ RETURN 45770 IF( OVER .AND. LWORK .GE. N + 2*N*NBMIN ) THEN 45771 NB = (LWORK - N) / (2*N) 45772 NB = MIN( NB, NBMAX ) 45773 CALL ZLASET( 'F', N, 1+2*NB, CZERO, CZERO, WORK, N ) 45774 ELSE 45775 NB = 1 45776 END IF 45777 UNFL = DLAMCH( 'Safe minimum' ) 45778 OVFL = ONE / UNFL 45779 CALL DLABAD( UNFL, OVFL ) 45780 ULP = DLAMCH( 'Precision' ) 45781 SMLNUM = UNFL*( N / ULP ) 45782 DO 20 I = 1, N 45783 WORK( I ) = T( I, I ) 45784 20 CONTINUE 45785 RWORK( 1 ) = ZERO 45786 DO 30 J = 2, N 45787 RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 ) 45788 30 CONTINUE 45789 IF( RIGHTV ) THEN 45790 IV = NB 45791 IS = M 45792 DO 80 KI = N, 1, -1 45793 IF( SOMEV ) THEN 45794 IF( .NOT.SELECT( KI ) ) 45795 $ GO TO 80 45796 END IF 45797 SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) 45798 WORK( KI + IV*N ) = CONE 45799 DO 40 K = 1, KI - 1 45800 WORK( K + IV*N ) = -T( K, KI ) 45801 40 CONTINUE 45802 DO 50 K = 1, KI - 1 45803 T( K, K ) = T( K, K ) - T( KI, KI ) 45804 IF( CABS1( T( K, K ) ).LT.SMIN ) 45805 $ T( K, K ) = SMIN 45806 50 CONTINUE 45807 IF( KI.GT.1 ) THEN 45808 CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y', 45809 $ KI-1, T, LDT, WORK( 1 + IV*N ), SCALE, 45810 $ RWORK, INFO ) 45811 WORK( KI + IV*N ) = SCALE 45812 END IF 45813 IF( .NOT.OVER ) THEN 45814 CALL ZCOPY( KI, WORK( 1 + IV*N ), 1, VR( 1, IS ), 1 ) 45815 II = IZAMAX( KI, VR( 1, IS ), 1 ) 45816 REMAX = ONE / CABS1( VR( II, IS ) ) 45817 CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 ) 45818 DO 60 K = KI + 1, N 45819 VR( K, IS ) = CZERO 45820 60 CONTINUE 45821 ELSE IF( NB.EQ.1 ) THEN 45822 IF( KI.GT.1 ) 45823 $ CALL ZGEMV( 'N', N, KI-1, CONE, VR, LDVR, 45824 $ WORK( 1 + IV*N ), 1, DCMPLX( SCALE ), 45825 $ VR( 1, KI ), 1 ) 45826 II = IZAMAX( N, VR( 1, KI ), 1 ) 45827 REMAX = ONE / CABS1( VR( II, KI ) ) 45828 CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 ) 45829 ELSE 45830 DO K = KI + 1, N 45831 WORK( K + IV*N ) = CZERO 45832 END DO 45833 IF( (IV.EQ.1) .OR. (KI.EQ.1) ) THEN 45834 CALL ZGEMM( 'N', 'N', N, NB-IV+1, KI+NB-IV, CONE, 45835 $ VR, LDVR, 45836 $ WORK( 1 + (IV)*N ), N, 45837 $ CZERO, 45838 $ WORK( 1 + (NB+IV)*N ), N ) 45839 DO K = IV, NB 45840 II = IZAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) 45841 REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) ) 45842 CALL ZDSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) 45843 END DO 45844 CALL ZLACPY( 'F', N, NB-IV+1, 45845 $ WORK( 1 + (NB+IV)*N ), N, 45846 $ VR( 1, KI ), LDVR ) 45847 IV = NB 45848 ELSE 45849 IV = IV - 1 45850 END IF 45851 END IF 45852 DO 70 K = 1, KI - 1 45853 T( K, K ) = WORK( K ) 45854 70 CONTINUE 45855 IS = IS - 1 45856 80 CONTINUE 45857 END IF 45858 IF( LEFTV ) THEN 45859 IV = 1 45860 IS = 1 45861 DO 130 KI = 1, N 45862 IF( SOMEV ) THEN 45863 IF( .NOT.SELECT( KI ) ) 45864 $ GO TO 130 45865 END IF 45866 SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) 45867 WORK( KI + IV*N ) = CONE 45868 DO 90 K = KI + 1, N 45869 WORK( K + IV*N ) = -CONJG( T( KI, K ) ) 45870 90 CONTINUE 45871 DO 100 K = KI + 1, N 45872 T( K, K ) = T( K, K ) - T( KI, KI ) 45873 IF( CABS1( T( K, K ) ).LT.SMIN ) 45874 $ T( K, K ) = SMIN 45875 100 CONTINUE 45876 IF( KI.LT.N ) THEN 45877 CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', 45878 $ 'Y', N-KI, T( KI+1, KI+1 ), LDT, 45879 $ WORK( KI+1 + IV*N ), SCALE, RWORK, INFO ) 45880 WORK( KI + IV*N ) = SCALE 45881 END IF 45882 IF( .NOT.OVER ) THEN 45883 CALL ZCOPY( N-KI+1, WORK( KI + IV*N ), 1, VL(KI,IS), 1 ) 45884 II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 45885 REMAX = ONE / CABS1( VL( II, IS ) ) 45886 CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) 45887 DO 110 K = 1, KI - 1 45888 VL( K, IS ) = CZERO 45889 110 CONTINUE 45890 ELSE IF( NB.EQ.1 ) THEN 45891 IF( KI.LT.N ) 45892 $ CALL ZGEMV( 'N', N, N-KI, CONE, VL( 1, KI+1 ), LDVL, 45893 $ WORK( KI+1 + IV*N ), 1, DCMPLX( SCALE ), 45894 $ VL( 1, KI ), 1 ) 45895 II = IZAMAX( N, VL( 1, KI ), 1 ) 45896 REMAX = ONE / CABS1( VL( II, KI ) ) 45897 CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 ) 45898 ELSE 45899 DO K = 1, KI - 1 45900 WORK( K + IV*N ) = CZERO 45901 END DO 45902 IF( (IV.EQ.NB) .OR. (KI.EQ.N) ) THEN 45903 CALL ZGEMM( 'N', 'N', N, IV, N-KI+IV, CONE, 45904 $ VL( 1, KI-IV+1 ), LDVL, 45905 $ WORK( KI-IV+1 + (1)*N ), N, 45906 $ CZERO, 45907 $ WORK( 1 + (NB+1)*N ), N ) 45908 DO K = 1, IV 45909 II = IZAMAX( N, WORK( 1 + (NB+K)*N ), 1 ) 45910 REMAX = ONE / CABS1( WORK( II + (NB+K)*N ) ) 45911 CALL ZDSCAL( N, REMAX, WORK( 1 + (NB+K)*N ), 1 ) 45912 END DO 45913 CALL ZLACPY( 'F', N, IV, 45914 $ WORK( 1 + (NB+1)*N ), N, 45915 $ VL( 1, KI-IV+1 ), LDVL ) 45916 IV = 1 45917 ELSE 45918 IV = IV + 1 45919 END IF 45920 END IF 45921 DO 120 K = KI + 1, N 45922 T( K, K ) = WORK( K ) 45923 120 CONTINUE 45924 IS = IS + 1 45925 130 CONTINUE 45926 END IF 45927 RETURN 45928 END 45929! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ztrexc.f 45930 SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) 45931 CHARACTER COMPQ 45932 INTEGER IFST, ILST, INFO, LDQ, LDT, N 45933 COMPLEX*16 Q( LDQ, * ), T( LDT, * ) 45934 LOGICAL WANTQ 45935 INTEGER K, M1, M2, M3 45936 DOUBLE PRECISION CS 45937 COMPLEX*16 SN, T11, T22, TEMP 45938 LOGICAL LSAME 45939 EXTERNAL LSAME 45940 EXTERNAL XERBLA, ZLARTG, ZROT 45941 INTRINSIC DCONJG, MAX 45942 INFO = 0 45943 WANTQ = LSAME( COMPQ, 'V' ) 45944 IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN 45945 INFO = -1 45946 ELSE IF( N.LT.0 ) THEN 45947 INFO = -2 45948 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN 45949 INFO = -4 45950 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN 45951 INFO = -6 45952 ELSE IF(( IFST.LT.1 .OR. IFST.GT.N ).AND.( N.GT.0 )) THEN 45953 INFO = -7 45954 ELSE IF(( ILST.LT.1 .OR. ILST.GT.N ).AND.( N.GT.0 )) THEN 45955 INFO = -8 45956 END IF 45957 IF( INFO.NE.0 ) THEN 45958 CALL XERBLA( 'ZTREXC', -INFO ) 45959 RETURN 45960 END IF 45961 IF( N.LE.1 .OR. IFST.EQ.ILST ) 45962 $ RETURN 45963 IF( IFST.LT.ILST ) THEN 45964 M1 = 0 45965 M2 = -1 45966 M3 = 1 45967 ELSE 45968 M1 = -1 45969 M2 = 0 45970 M3 = -1 45971 END IF 45972 DO 10 K = IFST + M1, ILST + M2, M3 45973 T11 = T( K, K ) 45974 T22 = T( K+1, K+1 ) 45975 CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP ) 45976 IF( K+2.LE.N ) 45977 $ CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS, 45978 $ SN ) 45979 CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, 45980 $ DCONJG( SN ) ) 45981 T( K, K ) = T22 45982 T( K+1, K+1 ) = T11 45983 IF( WANTQ ) THEN 45984 CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS, 45985 $ DCONJG( SN ) ) 45986 END IF 45987 10 CONTINUE 45988 RETURN 45989 END 45990! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ztrti2.f 45991 SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) 45992 CHARACTER DIAG, UPLO 45993 INTEGER INFO, LDA, N 45994 COMPLEX*16 A( LDA, * ) 45995 COMPLEX*16 ONE 45996 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 45997 LOGICAL NOUNIT, UPPER 45998 INTEGER J 45999 COMPLEX*16 AJJ 46000 LOGICAL LSAME 46001 EXTERNAL LSAME 46002 EXTERNAL XERBLA, ZSCAL, ZTRMV 46003 INTRINSIC MAX 46004 INFO = 0 46005 UPPER = LSAME( UPLO, 'U' ) 46006 NOUNIT = LSAME( DIAG, 'N' ) 46007 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 46008 INFO = -1 46009 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN 46010 INFO = -2 46011 ELSE IF( N.LT.0 ) THEN 46012 INFO = -3 46013 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 46014 INFO = -5 46015 END IF 46016 IF( INFO.NE.0 ) THEN 46017 CALL XERBLA( 'ZTRTI2', -INFO ) 46018 RETURN 46019 END IF 46020 IF( UPPER ) THEN 46021 DO 10 J = 1, N 46022 IF( NOUNIT ) THEN 46023 A( J, J ) = ONE / A( J, J ) 46024 AJJ = -A( J, J ) 46025 ELSE 46026 AJJ = -ONE 46027 END IF 46028 CALL ZTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, 46029 $ A( 1, J ), 1 ) 46030 CALL ZSCAL( J-1, AJJ, A( 1, J ), 1 ) 46031 10 CONTINUE 46032 ELSE 46033 DO 20 J = N, 1, -1 46034 IF( NOUNIT ) THEN 46035 A( J, J ) = ONE / A( J, J ) 46036 AJJ = -A( J, J ) 46037 ELSE 46038 AJJ = -ONE 46039 END IF 46040 IF( J.LT.N ) THEN 46041 CALL ZTRMV( 'Lower', 'No transpose', DIAG, N-J, 46042 $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) 46043 CALL ZSCAL( N-J, AJJ, A( J+1, J ), 1 ) 46044 END IF 46045 20 CONTINUE 46046 END IF 46047 RETURN 46048 END 46049! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/ztrtri.f 46050 SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO ) 46051 CHARACTER DIAG, UPLO 46052 INTEGER INFO, LDA, N 46053 COMPLEX*16 A( LDA, * ) 46054 COMPLEX*16 ONE, ZERO 46055 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), 46056 $ ZERO = ( 0.0D+0, 0.0D+0 ) ) 46057 LOGICAL NOUNIT, UPPER 46058 INTEGER J, JB, NB, NN 46059 LOGICAL LSAME 46060 INTEGER ILAENV 46061 EXTERNAL LSAME, ILAENV 46062 EXTERNAL XERBLA, ZTRMM, ZTRSM, ZTRTI2 46063 INTRINSIC MAX, MIN 46064 INFO = 0 46065 UPPER = LSAME( UPLO, 'U' ) 46066 NOUNIT = LSAME( DIAG, 'N' ) 46067 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 46068 INFO = -1 46069 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN 46070 INFO = -2 46071 ELSE IF( N.LT.0 ) THEN 46072 INFO = -3 46073 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 46074 INFO = -5 46075 END IF 46076 IF( INFO.NE.0 ) THEN 46077 CALL XERBLA( 'ZTRTRI', -INFO ) 46078 RETURN 46079 END IF 46080 IF( N.EQ.0 ) 46081 $ RETURN 46082 IF( NOUNIT ) THEN 46083 DO 10 INFO = 1, N 46084 IF( A( INFO, INFO ).EQ.ZERO ) 46085 $ RETURN 46086 10 CONTINUE 46087 INFO = 0 46088 END IF 46089 NB = ILAENV( 1, 'ZTRTRI', UPLO // DIAG, N, -1, -1, -1 ) 46090 IF( NB.LE.1 .OR. NB.GE.N ) THEN 46091 CALL ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) 46092 ELSE 46093 IF( UPPER ) THEN 46094 DO 20 J = 1, N, NB 46095 JB = MIN( NB, N-J+1 ) 46096 CALL ZTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, 46097 $ JB, ONE, A, LDA, A( 1, J ), LDA ) 46098 CALL ZTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, 46099 $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) 46100 CALL ZTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) 46101 20 CONTINUE 46102 ELSE 46103 NN = ( ( N-1 ) / NB )*NB + 1 46104 DO 30 J = NN, 1, -NB 46105 JB = MIN( NB, N-J+1 ) 46106 IF( J+JB.LE.N ) THEN 46107 CALL ZTRMM( 'Left', 'Lower', 'No transpose', DIAG, 46108 $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, 46109 $ A( J+JB, J ), LDA ) 46110 CALL ZTRSM( 'Right', 'Lower', 'No transpose', DIAG, 46111 $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, 46112 $ A( J+JB, J ), LDA ) 46113 END IF 46114 CALL ZTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) 46115 30 CONTINUE 46116 END IF 46117 END IF 46118 RETURN 46119 END 46120! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zung2l.f 46121 SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) 46122 INTEGER INFO, K, LDA, M, N 46123 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 46124 COMPLEX*16 ONE, ZERO 46125 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), 46126 $ ZERO = ( 0.0D+0, 0.0D+0 ) ) 46127 INTEGER I, II, J, L 46128 EXTERNAL XERBLA, ZLARF, ZSCAL 46129 INTRINSIC MAX 46130 INFO = 0 46131 IF( M.LT.0 ) THEN 46132 INFO = -1 46133 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN 46134 INFO = -2 46135 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN 46136 INFO = -3 46137 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 46138 INFO = -5 46139 END IF 46140 IF( INFO.NE.0 ) THEN 46141 CALL XERBLA( 'ZUNG2L', -INFO ) 46142 RETURN 46143 END IF 46144 IF( N.LE.0 ) 46145 $ RETURN 46146 DO 20 J = 1, N - K 46147 DO 10 L = 1, M 46148 A( L, J ) = ZERO 46149 10 CONTINUE 46150 A( M-N+J, J ) = ONE 46151 20 CONTINUE 46152 DO 40 I = 1, K 46153 II = N - K + I 46154 A( M-N+II, II ) = ONE 46155 CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, 46156 $ LDA, WORK ) 46157 CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) 46158 A( M-N+II, II ) = ONE - TAU( I ) 46159 DO 30 L = M - N + II + 1, M 46160 A( L, II ) = ZERO 46161 30 CONTINUE 46162 40 CONTINUE 46163 RETURN 46164 END 46165! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zung2r.f 46166 SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) 46167 INTEGER INFO, K, LDA, M, N 46168 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 46169 COMPLEX*16 ONE, ZERO 46170 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), 46171 $ ZERO = ( 0.0D+0, 0.0D+0 ) ) 46172 INTEGER I, J, L 46173 EXTERNAL XERBLA, ZLARF, ZSCAL 46174 INTRINSIC MAX 46175 INFO = 0 46176 IF( M.LT.0 ) THEN 46177 INFO = -1 46178 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN 46179 INFO = -2 46180 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN 46181 INFO = -3 46182 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 46183 INFO = -5 46184 END IF 46185 IF( INFO.NE.0 ) THEN 46186 CALL XERBLA( 'ZUNG2R', -INFO ) 46187 RETURN 46188 END IF 46189 IF( N.LE.0 ) 46190 $ RETURN 46191 DO 20 J = K + 1, N 46192 DO 10 L = 1, M 46193 A( L, J ) = ZERO 46194 10 CONTINUE 46195 A( J, J ) = ONE 46196 20 CONTINUE 46197 DO 40 I = K, 1, -1 46198 IF( I.LT.N ) THEN 46199 A( I, I ) = ONE 46200 CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), 46201 $ A( I, I+1 ), LDA, WORK ) 46202 END IF 46203 IF( I.LT.M ) 46204 $ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) 46205 A( I, I ) = ONE - TAU( I ) 46206 DO 30 L = 1, I - 1 46207 A( L, I ) = ZERO 46208 30 CONTINUE 46209 40 CONTINUE 46210 RETURN 46211 END 46212! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zunghr.f 46213 SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) 46214 INTEGER IHI, ILO, INFO, LDA, LWORK, N 46215 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 46216 COMPLEX*16 ZERO, ONE 46217 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), 46218 $ ONE = ( 1.0D+0, 0.0D+0 ) ) 46219 LOGICAL LQUERY 46220 INTEGER I, IINFO, J, LWKOPT, NB, NH 46221 EXTERNAL XERBLA, ZUNGQR 46222 INTEGER ILAENV 46223 EXTERNAL ILAENV 46224 INTRINSIC MAX, MIN 46225 INFO = 0 46226 NH = IHI - ILO 46227 LQUERY = ( LWORK.EQ.-1 ) 46228 IF( N.LT.0 ) THEN 46229 INFO = -1 46230 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN 46231 INFO = -2 46232 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN 46233 INFO = -3 46234 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 46235 INFO = -5 46236 ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN 46237 INFO = -8 46238 END IF 46239 IF( INFO.EQ.0 ) THEN 46240 NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 ) 46241 LWKOPT = MAX( 1, NH )*NB 46242 WORK( 1 ) = LWKOPT 46243 END IF 46244 IF( INFO.NE.0 ) THEN 46245 CALL XERBLA( 'ZUNGHR', -INFO ) 46246 RETURN 46247 ELSE IF( LQUERY ) THEN 46248 RETURN 46249 END IF 46250 IF( N.EQ.0 ) THEN 46251 WORK( 1 ) = 1 46252 RETURN 46253 END IF 46254 DO 40 J = IHI, ILO + 1, -1 46255 DO 10 I = 1, J - 1 46256 A( I, J ) = ZERO 46257 10 CONTINUE 46258 DO 20 I = J + 1, IHI 46259 A( I, J ) = A( I, J-1 ) 46260 20 CONTINUE 46261 DO 30 I = IHI + 1, N 46262 A( I, J ) = ZERO 46263 30 CONTINUE 46264 40 CONTINUE 46265 DO 60 J = 1, ILO 46266 DO 50 I = 1, N 46267 A( I, J ) = ZERO 46268 50 CONTINUE 46269 A( J, J ) = ONE 46270 60 CONTINUE 46271 DO 80 J = IHI + 1, N 46272 DO 70 I = 1, N 46273 A( I, J ) = ZERO 46274 70 CONTINUE 46275 A( J, J ) = ONE 46276 80 CONTINUE 46277 IF( NH.GT.0 ) THEN 46278 CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), 46279 $ WORK, LWORK, IINFO ) 46280 END IF 46281 WORK( 1 ) = LWKOPT 46282 RETURN 46283 END 46284! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zungql.f 46285 SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) 46286 INTEGER INFO, K, LDA, LWORK, M, N 46287 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 46288 COMPLEX*16 ZERO 46289 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 46290 LOGICAL LQUERY 46291 INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, 46292 $ NB, NBMIN, NX 46293 EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2L 46294 INTRINSIC MAX, MIN 46295 INTEGER ILAENV 46296 EXTERNAL ILAENV 46297 INFO = 0 46298 LQUERY = ( LWORK.EQ.-1 ) 46299 IF( M.LT.0 ) THEN 46300 INFO = -1 46301 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN 46302 INFO = -2 46303 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN 46304 INFO = -3 46305 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 46306 INFO = -5 46307 END IF 46308 IF( INFO.EQ.0 ) THEN 46309 IF( N.EQ.0 ) THEN 46310 LWKOPT = 1 46311 ELSE 46312 NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) 46313 LWKOPT = N*NB 46314 END IF 46315 WORK( 1 ) = LWKOPT 46316 IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 46317 INFO = -8 46318 END IF 46319 END IF 46320 IF( INFO.NE.0 ) THEN 46321 CALL XERBLA( 'ZUNGQL', -INFO ) 46322 RETURN 46323 ELSE IF( LQUERY ) THEN 46324 RETURN 46325 END IF 46326 IF( N.LE.0 ) THEN 46327 RETURN 46328 END IF 46329 NBMIN = 2 46330 NX = 0 46331 IWS = N 46332 IF( NB.GT.1 .AND. NB.LT.K ) THEN 46333 NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) ) 46334 IF( NX.LT.K ) THEN 46335 LDWORK = N 46336 IWS = LDWORK*NB 46337 IF( LWORK.LT.IWS ) THEN 46338 NB = LWORK / LDWORK 46339 NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) ) 46340 END IF 46341 END IF 46342 END IF 46343 IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN 46344 KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) 46345 DO 20 J = 1, N - KK 46346 DO 10 I = M - KK + 1, M 46347 A( I, J ) = ZERO 46348 10 CONTINUE 46349 20 CONTINUE 46350 ELSE 46351 KK = 0 46352 END IF 46353 CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) 46354 IF( KK.GT.0 ) THEN 46355 DO 50 I = K - KK + 1, K, NB 46356 IB = MIN( NB, K-I+1 ) 46357 IF( N-K+I.GT.1 ) THEN 46358 CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, 46359 $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) 46360 CALL ZLARFB( 'Left', 'No transpose', 'Backward', 46361 $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, 46362 $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, 46363 $ WORK( IB+1 ), LDWORK ) 46364 END IF 46365 CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, 46366 $ TAU( I ), WORK, IINFO ) 46367 DO 40 J = N - K + I, N - K + I + IB - 1 46368 DO 30 L = M - K + I + IB, M 46369 A( L, J ) = ZERO 46370 30 CONTINUE 46371 40 CONTINUE 46372 50 CONTINUE 46373 END IF 46374 WORK( 1 ) = IWS 46375 RETURN 46376 END 46377! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zungqr.f 46378 SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) 46379 INTEGER INFO, K, LDA, LWORK, M, N 46380 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 46381 COMPLEX*16 ZERO 46382 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) 46383 LOGICAL LQUERY 46384 INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, 46385 $ LWKOPT, NB, NBMIN, NX 46386 EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R 46387 INTRINSIC MAX, MIN 46388 INTEGER ILAENV 46389 EXTERNAL ILAENV 46390 INFO = 0 46391 NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) 46392 LWKOPT = MAX( 1, N )*NB 46393 WORK( 1 ) = LWKOPT 46394 LQUERY = ( LWORK.EQ.-1 ) 46395 IF( M.LT.0 ) THEN 46396 INFO = -1 46397 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN 46398 INFO = -2 46399 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN 46400 INFO = -3 46401 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN 46402 INFO = -5 46403 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 46404 INFO = -8 46405 END IF 46406 IF( INFO.NE.0 ) THEN 46407 CALL XERBLA( 'ZUNGQR', -INFO ) 46408 RETURN 46409 ELSE IF( LQUERY ) THEN 46410 RETURN 46411 END IF 46412 IF( N.LE.0 ) THEN 46413 WORK( 1 ) = 1 46414 RETURN 46415 END IF 46416 NBMIN = 2 46417 NX = 0 46418 IWS = N 46419 IF( NB.GT.1 .AND. NB.LT.K ) THEN 46420 NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) ) 46421 IF( NX.LT.K ) THEN 46422 LDWORK = N 46423 IWS = LDWORK*NB 46424 IF( LWORK.LT.IWS ) THEN 46425 NB = LWORK / LDWORK 46426 NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) ) 46427 END IF 46428 END IF 46429 END IF 46430 IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN 46431 KI = ( ( K-NX-1 ) / NB )*NB 46432 KK = MIN( K, KI+NB ) 46433 DO 20 J = KK + 1, N 46434 DO 10 I = 1, KK 46435 A( I, J ) = ZERO 46436 10 CONTINUE 46437 20 CONTINUE 46438 ELSE 46439 KK = 0 46440 END IF 46441 IF( KK.LT.N ) 46442 $ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, 46443 $ TAU( KK+1 ), WORK, IINFO ) 46444 IF( KK.GT.0 ) THEN 46445 DO 50 I = KI + 1, 1, -NB 46446 IB = MIN( NB, K-I+1 ) 46447 IF( I+IB.LE.N ) THEN 46448 CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, 46449 $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) 46450 CALL ZLARFB( 'Left', 'No transpose', 'Forward', 46451 $ 'Columnwise', M-I+1, N-I-IB+1, IB, 46452 $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), 46453 $ LDA, WORK( IB+1 ), LDWORK ) 46454 END IF 46455 CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, 46456 $ IINFO ) 46457 DO 40 J = I, I + IB - 1 46458 DO 30 L = 1, I - 1 46459 A( L, J ) = ZERO 46460 30 CONTINUE 46461 40 CONTINUE 46462 50 CONTINUE 46463 END IF 46464 WORK( 1 ) = IWS 46465 RETURN 46466 END 46467! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zungtr.f 46468 SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) 46469 CHARACTER UPLO 46470 INTEGER INFO, LDA, LWORK, N 46471 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) 46472 COMPLEX*16 ZERO, ONE 46473 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), 46474 $ ONE = ( 1.0D+0, 0.0D+0 ) ) 46475 LOGICAL LQUERY, UPPER 46476 INTEGER I, IINFO, J, LWKOPT, NB 46477 LOGICAL LSAME 46478 INTEGER ILAENV 46479 EXTERNAL LSAME, ILAENV 46480 EXTERNAL XERBLA, ZUNGQL, ZUNGQR 46481 INTRINSIC MAX 46482 INFO = 0 46483 LQUERY = ( LWORK.EQ.-1 ) 46484 UPPER = LSAME( UPLO, 'U' ) 46485 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 46486 INFO = -1 46487 ELSE IF( N.LT.0 ) THEN 46488 INFO = -2 46489 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 46490 INFO = -4 46491 ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN 46492 INFO = -7 46493 END IF 46494 IF( INFO.EQ.0 ) THEN 46495 IF( UPPER ) THEN 46496 NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 ) 46497 ELSE 46498 NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 ) 46499 END IF 46500 LWKOPT = MAX( 1, N-1 )*NB 46501 WORK( 1 ) = LWKOPT 46502 END IF 46503 IF( INFO.NE.0 ) THEN 46504 CALL XERBLA( 'ZUNGTR', -INFO ) 46505 RETURN 46506 ELSE IF( LQUERY ) THEN 46507 RETURN 46508 END IF 46509 IF( N.EQ.0 ) THEN 46510 WORK( 1 ) = 1 46511 RETURN 46512 END IF 46513 IF( UPPER ) THEN 46514 DO 20 J = 1, N - 1 46515 DO 10 I = 1, J - 1 46516 A( I, J ) = A( I, J+1 ) 46517 10 CONTINUE 46518 A( N, J ) = ZERO 46519 20 CONTINUE 46520 DO 30 I = 1, N - 1 46521 A( I, N ) = ZERO 46522 30 CONTINUE 46523 A( N, N ) = ONE 46524 CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) 46525 ELSE 46526 DO 50 J = N, 2, -1 46527 A( 1, J ) = ZERO 46528 DO 40 I = J + 1, N 46529 A( I, J ) = A( I, J-1 ) 46530 40 CONTINUE 46531 50 CONTINUE 46532 A( 1, 1 ) = ONE 46533 DO 60 I = 2, N 46534 A( I, 1 ) = ZERO 46535 60 CONTINUE 46536 IF( N.GT.1 ) THEN 46537 CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, 46538 $ LWORK, IINFO ) 46539 END IF 46540 END IF 46541 WORK( 1 ) = LWKOPT 46542 RETURN 46543 END 46544! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zunm2l.f 46545 SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, 46546 $ WORK, INFO ) 46547 CHARACTER SIDE, TRANS 46548 INTEGER INFO, K, LDA, LDC, M, N 46549 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 46550 COMPLEX*16 ONE 46551 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 46552 LOGICAL LEFT, NOTRAN 46553 INTEGER I, I1, I2, I3, MI, NI, NQ 46554 COMPLEX*16 AII, TAUI 46555 LOGICAL LSAME 46556 EXTERNAL LSAME 46557 EXTERNAL XERBLA, ZLARF 46558 INTRINSIC DCONJG, MAX 46559 INFO = 0 46560 LEFT = LSAME( SIDE, 'L' ) 46561 NOTRAN = LSAME( TRANS, 'N' ) 46562 IF( LEFT ) THEN 46563 NQ = M 46564 ELSE 46565 NQ = N 46566 END IF 46567 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 46568 INFO = -1 46569 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN 46570 INFO = -2 46571 ELSE IF( M.LT.0 ) THEN 46572 INFO = -3 46573 ELSE IF( N.LT.0 ) THEN 46574 INFO = -4 46575 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN 46576 INFO = -5 46577 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 46578 INFO = -7 46579 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 46580 INFO = -10 46581 END IF 46582 IF( INFO.NE.0 ) THEN 46583 CALL XERBLA( 'ZUNM2L', -INFO ) 46584 RETURN 46585 END IF 46586 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) 46587 $ RETURN 46588 IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN 46589 I1 = 1 46590 I2 = K 46591 I3 = 1 46592 ELSE 46593 I1 = K 46594 I2 = 1 46595 I3 = -1 46596 END IF 46597 IF( LEFT ) THEN 46598 NI = N 46599 ELSE 46600 MI = M 46601 END IF 46602 DO 10 I = I1, I2, I3 46603 IF( LEFT ) THEN 46604 MI = M - K + I 46605 ELSE 46606 NI = N - K + I 46607 END IF 46608 IF( NOTRAN ) THEN 46609 TAUI = TAU( I ) 46610 ELSE 46611 TAUI = DCONJG( TAU( I ) ) 46612 END IF 46613 AII = A( NQ-K+I, I ) 46614 A( NQ-K+I, I ) = ONE 46615 CALL ZLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK ) 46616 A( NQ-K+I, I ) = AII 46617 10 CONTINUE 46618 RETURN 46619 END 46620! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zunm2r.f 46621 SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, 46622 $ WORK, INFO ) 46623 CHARACTER SIDE, TRANS 46624 INTEGER INFO, K, LDA, LDC, M, N 46625 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 46626 COMPLEX*16 ONE 46627 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 46628 LOGICAL LEFT, NOTRAN 46629 INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ 46630 COMPLEX*16 AII, TAUI 46631 LOGICAL LSAME 46632 EXTERNAL LSAME 46633 EXTERNAL XERBLA, ZLARF 46634 INTRINSIC DCONJG, MAX 46635 INFO = 0 46636 LEFT = LSAME( SIDE, 'L' ) 46637 NOTRAN = LSAME( TRANS, 'N' ) 46638 IF( LEFT ) THEN 46639 NQ = M 46640 ELSE 46641 NQ = N 46642 END IF 46643 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 46644 INFO = -1 46645 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN 46646 INFO = -2 46647 ELSE IF( M.LT.0 ) THEN 46648 INFO = -3 46649 ELSE IF( N.LT.0 ) THEN 46650 INFO = -4 46651 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN 46652 INFO = -5 46653 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 46654 INFO = -7 46655 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 46656 INFO = -10 46657 END IF 46658 IF( INFO.NE.0 ) THEN 46659 CALL XERBLA( 'ZUNM2R', -INFO ) 46660 RETURN 46661 END IF 46662 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) 46663 $ RETURN 46664 IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN 46665 I1 = 1 46666 I2 = K 46667 I3 = 1 46668 ELSE 46669 I1 = K 46670 I2 = 1 46671 I3 = -1 46672 END IF 46673 IF( LEFT ) THEN 46674 NI = N 46675 JC = 1 46676 ELSE 46677 MI = M 46678 IC = 1 46679 END IF 46680 DO 10 I = I1, I2, I3 46681 IF( LEFT ) THEN 46682 MI = M - I + 1 46683 IC = I 46684 ELSE 46685 NI = N - I + 1 46686 JC = I 46687 END IF 46688 IF( NOTRAN ) THEN 46689 TAUI = TAU( I ) 46690 ELSE 46691 TAUI = DCONJG( TAU( I ) ) 46692 END IF 46693 AII = A( I, I ) 46694 A( I, I ) = ONE 46695 CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, 46696 $ WORK ) 46697 A( I, I ) = AII 46698 10 CONTINUE 46699 RETURN 46700 END 46701! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zunmhr.f 46702 SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, 46703 $ LDC, WORK, LWORK, INFO ) 46704 CHARACTER SIDE, TRANS 46705 INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N 46706 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 46707 LOGICAL LEFT, LQUERY 46708 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW 46709 LOGICAL LSAME 46710 INTEGER ILAENV 46711 EXTERNAL LSAME, ILAENV 46712 EXTERNAL XERBLA, ZUNMQR 46713 INTRINSIC MAX, MIN 46714 INFO = 0 46715 NH = IHI - ILO 46716 LEFT = LSAME( SIDE, 'L' ) 46717 LQUERY = ( LWORK.EQ.-1 ) 46718 IF( LEFT ) THEN 46719 NQ = M 46720 NW = N 46721 ELSE 46722 NQ = N 46723 NW = M 46724 END IF 46725 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 46726 INFO = -1 46727 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) 46728 $ THEN 46729 INFO = -2 46730 ELSE IF( M.LT.0 ) THEN 46731 INFO = -3 46732 ELSE IF( N.LT.0 ) THEN 46733 INFO = -4 46734 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN 46735 INFO = -5 46736 ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN 46737 INFO = -6 46738 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 46739 INFO = -8 46740 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 46741 INFO = -11 46742 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN 46743 INFO = -13 46744 END IF 46745 IF( INFO.EQ.0 ) THEN 46746 IF( LEFT ) THEN 46747 NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, NH, N, NH, -1 ) 46748 ELSE 46749 NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, NH, NH, -1 ) 46750 END IF 46751 LWKOPT = MAX( 1, NW )*NB 46752 WORK( 1 ) = LWKOPT 46753 END IF 46754 IF( INFO.NE.0 ) THEN 46755 CALL XERBLA( 'ZUNMHR', -INFO ) 46756 RETURN 46757 ELSE IF( LQUERY ) THEN 46758 RETURN 46759 END IF 46760 IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN 46761 WORK( 1 ) = 1 46762 RETURN 46763 END IF 46764 IF( LEFT ) THEN 46765 MI = NH 46766 NI = N 46767 I1 = ILO + 1 46768 I2 = 1 46769 ELSE 46770 MI = M 46771 NI = NH 46772 I1 = 1 46773 I2 = ILO + 1 46774 END IF 46775 CALL ZUNMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, 46776 $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) 46777 WORK( 1 ) = LWKOPT 46778 RETURN 46779 END 46780! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zunmql.f 46781 SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, 46782 $ WORK, LWORK, INFO ) 46783 CHARACTER SIDE, TRANS 46784 INTEGER INFO, K, LDA, LDC, LWORK, M, N 46785 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 46786 INTEGER NBMAX, LDT, TSIZE 46787 PARAMETER ( NBMAX = 64, LDT = NBMAX+1, 46788 $ TSIZE = LDT*NBMAX ) 46789 LOGICAL LEFT, LQUERY, NOTRAN 46790 INTEGER I, I1, I2, I3, IB, IINFO, IWT, LDWORK, LWKOPT, 46791 $ MI, NB, NBMIN, NI, NQ, NW 46792 LOGICAL LSAME 46793 INTEGER ILAENV 46794 EXTERNAL LSAME, ILAENV 46795 EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2L 46796 INTRINSIC MAX, MIN 46797 INFO = 0 46798 LEFT = LSAME( SIDE, 'L' ) 46799 NOTRAN = LSAME( TRANS, 'N' ) 46800 LQUERY = ( LWORK.EQ.-1 ) 46801 IF( LEFT ) THEN 46802 NQ = M 46803 NW = MAX( 1, N ) 46804 ELSE 46805 NQ = N 46806 NW = MAX( 1, M ) 46807 END IF 46808 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 46809 INFO = -1 46810 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN 46811 INFO = -2 46812 ELSE IF( M.LT.0 ) THEN 46813 INFO = -3 46814 ELSE IF( N.LT.0 ) THEN 46815 INFO = -4 46816 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN 46817 INFO = -5 46818 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 46819 INFO = -7 46820 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 46821 INFO = -10 46822 ELSE IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN 46823 INFO = -12 46824 END IF 46825 IF( INFO.EQ.0 ) THEN 46826 IF( M.EQ.0 .OR. N.EQ.0 ) THEN 46827 LWKOPT = 1 46828 ELSE 46829 NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N, 46830 $ K, -1 ) ) 46831 LWKOPT = NW*NB + TSIZE 46832 END IF 46833 WORK( 1 ) = LWKOPT 46834 END IF 46835 IF( INFO.NE.0 ) THEN 46836 CALL XERBLA( 'ZUNMQL', -INFO ) 46837 RETURN 46838 ELSE IF( LQUERY ) THEN 46839 RETURN 46840 END IF 46841 IF( M.EQ.0 .OR. N.EQ.0 ) THEN 46842 RETURN 46843 END IF 46844 NBMIN = 2 46845 LDWORK = NW 46846 IF( NB.GT.1 .AND. NB.LT.K ) THEN 46847 IF( LWORK.LT.NW*NB+TSIZE ) THEN 46848 NB = (LWORK-TSIZE) / LDWORK 46849 NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQL', SIDE // TRANS, M, N, K, 46850 $ -1 ) ) 46851 END IF 46852 END IF 46853 IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN 46854 CALL ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, 46855 $ IINFO ) 46856 ELSE 46857 IWT = 1 + NW*NB 46858 IF( ( LEFT .AND. NOTRAN ) .OR. 46859 $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN 46860 I1 = 1 46861 I2 = K 46862 I3 = NB 46863 ELSE 46864 I1 = ( ( K-1 ) / NB )*NB + 1 46865 I2 = 1 46866 I3 = -NB 46867 END IF 46868 IF( LEFT ) THEN 46869 NI = N 46870 ELSE 46871 MI = M 46872 END IF 46873 DO 10 I = I1, I2, I3 46874 IB = MIN( NB, K-I+1 ) 46875 CALL ZLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, 46876 $ A( 1, I ), LDA, TAU( I ), WORK( IWT ), LDT ) 46877 IF( LEFT ) THEN 46878 MI = M - K + I + IB - 1 46879 ELSE 46880 NI = N - K + I + IB - 1 46881 END IF 46882 CALL ZLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, 46883 $ IB, A( 1, I ), LDA, WORK( IWT ), LDT, C, LDC, 46884 $ WORK, LDWORK ) 46885 10 CONTINUE 46886 END IF 46887 WORK( 1 ) = LWKOPT 46888 RETURN 46889 END 46890! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zunmqr.f 46891 SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, 46892 $ WORK, LWORK, INFO ) 46893 CHARACTER SIDE, TRANS 46894 INTEGER INFO, K, LDA, LDC, LWORK, M, N 46895 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 46896 INTEGER NBMAX, LDT, TSIZE 46897 PARAMETER ( NBMAX = 64, LDT = NBMAX+1, 46898 $ TSIZE = LDT*NBMAX ) 46899 LOGICAL LEFT, LQUERY, NOTRAN 46900 INTEGER I, I1, I2, I3, IB, IC, IINFO, IWT, JC, LDWORK, 46901 $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW 46902 LOGICAL LSAME 46903 INTEGER ILAENV 46904 EXTERNAL LSAME, ILAENV 46905 EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R 46906 INTRINSIC MAX, MIN 46907 INFO = 0 46908 LEFT = LSAME( SIDE, 'L' ) 46909 NOTRAN = LSAME( TRANS, 'N' ) 46910 LQUERY = ( LWORK.EQ.-1 ) 46911 IF( LEFT ) THEN 46912 NQ = M 46913 NW = N 46914 ELSE 46915 NQ = N 46916 NW = M 46917 END IF 46918 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 46919 INFO = -1 46920 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN 46921 INFO = -2 46922 ELSE IF( M.LT.0 ) THEN 46923 INFO = -3 46924 ELSE IF( N.LT.0 ) THEN 46925 INFO = -4 46926 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN 46927 INFO = -5 46928 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 46929 INFO = -7 46930 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 46931 INFO = -10 46932 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN 46933 INFO = -12 46934 END IF 46935 IF( INFO.EQ.0 ) THEN 46936 NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K, 46937 $ -1 ) ) 46938 LWKOPT = MAX( 1, NW )*NB + TSIZE 46939 WORK( 1 ) = LWKOPT 46940 END IF 46941 IF( INFO.NE.0 ) THEN 46942 CALL XERBLA( 'ZUNMQR', -INFO ) 46943 RETURN 46944 ELSE IF( LQUERY ) THEN 46945 RETURN 46946 END IF 46947 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN 46948 WORK( 1 ) = 1 46949 RETURN 46950 END IF 46951 NBMIN = 2 46952 LDWORK = NW 46953 IF( NB.GT.1 .AND. NB.LT.K ) THEN 46954 IF( LWORK.LT.NW*NB+TSIZE ) THEN 46955 NB = (LWORK-TSIZE) / LDWORK 46956 NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K, 46957 $ -1 ) ) 46958 END IF 46959 END IF 46960 IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN 46961 CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, 46962 $ IINFO ) 46963 ELSE 46964 IWT = 1 + NW*NB 46965 IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. 46966 $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN 46967 I1 = 1 46968 I2 = K 46969 I3 = NB 46970 ELSE 46971 I1 = ( ( K-1 ) / NB )*NB + 1 46972 I2 = 1 46973 I3 = -NB 46974 END IF 46975 IF( LEFT ) THEN 46976 NI = N 46977 JC = 1 46978 ELSE 46979 MI = M 46980 IC = 1 46981 END IF 46982 DO 10 I = I1, I2, I3 46983 IB = MIN( NB, K-I+1 ) 46984 CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), 46985 $ LDA, TAU( I ), WORK( IWT ), LDT ) 46986 IF( LEFT ) THEN 46987 MI = M - I + 1 46988 IC = I 46989 ELSE 46990 NI = N - I + 1 46991 JC = I 46992 END IF 46993 CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, 46994 $ IB, A( I, I ), LDA, WORK( IWT ), LDT, 46995 $ C( IC, JC ), LDC, WORK, LDWORK ) 46996 10 CONTINUE 46997 END IF 46998 WORK( 1 ) = LWKOPT 46999 RETURN 47000 END 47001! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zunmtr.f 47002 SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, 47003 $ WORK, LWORK, INFO ) 47004 CHARACTER SIDE, TRANS, UPLO 47005 INTEGER INFO, LDA, LDC, LWORK, M, N 47006 COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 47007 LOGICAL LEFT, LQUERY, UPPER 47008 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW 47009 LOGICAL LSAME 47010 INTEGER ILAENV 47011 EXTERNAL LSAME, ILAENV 47012 EXTERNAL XERBLA, ZUNMQL, ZUNMQR 47013 INTRINSIC MAX 47014 INFO = 0 47015 LEFT = LSAME( SIDE, 'L' ) 47016 UPPER = LSAME( UPLO, 'U' ) 47017 LQUERY = ( LWORK.EQ.-1 ) 47018 IF( LEFT ) THEN 47019 NQ = M 47020 NW = N 47021 ELSE 47022 NQ = N 47023 NW = M 47024 END IF 47025 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 47026 INFO = -1 47027 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 47028 INFO = -2 47029 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) 47030 $ THEN 47031 INFO = -3 47032 ELSE IF( M.LT.0 ) THEN 47033 INFO = -4 47034 ELSE IF( N.LT.0 ) THEN 47035 INFO = -5 47036 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 47037 INFO = -7 47038 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 47039 INFO = -10 47040 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN 47041 INFO = -12 47042 END IF 47043 IF( INFO.EQ.0 ) THEN 47044 IF( UPPER ) THEN 47045 IF( LEFT ) THEN 47046 NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M-1, N, M-1, 47047 $ -1 ) 47048 ELSE 47049 NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N-1, N-1, 47050 $ -1 ) 47051 END IF 47052 ELSE 47053 IF( LEFT ) THEN 47054 NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, 47055 $ -1 ) 47056 ELSE 47057 NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, 47058 $ -1 ) 47059 END IF 47060 END IF 47061 LWKOPT = MAX( 1, NW )*NB 47062 WORK( 1 ) = LWKOPT 47063 END IF 47064 IF( INFO.NE.0 ) THEN 47065 CALL XERBLA( 'ZUNMTR', -INFO ) 47066 RETURN 47067 ELSE IF( LQUERY ) THEN 47068 RETURN 47069 END IF 47070 IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN 47071 WORK( 1 ) = 1 47072 RETURN 47073 END IF 47074 IF( LEFT ) THEN 47075 MI = M - 1 47076 NI = N 47077 ELSE 47078 MI = M 47079 NI = N - 1 47080 END IF 47081 IF( UPPER ) THEN 47082 CALL ZUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, 47083 $ LDC, WORK, LWORK, IINFO ) 47084 ELSE 47085 IF( LEFT ) THEN 47086 I1 = 2 47087 I2 = 1 47088 ELSE 47089 I1 = 1 47090 I2 = 2 47091 END IF 47092 CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, 47093 $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) 47094 END IF 47095 WORK( 1 ) = LWKOPT 47096 RETURN 47097 END 47098! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zupgtr.f 47099 SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) 47100 CHARACTER UPLO 47101 INTEGER INFO, LDQ, N 47102 COMPLEX*16 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) 47103 COMPLEX*16 CZERO, CONE 47104 PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), 47105 $ CONE = ( 1.0D+0, 0.0D+0 ) ) 47106 LOGICAL UPPER 47107 INTEGER I, IINFO, IJ, J 47108 LOGICAL LSAME 47109 EXTERNAL LSAME 47110 EXTERNAL XERBLA, ZUNG2L, ZUNG2R 47111 INTRINSIC MAX 47112 INFO = 0 47113 UPPER = LSAME( UPLO, 'U' ) 47114 IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 47115 INFO = -1 47116 ELSE IF( N.LT.0 ) THEN 47117 INFO = -2 47118 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN 47119 INFO = -6 47120 END IF 47121 IF( INFO.NE.0 ) THEN 47122 CALL XERBLA( 'ZUPGTR', -INFO ) 47123 RETURN 47124 END IF 47125 IF( N.EQ.0 ) 47126 $ RETURN 47127 IF( UPPER ) THEN 47128 IJ = 2 47129 DO 20 J = 1, N - 1 47130 DO 10 I = 1, J - 1 47131 Q( I, J ) = AP( IJ ) 47132 IJ = IJ + 1 47133 10 CONTINUE 47134 IJ = IJ + 2 47135 Q( N, J ) = CZERO 47136 20 CONTINUE 47137 DO 30 I = 1, N - 1 47138 Q( I, N ) = CZERO 47139 30 CONTINUE 47140 Q( N, N ) = CONE 47141 CALL ZUNG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO ) 47142 ELSE 47143 Q( 1, 1 ) = CONE 47144 DO 40 I = 2, N 47145 Q( I, 1 ) = CZERO 47146 40 CONTINUE 47147 IJ = 3 47148 DO 60 J = 2, N 47149 Q( 1, J ) = CZERO 47150 DO 50 I = J + 1, N 47151 Q( I, J ) = AP( IJ ) 47152 IJ = IJ + 1 47153 50 CONTINUE 47154 IJ = IJ + 2 47155 60 CONTINUE 47156 IF( N.GT.1 ) THEN 47157 CALL ZUNG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, 47158 $ IINFO ) 47159 END IF 47160 END IF 47161 RETURN 47162 END 47163! SOURCE-FILE = /home/nicpa/LA/lapack/SRC/zupmtr.f 47164 SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, 47165 $ INFO ) 47166 CHARACTER SIDE, TRANS, UPLO 47167 INTEGER INFO, LDC, M, N 47168 COMPLEX*16 AP( * ), C( LDC, * ), TAU( * ), WORK( * ) 47169 COMPLEX*16 ONE 47170 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) 47171 LOGICAL FORWRD, LEFT, NOTRAN, UPPER 47172 INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ 47173 COMPLEX*16 AII, TAUI 47174 LOGICAL LSAME 47175 EXTERNAL LSAME 47176 EXTERNAL XERBLA, ZLARF 47177 INTRINSIC DCONJG, MAX 47178 INFO = 0 47179 LEFT = LSAME( SIDE, 'L' ) 47180 NOTRAN = LSAME( TRANS, 'N' ) 47181 UPPER = LSAME( UPLO, 'U' ) 47182 IF( LEFT ) THEN 47183 NQ = M 47184 ELSE 47185 NQ = N 47186 END IF 47187 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 47188 INFO = -1 47189 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 47190 INFO = -2 47191 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN 47192 INFO = -3 47193 ELSE IF( M.LT.0 ) THEN 47194 INFO = -4 47195 ELSE IF( N.LT.0 ) THEN 47196 INFO = -5 47197 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 47198 INFO = -9 47199 END IF 47200 IF( INFO.NE.0 ) THEN 47201 CALL XERBLA( 'ZUPMTR', -INFO ) 47202 RETURN 47203 END IF 47204 IF( M.EQ.0 .OR. N.EQ.0 ) 47205 $ RETURN 47206 IF( UPPER ) THEN 47207 FORWRD = ( LEFT .AND. NOTRAN ) .OR. 47208 $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) 47209 IF( FORWRD ) THEN 47210 I1 = 1 47211 I2 = NQ - 1 47212 I3 = 1 47213 II = 2 47214 ELSE 47215 I1 = NQ - 1 47216 I2 = 1 47217 I3 = -1 47218 II = NQ*( NQ+1 ) / 2 - 1 47219 END IF 47220 IF( LEFT ) THEN 47221 NI = N 47222 ELSE 47223 MI = M 47224 END IF 47225 DO 10 I = I1, I2, I3 47226 IF( LEFT ) THEN 47227 MI = I 47228 ELSE 47229 NI = I 47230 END IF 47231 IF( NOTRAN ) THEN 47232 TAUI = TAU( I ) 47233 ELSE 47234 TAUI = DCONJG( TAU( I ) ) 47235 END IF 47236 AII = AP( II ) 47237 AP( II ) = ONE 47238 CALL ZLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, LDC, 47239 $ WORK ) 47240 AP( II ) = AII 47241 IF( FORWRD ) THEN 47242 II = II + I + 2 47243 ELSE 47244 II = II - I - 1 47245 END IF 47246 10 CONTINUE 47247 ELSE 47248 FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR. 47249 $ ( .NOT.LEFT .AND. NOTRAN ) 47250 IF( FORWRD ) THEN 47251 I1 = 1 47252 I2 = NQ - 1 47253 I3 = 1 47254 II = 2 47255 ELSE 47256 I1 = NQ - 1 47257 I2 = 1 47258 I3 = -1 47259 II = NQ*( NQ+1 ) / 2 - 1 47260 END IF 47261 IF( LEFT ) THEN 47262 NI = N 47263 JC = 1 47264 ELSE 47265 MI = M 47266 IC = 1 47267 END IF 47268 DO 20 I = I1, I2, I3 47269 AII = AP( II ) 47270 AP( II ) = ONE 47271 IF( LEFT ) THEN 47272 MI = M - I 47273 IC = I + 1 47274 ELSE 47275 NI = N - I 47276 JC = I + 1 47277 END IF 47278 IF( NOTRAN ) THEN 47279 TAUI = TAU( I ) 47280 ELSE 47281 TAUI = DCONJG( TAU( I ) ) 47282 END IF 47283 CALL ZLARF( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, JC ), 47284 $ LDC, WORK ) 47285 AP( II ) = AII 47286 IF( FORWRD ) THEN 47287 II = II + NQ - I + 1 47288 ELSE 47289 II = II - NQ + I - 2 47290 END IF 47291 20 CONTINUE 47292 END IF 47293 RETURN 47294 END 47295