SRC/clahef.f

   1 *> \brief \b CLAHEF computes a partial factorization of a complex Hermitian indefinite matrix using the Bunch-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS).
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download CLAHEF + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clahef.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clahef.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clahef.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
  22 *
  23 *       .. Scalar Arguments ..
  24 *       CHARACTER          UPLO
  25 *       INTEGER            INFO, KB, LDA, LDW, N, NB
  26 *       ..
  27 *       .. Array Arguments ..
  28 *       INTEGER            IPIV( * )
  29 *       COMPLEX            A( LDA, * ), W( LDW, * )
  30 *       ..
  31 *
  32 *
  33 *> \par Purpose:
  34 *  =============
  35 *>
  36 *> \verbatim
  37 *>
  38 *> CLAHEF computes a partial factorization of a complex Hermitian
  39 *> matrix A using the Bunch-Kaufman diagonal pivoting method. The
  40 *> partial factorization has the form:
  41 *>
  42 *> A  =  ( I  U12 ) ( A11  0  ) (  I      0     )  if UPLO = 'U', or:
  43 *>       ( 0  U22 ) (  0   D  ) ( U12**H U22**H )
  44 *>
  45 *> A  =  ( L11  0 ) (  D   0  ) ( L11**H L21**H )  if UPLO = 'L'
  46 *>       ( L21  I ) (  0  A22 ) (  0      I     )
  47 *>
  48 *> where the order of D is at most NB. The actual order is returned in
  49 *> the argument KB, and is either NB or NB-1, or N if N <= NB.
  50 *> Note that U**H denotes the conjugate transpose of U.
  51 *>
  52 *> CLAHEF is an auxiliary routine called by CHETRF. It uses blocked code
  53 *> (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
  54 *> A22 (if UPLO = 'L').
  55 *> \endverbatim
  56 *
  57 *  Arguments:
  58 *  ==========
  59 *
  60 *> \param[in] UPLO
  61 *> \verbatim
  62 *>          UPLO is CHARACTER*1
  63 *>          Specifies whether the upper or lower triangular part of the
  64 *>          Hermitian matrix A is stored:
  65 *>          = 'U':  Upper triangular
  66 *>          = 'L':  Lower triangular
  67 *> \endverbatim
  68 *>
  69 *> \param[in] N
  70 *> \verbatim
  71 *>          N is INTEGER
  72 *>          The order of the matrix A.  N >= 0.
  73 *> \endverbatim
  74 *>
  75 *> \param[in] NB
  76 *> \verbatim
  77 *>          NB is INTEGER
  78 *>          The maximum number of columns of the matrix A that should be
  79 *>          factored.  NB should be at least 2 to allow for 2-by-2 pivot
  80 *>          blocks.
  81 *> \endverbatim
  82 *>
  83 *> \param[out] KB
  84 *> \verbatim
  85 *>          KB is INTEGER
  86 *>          The number of columns of A that were actually factored.
  87 *>          KB is either NB-1 or NB, or N if N <= NB.
  88 *> \endverbatim
  89 *>
  90 *> \param[in,out] A
  91 *> \verbatim
  92 *>          A is COMPLEX array, dimension (LDA,N)
  93 *>          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
  94 *>          n-by-n upper triangular part of A contains the upper
  95 *>          triangular part of the matrix A, and the strictly lower
  96 *>          triangular part of A is not referenced.  If UPLO = 'L', the
  97 *>          leading n-by-n lower triangular part of A contains the lower
  98 *>          triangular part of the matrix A, and the strictly upper
  99 *>          triangular part of A is not referenced.
 100 *>          On exit, A contains details of the partial factorization.
 101 *> \endverbatim
 102 *>
 103 *> \param[in] LDA
 104 *> \verbatim
 105 *>          LDA is INTEGER
 106 *>          The leading dimension of the array A.  LDA >= max(1,N).
 107 *> \endverbatim
 108 *>
 109 *> \param[out] IPIV
 110 *> \verbatim
 111 *>          IPIV is INTEGER array, dimension (N)
 112 *>          Details of the interchanges and the block structure of D.
 113 *>
 114 *>          If UPLO = 'U':
 115 *>             Only the last KB elements of IPIV are set.
 116 *>
 117 *>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
 118 *>             interchanged and D(k,k) is a 1-by-1 diagonal block.
 119 *>
 120 *>             If IPIV(k) = IPIV(k-1) < 0, then rows and columns
 121 *>             k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
 122 *>             is a 2-by-2 diagonal block.
 123 *>
 124 *>          If UPLO = 'L':
 125 *>             Only the first KB elements of IPIV are set.
 126 *>
 127 *>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
 128 *>             interchanged and D(k,k) is a 1-by-1 diagonal block.
 129 *>
 130 *>             If IPIV(k) = IPIV(k+1) < 0, then rows and columns
 131 *>             k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1)
 132 *>             is a 2-by-2 diagonal block.
 133 *> \endverbatim
 134 *>
 135 *> \param[out] W
 136 *> \verbatim
 137 *>          W is COMPLEX array, dimension (LDW,NB)
 138 *> \endverbatim
 139 *>
 140 *> \param[in] LDW
 141 *> \verbatim
 142 *>          LDW is INTEGER
 143 *>          The leading dimension of the array W.  LDW >= max(1,N).
 144 *> \endverbatim
 145 *>
 146 *> \param[out] INFO
 147 *> \verbatim
 148 *>          INFO is INTEGER
 149 *>          = 0: successful exit
 150 *>          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
 151 *>               has been completed, but the block diagonal matrix D is
 152 *>               exactly singular.
 153 *> \endverbatim
 154 *
 155 *  Authors:
 156 *  ========
 157 *
 158 *> \author Univ. of Tennessee
 159 *> \author Univ. of California Berkeley
 160 *> \author Univ. of Colorado Denver
 161 *> \author NAG Ltd.
 162 *
 163 *> \date November 2013
 164 *
 165 *> \ingroup complexHEcomputational
 166 *
 167 *> \par Contributors:
 168 *  ==================
 169 *>
 170 *> \verbatim
 171 *>
 172 *>  November 2013,  Igor Kozachenko,
 173 *>                  Computer Science Division,
 174 *>                  University of California, Berkeley
 175 *> \endverbatim
 176 *
 177 *  =====================================================================
 178       SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
 179 *
 180 *  -- LAPACK computational routine (version 3.5.0) --
 181 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 182 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 183 *     November 2013
 184 *
 185 *     .. Scalar Arguments ..
 186       CHARACTER          UPLO
 187       INTEGER            INFO, KB, LDA, LDW, N, NB
 188 *     ..
 189 *     .. Array Arguments ..
 190       INTEGER            IPIV( * )
 191       COMPLEX            A( LDA, * ), W( LDW, * )
 192 *     ..
 193 *
 194 *  =====================================================================
 195 *
 196 *     .. Parameters ..
 197       REAL               ZERO, ONE
 198       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
 199       COMPLEX            CONE
 200       PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ) )
 201       REAL               EIGHT, SEVTEN
 202       PARAMETER          ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
 203 *     ..
 204 *     .. Local Scalars ..
 205       INTEGER            IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
 206      $                   KSTEP, KW
 207       REAL               ABSAKK, ALPHA, COLMAX, R1, ROWMAX, T
 208       COMPLEX            D11, D21, D22, Z
 209 *     ..
 210 *     .. External Functions ..
 211       LOGICAL            LSAME
 212       INTEGER            ICAMAX
 213       EXTERNAL           LSAME, ICAMAX
 214 *     ..
 215 *     .. External Subroutines ..
 216       EXTERNAL           CCOPY, CGEMM, CGEMV, CLACGV, CSSCAL, CSWAP
 217 *     ..
 218 *     .. Intrinsic Functions ..
 219       INTRINSIC          ABS, AIMAG, CONJG, MAX, MIN, REAL, SQRT
 220 *     ..
 221 *     .. Statement Functions ..
 222       REAL               CABS1
 223 *     ..
 224 *     .. Statement Function definitions ..
 225       CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
 226 *     ..
 227 *     .. Executable Statements ..
 228 *
 229       INFO = 0
 230 *
 231 *     Initialize ALPHA for use in choosing pivot block size.
 232 *
 233       ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
 234 *
 235       IF( LSAME( UPLO, 'U' ) ) THEN
 236 *
 237 *        Factorize the trailing columns of A using the upper triangle
 238 *        of A and working backwards, and compute the matrix W = U12*D
 239 *        for use in updating A11 (note that conjg(W) is actually stored)
 240 *
 241 *        K is the main loop index, decreasing from N in steps of 1 or 2
 242 *
 243          K = N
 244    10    CONTINUE
 245 *
 246 *        KW is the column of W which corresponds to column K of A
 247 *
 248          KW = NB + K - N
 249 *
 250 *        Exit from loop
 251 *
 252          IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
 253      $      GO TO 30
 254 *
 255          KSTEP = 1
 256 *
 257 *        Copy column K of A to column KW of W and update it
 258 *
 259          CALL CCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 )
 260          W( K, KW ) = REAL( A( K, K ) )
 261          IF( K.LT.N ) THEN
 262             CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA,
 263      $                  W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
 264             W( K, KW ) = REAL( W( K, KW ) )
 265          END IF
 266 *
 267 *        Determine rows and columns to be interchanged and whether
 268 *        a 1-by-1 or 2-by-2 pivot block will be used
 269 *
 270          ABSAKK = ABS( REAL( W( K, KW ) ) )
 271 *
 272 *        IMAX is the row-index of the largest off-diagonal element in
 273 *        column K, and COLMAX is its absolute value.
 274 *        Determine both COLMAX and IMAX.
 275 *
 276          IF( K.GT.1 ) THEN
 277             IMAX = ICAMAX( K-1, W( 1, KW ), 1 )
 278             COLMAX = CABS1( W( IMAX, KW ) )
 279          ELSE
 280             COLMAX = ZERO
 281          END IF
 282 *
 283          IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
 284 *
 285 *           Column K is zero or underflow: set INFO and continue
 286 *
 287             IF( INFO.EQ.0 )
 288      $         INFO = K
 289             KP = K
 290             A( K, K ) = REAL( A( K, K ) )
 291          ELSE
 292 *
 293 *           ============================================================
 294 *
 295 *           BEGIN pivot search
 296 *
 297 *           Case(1)
 298             IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
 299 *
 300 *              no interchange, use 1-by-1 pivot block
 301 *
 302                KP = K
 303             ELSE
 304 *
 305 *              BEGIN pivot search along IMAX row
 306 *
 307 *
 308 *              Copy column IMAX to column KW-1 of W and update it
 309 *
 310                CALL CCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
 311                W( IMAX, KW-1 ) = REAL( A( IMAX, IMAX ) )
 312                CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
 313      $                     W( IMAX+1, KW-1 ), 1 )
 314                CALL CLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 )
 315                IF( K.LT.N ) THEN
 316                   CALL CGEMV( 'No transpose', K, N-K, -CONE,
 317      $                        A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
 318      $                        CONE, W( 1, KW-1 ), 1 )
 319                   W( IMAX, KW-1 ) = REAL( W( IMAX, KW-1 ) )
 320                END IF
 321 *
 322 *              JMAX is the column-index of the largest off-diagonal
 323 *              element in row IMAX, and ROWMAX is its absolute value.
 324 *              Determine only ROWMAX.
 325 *
 326                JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
 327                ROWMAX = CABS1( W( JMAX, KW-1 ) )
 328                IF( IMAX.GT.1 ) THEN
 329                   JMAX = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 )
 330                   ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, KW-1 ) ) )
 331                END IF
 332 *
 333 *              Case(2)
 334                IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
 335 *
 336 *                 no interchange, use 1-by-1 pivot block
 337 *
 338                   KP = K
 339 *
 340 *              Case(3)
 341                ELSE IF( ABS( REAL( W( IMAX, KW-1 ) ) ).GE.ALPHA*ROWMAX )
 342      $                   THEN
 343 *
 344 *                 interchange rows and columns K and IMAX, use 1-by-1
 345 *                 pivot block
 346 *
 347                   KP = IMAX
 348 *
 349 *                 copy column KW-1 of W to column KW of W
 350 *
 351                   CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
 352 *
 353 *              Case(4)
 354                ELSE
 355 *
 356 *                 interchange rows and columns K-1 and IMAX, use 2-by-2
 357 *                 pivot block
 358 *
 359                   KP = IMAX
 360                   KSTEP = 2
 361                END IF
 362 *
 363 *
 364 *              END pivot search along IMAX row
 365 *
 366             END IF
 367 *
 368 *           END pivot search
 369 *
 370 *           ============================================================
 371 *
 372 *           KK is the column of A where pivoting step stopped
 373 *
 374             KK = K - KSTEP + 1
 375 *
 376 *           KKW is the column of W which corresponds to column KK of A
 377 *
 378             KKW = NB + KK - N
 379 *
 380 *           Interchange rows and columns KP and KK.
 381 *           Updated column KP is already stored in column KKW of W.
 382 *
 383             IF( KP.NE.KK ) THEN
 384 *
 385 *              Copy non-updated column KK to column KP of submatrix A
 386 *              at step K. No need to copy element into column K
 387 *              (or K and K-1 for 2-by-2 pivot) of A, since these columns
 388 *              will be later overwritten.
 389 *
 390                A( KP, KP ) = REAL( A( KK, KK ) )
 391                CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
 392      $                     LDA )
 393                CALL CLACGV( KK-1-KP, A( KP, KP+1 ), LDA )
 394                IF( KP.GT.1 )
 395      $            CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
 396 *
 397 *              Interchange rows KK and KP in last K+1 to N columns of A
 398 *              (columns K (or K and K-1 for 2-by-2 pivot) of A will be
 399 *              later overwritten). Interchange rows KK and KP
 400 *              in last KKW to NB columns of W.
 401 *
 402                IF( K.LT.N )
 403      $            CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
 404      $                        LDA )
 405                CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
 406      $                     LDW )
 407             END IF
 408 *
 409             IF( KSTEP.EQ.1 ) THEN
 410 *
 411 *              1-by-1 pivot block D(k): column kw of W now holds
 412 *
 413 *              W(kw) = U(k)*D(k),
 414 *
 415 *              where U(k) is the k-th column of U
 416 *
 417 *              (1) Store subdiag. elements of column U(k)
 418 *              and 1-by-1 block D(k) in column k of A.
 419 *              (NOTE: Diagonal element U(k,k) is a UNIT element
 420 *              and not stored)
 421 *                 A(k,k) := D(k,k) = W(k,kw)
 422 *                 A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
 423 *
 424 *              (NOTE: No need to use for Hermitian matrix
 425 *              A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
 426 *              element D(k,k) from W (potentially saves only one load))
 427                CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
 428                IF( K.GT.1 ) THEN
 429 *
 430 *                 (NOTE: No need to check if A(k,k) is NOT ZERO,
 431 *                  since that was ensured earlier in pivot search:
 432 *                  case A(k,k) = 0 falls into 2x2 pivot case(4))
 433 *
 434                   R1 = ONE / REAL( A( K, K ) )
 435                   CALL CSSCAL( K-1, R1, A( 1, K ), 1 )
 436 *
 437 *                 (2) Conjugate column W(kw)
 438 *
 439                   CALL CLACGV( K-1, W( 1, KW ), 1 )
 440                END IF
 441 *
 442             ELSE
 443 *
 444 *              2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
 445 *
 446 *              ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
 447 *
 448 *              where U(k) and U(k-1) are the k-th and (k-1)-th columns
 449 *              of U
 450 *
 451 *              (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
 452 *              block D(k-1:k,k-1:k) in columns k-1 and k of A.
 453 *              (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
 454 *              block and not stored)
 455 *                 A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
 456 *                 A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
 457 *                 = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
 458 *
 459                IF( K.GT.2 ) THEN
 460 *
 461 *                 Factor out the columns of the inverse of 2-by-2 pivot
 462 *                 block D, so that each column contains 1, to reduce the
 463 *                 number of FLOPS when we multiply panel
 464 *                 ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
 465 *
 466 *                 D**(-1) = ( d11 cj(d21) )**(-1) =
 467 *                           ( d21    d22 )
 468 *
 469 *                 = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
 470 *                                          ( (-d21) (     d11 ) )
 471 *
 472 *                 = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
 473 *
 474 *                   * ( d21*( d22/d21 ) conj(d21)*(           - 1 ) ) =
 475 *                     (     (      -1 )           ( d11/conj(d21) ) )
 476 *
 477 *                 = 1/(|d21|**2) * 1/(D22*D11-1) *
 478 *
 479 *                   * ( d21*( D11 ) conj(d21)*(  -1 ) ) =
 480 *                     (     (  -1 )           ( D22 ) )
 481 *
 482 *                 = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*(  -1 ) ) =
 483 *                                      (     (  -1 )           ( D22 ) )
 484 *
 485 *                 = ( (T/conj(d21))*( D11 ) (T/d21)*(  -1 ) ) =
 486 *                   (               (  -1 )         ( D22 ) )
 487 *
 488 *                 = ( conj(D21)*( D11 ) D21*(  -1 ) )
 489 *                   (           (  -1 )     ( D22 ) ),
 490 *
 491 *                 where D11 = d22/d21,
 492 *                       D22 = d11/conj(d21),
 493 *                       D21 = T/d21,
 494 *                       T = 1/(D22*D11-1).
 495 *
 496 *                 (NOTE: No need to check for division by ZERO,
 497 *                  since that was ensured earlier in pivot search:
 498 *                  (a) d21 != 0, since in 2x2 pivot case(4)
 499 *                      |d21| should be larger than |d11| and |d22|;
 500 *                  (b) (D22*D11 - 1) != 0, since from (a),
 501 *                      both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
 502 *
 503                   D21 = W( K-1, KW )
 504                   D11 = W( K, KW ) / CONJG( D21 )
 505                   D22 = W( K-1, KW-1 ) / D21
 506                   T = ONE / ( REAL( D11*D22 )-ONE )
 507                   D21 = T / D21
 508 *
 509 *                 Update elements in columns A(k-1) and A(k) as
 510 *                 dot products of rows of ( W(kw-1) W(kw) ) and columns
 511 *                 of D**(-1)
 512 *
 513                   DO 20 J = 1, K - 2
 514                      A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
 515                      A( J, K ) = CONJG( D21 )*
 516      $                           ( D22*W( J, KW )-W( J, KW-1 ) )
 517    20             CONTINUE
 518                END IF
 519 *
 520 *              Copy D(k) to A
 521 *
 522                A( K-1, K-1 ) = W( K-1, KW-1 )
 523                A( K-1, K ) = W( K-1, KW )
 524                A( K, K ) = W( K, KW )
 525 *
 526 *              (2) Conjugate columns W(kw) and W(kw-1)
 527 *
 528                CALL CLACGV( K-1, W( 1, KW ), 1 )
 529                CALL CLACGV( K-2, W( 1, KW-1 ), 1 )
 530 *
 531             END IF
 532 *
 533          END IF
 534 *
 535 *        Store details of the interchanges in IPIV
 536 *
 537          IF( KSTEP.EQ.1 ) THEN
 538             IPIV( K ) = KP
 539          ELSE
 540             IPIV( K ) = -KP
 541             IPIV( K-1 ) = -KP
 542          END IF
 543 *
 544 *        Decrease K and return to the start of the main loop
 545 *
 546          K = K - KSTEP
 547          GO TO 10
 548 *
 549    30    CONTINUE
 550 *
 551 *        Update the upper triangle of A11 (= A(1:k,1:k)) as
 552 *
 553 *        A11 := A11 - U12*D*U12**H = A11 - U12*W**H
 554 *
 555 *        computing blocks of NB columns at a time (note that conjg(W) is
 556 *        actually stored)
 557 *
 558          DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
 559             JB = MIN( NB, K-J+1 )
 560 *
 561 *           Update the upper triangle of the diagonal block
 562 *
 563             DO 40 JJ = J, J + JB - 1
 564                A( JJ, JJ ) = REAL( A( JJ, JJ ) )
 565                CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
 566      $                     A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
 567      $                     A( J, JJ ), 1 )
 568                A( JJ, JJ ) = REAL( A( JJ, JJ ) )
 569    40       CONTINUE
 570 *
 571 *           Update the rectangular superdiagonal block
 572 *
 573             CALL CGEMM( 'No transpose', 'Transpose', J-1, JB, N-K,
 574      $                  -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
 575      $                  CONE, A( 1, J ), LDA )
 576    50    CONTINUE
 577 *
 578 *        Put U12 in standard form by partially undoing the interchanges
 579 *        in of rows in columns k+1:n looping backwards from k+1 to n
 580 *
 581          J = K + 1
 582    60    CONTINUE
 583 *
 584 *           Undo the interchanges (if any) of rows J and JP
 585 *           at each step J
 586 *
 587 *           (Here, J is a diagonal index)
 588             JJ = J
 589             JP = IPIV( J )
 590             IF( JP.LT.0 ) THEN
 591                JP = -JP
 592 *              (Here, J is a diagonal index)
 593                J = J + 1
 594             END IF
 595 *           (NOTE: Here, J is used to determine row length. Length N-J+1
 596 *           of the rows to swap back doesn't include diagonal element)
 597             J = J + 1
 598             IF( JP.NE.JJ .AND. J.LE.N )
 599      $         CALL CSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
 600          IF( J.LE.N )
 601      $      GO TO 60
 602 *
 603 *        Set KB to the number of columns factorized
 604 *
 605          KB = N - K
 606 *
 607       ELSE
 608 *
 609 *        Factorize the leading columns of A using the lower triangle
 610 *        of A and working forwards, and compute the matrix W = L21*D
 611 *        for use in updating A22 (note that conjg(W) is actually stored)
 612 *
 613 *        K is the main loop index, increasing from 1 in steps of 1 or 2
 614 *
 615          K = 1
 616    70    CONTINUE
 617 *
 618 *        Exit from loop
 619 *
 620          IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
 621      $      GO TO 90
 622 *
 623          KSTEP = 1
 624 *
 625 *        Copy column K of A to column K of W and update it
 626 *
 627          W( K, K ) = REAL( A( K, K ) )
 628          IF( K.LT.N )
 629      $      CALL CCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 )
 630          CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ), LDA,
 631      $               W( K, 1 ), LDW, CONE, W( K, K ), 1 )
 632          W( K, K ) = REAL( W( K, K ) )
 633 *
 634 *        Determine rows and columns to be interchanged and whether
 635 *        a 1-by-1 or 2-by-2 pivot block will be used
 636 *
 637          ABSAKK = ABS( REAL( W( K, K ) ) )
 638 *
 639 *        IMAX is the row-index of the largest off-diagonal element in
 640 *        column K, and COLMAX is its absolute value.
 641 *        Determine both COLMAX and IMAX.
 642 *
 643          IF( K.LT.N ) THEN
 644             IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 )
 645             COLMAX = CABS1( W( IMAX, K ) )
 646          ELSE
 647             COLMAX = ZERO
 648          END IF
 649 *
 650          IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
 651 *
 652 *           Column K is zero or underflow: set INFO and continue
 653 *
 654             IF( INFO.EQ.0 )
 655      $         INFO = K
 656             KP = K
 657             A( K, K ) = REAL( A( K, K ) )
 658          ELSE
 659 *
 660 *           ============================================================
 661 *
 662 *           BEGIN pivot search
 663 *
 664 *           Case(1)
 665             IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
 666 *
 667 *              no interchange, use 1-by-1 pivot block
 668 *
 669                KP = K
 670             ELSE
 671 *
 672 *              BEGIN pivot search along IMAX row
 673 *
 674 *
 675 *              Copy column IMAX to column K+1 of W and update it
 676 *
 677                CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
 678                CALL CLACGV( IMAX-K, W( K, K+1 ), 1 )
 679                W( IMAX, K+1 ) = REAL( A( IMAX, IMAX ) )
 680                IF( IMAX.LT.N )
 681      $            CALL CCOPY( N-IMAX, A( IMAX+1, IMAX ), 1,
 682      $                        W( IMAX+1, K+1 ), 1 )
 683                CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
 684      $                     LDA, W( IMAX, 1 ), LDW, CONE, W( K, K+1 ),
 685      $                     1 )
 686                W( IMAX, K+1 ) = REAL( W( IMAX, K+1 ) )
 687 *
 688 *              JMAX is the column-index of the largest off-diagonal
 689 *              element in row IMAX, and ROWMAX is its absolute value.
 690 *              Determine only ROWMAX.
 691 *
 692                JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 )
 693                ROWMAX = CABS1( W( JMAX, K+1 ) )
 694                IF( IMAX.LT.N ) THEN
 695                   JMAX = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
 696                   ROWMAX = MAX( ROWMAX, CABS1( W( JMAX, K+1 ) ) )
 697                END IF
 698 *
 699 *              Case(2)
 700                IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
 701 *
 702 *                 no interchange, use 1-by-1 pivot block
 703 *
 704                   KP = K
 705 *
 706 *              Case(3)
 707                ELSE IF( ABS( REAL( W( IMAX, K+1 ) ) ).GE.ALPHA*ROWMAX )
 708      $                   THEN
 709 *
 710 *                 interchange rows and columns K and IMAX, use 1-by-1
 711 *                 pivot block
 712 *
 713                   KP = IMAX
 714 *
 715 *                 copy column K+1 of W to column K of W
 716 *
 717                   CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
 718 *
 719 *              Case(4)
 720                ELSE
 721 *
 722 *                 interchange rows and columns K+1 and IMAX, use 2-by-2
 723 *                 pivot block
 724 *
 725                   KP = IMAX
 726                   KSTEP = 2
 727                END IF
 728 *
 729 *
 730 *              END pivot search along IMAX row
 731 *
 732             END IF
 733 *
 734 *           END pivot search
 735 *
 736 *           ============================================================
 737 *
 738 *           KK is the column of A where pivoting step stopped
 739 *
 740             KK = K + KSTEP - 1
 741 *
 742 *           Interchange rows and columns KP and KK.
 743 *           Updated column KP is already stored in column KK of W.
 744 *
 745             IF( KP.NE.KK ) THEN
 746 *
 747 *              Copy non-updated column KK to column KP of submatrix A
 748 *              at step K. No need to copy element into column K
 749 *              (or K and K+1 for 2-by-2 pivot) of A, since these columns
 750 *              will be later overwritten.
 751 *
 752                A( KP, KP ) = REAL( A( KK, KK ) )
 753                CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
 754      $                     LDA )
 755                CALL CLACGV( KP-KK-1, A( KP, KK+1 ), LDA )
 756                IF( KP.LT.N )
 757      $            CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
 758 *
 759 *              Interchange rows KK and KP in first K-1 columns of A
 760 *              (columns K (or K and K+1 for 2-by-2 pivot) of A will be
 761 *              later overwritten). Interchange rows KK and KP
 762 *              in first KK columns of W.
 763 *
 764                IF( K.GT.1 )
 765      $            CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
 766                CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
 767             END IF
 768 *
 769             IF( KSTEP.EQ.1 ) THEN
 770 *
 771 *              1-by-1 pivot block D(k): column k of W now holds
 772 *
 773 *              W(k) = L(k)*D(k),
 774 *
 775 *              where L(k) is the k-th column of L
 776 *
 777 *              (1) Store subdiag. elements of column L(k)
 778 *              and 1-by-1 block D(k) in column k of A.
 779 *              (NOTE: Diagonal element L(k,k) is a UNIT element
 780 *              and not stored)
 781 *                 A(k,k) := D(k,k) = W(k,k)
 782 *                 A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
 783 *
 784 *              (NOTE: No need to use for Hermitian matrix
 785 *              A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal
 786 *              element D(k,k) from W (potentially saves only one load))
 787                CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
 788                IF( K.LT.N ) THEN
 789 *
 790 *                 (NOTE: No need to check if A(k,k) is NOT ZERO,
 791 *                  since that was ensured earlier in pivot search:
 792 *                  case A(k,k) = 0 falls into 2x2 pivot case(4))
 793 *
 794                   R1 = ONE / REAL( A( K, K ) )
 795                   CALL CSSCAL( N-K, R1, A( K+1, K ), 1 )
 796 *
 797 *                 (2) Conjugate column W(k)
 798 *
 799                   CALL CLACGV( N-K, W( K+1, K ), 1 )
 800                END IF
 801 *
 802             ELSE
 803 *
 804 *              2-by-2 pivot block D(k): columns k and k+1 of W now hold
 805 *
 806 *              ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
 807 *
 808 *              where L(k) and L(k+1) are the k-th and (k+1)-th columns
 809 *              of L
 810 *
 811 *              (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
 812 *              block D(k:k+1,k:k+1) in columns k and k+1 of A.
 813 *              (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
 814 *              block and not stored)
 815 *                 A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
 816 *                 A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
 817 *                 = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
 818 *
 819                IF( K.LT.N-1 ) THEN
 820 *
 821 *                 Factor out the columns of the inverse of 2-by-2 pivot
 822 *                 block D, so that each column contains 1, to reduce the
 823 *                 number of FLOPS when we multiply panel
 824 *                 ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
 825 *
 826 *                 D**(-1) = ( d11 cj(d21) )**(-1) =
 827 *                           ( d21    d22 )
 828 *
 829 *                 = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
 830 *                                          ( (-d21) (     d11 ) )
 831 *
 832 *                 = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
 833 *
 834 *                   * ( d21*( d22/d21 ) conj(d21)*(           - 1 ) ) =
 835 *                     (     (      -1 )           ( d11/conj(d21) ) )
 836 *
 837 *                 = 1/(|d21|**2) * 1/(D22*D11-1) *
 838 *
 839 *                   * ( d21*( D11 ) conj(d21)*(  -1 ) ) =
 840 *                     (     (  -1 )           ( D22 ) )
 841 *
 842 *                 = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*(  -1 ) ) =
 843 *                                      (     (  -1 )           ( D22 ) )
 844 *
 845 *                 = ( (T/conj(d21))*( D11 ) (T/d21)*(  -1 ) ) =
 846 *                   (               (  -1 )         ( D22 ) )
 847 *
 848 *                 = ( conj(D21)*( D11 ) D21*(  -1 ) )
 849 *                   (           (  -1 )     ( D22 ) )
 850 *
 851 *                 where D11 = d22/d21,
 852 *                       D22 = d11/conj(d21),
 853 *                       D21 = T/d21,
 854 *                       T = 1/(D22*D11-1).
 855 *
 856 *                 (NOTE: No need to check for division by ZERO,
 857 *                  since that was ensured earlier in pivot search:
 858 *                  (a) d21 != 0, since in 2x2 pivot case(4)
 859 *                      |d21| should be larger than |d11| and |d22|;
 860 *                  (b) (D22*D11 - 1) != 0, since from (a),
 861 *                      both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
 862 *
 863                   D21 = W( K+1, K )
 864                   D11 = W( K+1, K+1 ) / D21
 865                   D22 = W( K, K ) / CONJG( D21 )
 866                   T = ONE / ( REAL( D11*D22 )-ONE )
 867                   D21 = T / D21
 868 *
 869 *                 Update elements in columns A(k) and A(k+1) as
 870 *                 dot products of rows of ( W(k) W(k+1) ) and columns
 871 *                 of D**(-1)
 872 *
 873                   DO 80 J = K + 2, N
 874                      A( J, K ) = CONJG( D21 )*
 875      $                           ( D11*W( J, K )-W( J, K+1 ) )
 876                      A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
 877    80             CONTINUE
 878                END IF
 879 *
 880 *              Copy D(k) to A
 881 *
 882                A( K, K ) = W( K, K )
 883                A( K+1, K ) = W( K+1, K )
 884                A( K+1, K+1 ) = W( K+1, K+1 )
 885 *
 886 *              (2) Conjugate columns W(k) and W(k+1)
 887 *
 888                CALL CLACGV( N-K, W( K+1, K ), 1 )
 889                CALL CLACGV( N-K-1, W( K+2, K+1 ), 1 )
 890 *
 891             END IF
 892 *
 893          END IF
 894 *
 895 *        Store details of the interchanges in IPIV
 896 *
 897          IF( KSTEP.EQ.1 ) THEN
 898             IPIV( K ) = KP
 899          ELSE
 900             IPIV( K ) = -KP
 901             IPIV( K+1 ) = -KP
 902          END IF
 903 *
 904 *        Increase K and return to the start of the main loop
 905 *
 906          K = K + KSTEP
 907          GO TO 70
 908 *
 909    90    CONTINUE
 910 *
 911 *        Update the lower triangle of A22 (= A(k:n,k:n)) as
 912 *
 913 *        A22 := A22 - L21*D*L21**H = A22 - L21*W**H
 914 *
 915 *        computing blocks of NB columns at a time (note that conjg(W) is
 916 *        actually stored)
 917 *
 918          DO 110 J = K, N, NB
 919             JB = MIN( NB, N-J+1 )
 920 *
 921 *           Update the lower triangle of the diagonal block
 922 *
 923             DO 100 JJ = J, J + JB - 1
 924                A( JJ, JJ ) = REAL( A( JJ, JJ ) )
 925                CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
 926      $                     A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
 927      $                     A( JJ, JJ ), 1 )
 928                A( JJ, JJ ) = REAL( A( JJ, JJ ) )
 929   100       CONTINUE
 930 *
 931 *           Update the rectangular subdiagonal block
 932 *
 933             IF( J+JB.LE.N )
 934      $         CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
 935      $                     K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
 936      $                     LDW, CONE, A( J+JB, J ), LDA )
 937   110    CONTINUE
 938 *
 939 *        Put L21 in standard form by partially undoing the interchanges
 940 *        of rows in columns 1:k-1 looping backwards from k-1 to 1
 941 *
 942          J = K - 1
 943   120    CONTINUE
 944 *
 945 *           Undo the interchanges (if any) of rows J and JP
 946 *           at each step J
 947 *
 948 *           (Here, J is a diagonal index)
 949             JJ = J
 950             JP = IPIV( J )
 951             IF( JP.LT.0 ) THEN
 952                JP = -JP
 953 *              (Here, J is a diagonal index)
 954                J = J - 1
 955             END IF
 956 *           (NOTE: Here, J is used to determine row length. Length J
 957 *           of the rows to swap back doesn't include diagonal element)
 958             J = J - 1
 959             IF( JP.NE.JJ .AND. J.GE.1 )
 960      $         CALL CSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
 961          IF( J.GE.1 )
 962      $      GO TO 120
 963 *
 964 *        Set KB to the number of columns factorized
 965 *
 966          KB = K - 1
 967 *
 968       END IF
 969       RETURN
 970 *
 971 *     End of CLAHEF
 972 *
 973       END