Return to zhegs2.f CVS log

Up to [local] / rpl / lapack / lapack

Cohérence

    1:       SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
    2: *
    3: *  -- LAPACK routine (version 3.2) --
    4: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
    5: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
    6: *     November 2006
    7: *
    8: *     .. Scalar Arguments ..
    9:       CHARACTER          UPLO
   10:       INTEGER            INFO, ITYPE, LDA, LDB, N
   11: *     ..
   12: *     .. Array Arguments ..
   13:       COMPLEX*16         A( LDA, * ), B( LDB, * )
   14: *     ..
   15: *
   16: *  Purpose
   17: *  =======
   18: *
   19: *  ZHEGS2 reduces a complex Hermitian-definite generalized
   20: *  eigenproblem to standard form.
   21: *
   22: *  If ITYPE = 1, the problem is A*x = lambda*B*x,
   23: *  and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
   24: *
   25: *  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
   26: *  B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
   27: *
   28: *  B must have been previously factorized as U'*U or L*L' by ZPOTRF.
   29: *
   30: *  Arguments
   31: *  =========
   32: *
   33: *  ITYPE   (input) INTEGER
   34: *          = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
   35: *          = 2 or 3: compute U*A*U' or L'*A*L.
   36: *
   37: *  UPLO    (input) CHARACTER*1
   38: *          Specifies whether the upper or lower triangular part of the
   39: *          Hermitian matrix A is stored, and how B has been factorized.
   40: *          = 'U':  Upper triangular
   41: *          = 'L':  Lower triangular
   42: *
   43: *  N       (input) INTEGER
   44: *          The order of the matrices A and B.  N >= 0.
   45: *
   46: *  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
   47: *          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
   48: *          n by n upper triangular part of A contains the upper
   49: *          triangular part of the matrix A, and the strictly lower
   50: *          triangular part of A is not referenced.  If UPLO = 'L', the
   51: *          leading n by n lower triangular part of A contains the lower
   52: *          triangular part of the matrix A, and the strictly upper
   53: *          triangular part of A is not referenced.
   54: *
   55: *          On exit, if INFO = 0, the transformed matrix, stored in the
   56: *          same format as A.
   57: *
   58: *  LDA     (input) INTEGER
   59: *          The leading dimension of the array A.  LDA >= max(1,N).
   60: *
   61: *  B       (input) COMPLEX*16 array, dimension (LDB,N)
   62: *          The triangular factor from the Cholesky factorization of B,
   63: *          as returned by ZPOTRF.
   64: *
   65: *  LDB     (input) INTEGER
   66: *          The leading dimension of the array B.  LDB >= max(1,N).
   67: *
   68: *  INFO    (output) INTEGER
   69: *          = 0:  successful exit.
   70: *          < 0:  if INFO = -i, the i-th argument had an illegal value.
   71: *
   72: *  =====================================================================
   73: *
   74: *     .. Parameters ..
   75:       DOUBLE PRECISION   ONE, HALF
   76:       PARAMETER          ( ONE = 1.0D+0, HALF = 0.5D+0 )
   77:       COMPLEX*16         CONE
   78:       PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
   79: *     ..
   80: *     .. Local Scalars ..
   81:       LOGICAL            UPPER
   82:       INTEGER            K
   83:       DOUBLE PRECISION   AKK, BKK
   84:       COMPLEX*16         CT
   85: *     ..
   86: *     .. External Subroutines ..
   87:       EXTERNAL           XERBLA, ZAXPY, ZDSCAL, ZHER2, ZLACGV, ZTRMV,
   88:      $                   ZTRSV
   89: *     ..
   90: *     .. Intrinsic Functions ..
   91:       INTRINSIC          MAX
   92: *     ..
   93: *     .. External Functions ..
   94:       LOGICAL            LSAME
   95:       EXTERNAL           LSAME
   96: *     ..
   97: *     .. Executable Statements ..
   98: *
   99: *     Test the input parameters.
  100: *
  101:       INFO = 0
  102:       UPPER = LSAME( UPLO, 'U' )
  103:       IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
  104:          INFO = -1
  105:       ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
  106:          INFO = -2
  107:       ELSE IF( N.LT.0 ) THEN
  108:          INFO = -3
  109:       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
  110:          INFO = -5
  111:       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
  112:          INFO = -7
  113:       END IF
  114:       IF( INFO.NE.0 ) THEN
  115:          CALL XERBLA( 'ZHEGS2', -INFO )
  116:          RETURN
  117:       END IF
  118: *
  119:       IF( ITYPE.EQ.1 ) THEN
  120:          IF( UPPER ) THEN
  121: *
  122: *           Compute inv(U')*A*inv(U)
  123: *
  124:             DO 10 K = 1, N
  125: *
  126: *              Update the upper triangle of A(k:n,k:n)
  127: *
  128:                AKK = A( K, K )
  129:                BKK = B( K, K )
  130:                AKK = AKK / BKK**2
  131:                A( K, K ) = AKK
  132:                IF( K.LT.N ) THEN
  133:                   CALL ZDSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
  134:                   CT = -HALF*AKK
  135:                   CALL ZLACGV( N-K, A( K, K+1 ), LDA )
  136:                   CALL ZLACGV( N-K, B( K, K+1 ), LDB )
  137:                   CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
  138:      $                        LDA )
  139:                   CALL ZHER2( UPLO, N-K, -CONE, A( K, K+1 ), LDA,
  140:      $                        B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
  141:                   CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
  142:      $                        LDA )
  143:                   CALL ZLACGV( N-K, B( K, K+1 ), LDB )
  144:                   CALL ZTRSV( UPLO, 'Conjugate transpose', 'Non-unit',
  145:      $                        N-K, B( K+1, K+1 ), LDB, A( K, K+1 ),
  146:      $                        LDA )
  147:                   CALL ZLACGV( N-K, A( K, K+1 ), LDA )
  148:                END IF
  149:    10       CONTINUE
  150:          ELSE
  151: *
  152: *           Compute inv(L)*A*inv(L')
  153: *
  154:             DO 20 K = 1, N
  155: *
  156: *              Update the lower triangle of A(k:n,k:n)
  157: *
  158:                AKK = A( K, K )
  159:                BKK = B( K, K )
  160:                AKK = AKK / BKK**2
  161:                A( K, K ) = AKK
  162:                IF( K.LT.N ) THEN
  163:                   CALL ZDSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
  164:                   CT = -HALF*AKK
  165:                   CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
  166:                   CALL ZHER2( UPLO, N-K, -CONE, A( K+1, K ), 1,
  167:      $                        B( K+1, K ), 1, A( K+1, K+1 ), LDA )
  168:                   CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
  169:                   CALL ZTRSV( UPLO, 'No transpose', 'Non-unit', N-K,
  170:      $                        B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
  171:                END IF
  172:    20       CONTINUE
  173:          END IF
  174:       ELSE
  175:          IF( UPPER ) THEN
  176: *
  177: *           Compute U*A*U'
  178: *
  179:             DO 30 K = 1, N
  180: *
  181: *              Update the upper triangle of A(1:k,1:k)
  182: *
  183:                AKK = A( K, K )
  184:                BKK = B( K, K )
  185:                CALL ZTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
  186:      $                     LDB, A( 1, K ), 1 )
  187:                CT = HALF*AKK
  188:                CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
  189:                CALL ZHER2( UPLO, K-1, CONE, A( 1, K ), 1, B( 1, K ), 1,
  190:      $                     A, LDA )
  191:                CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
  192:                CALL ZDSCAL( K-1, BKK, A( 1, K ), 1 )
  193:                A( K, K ) = AKK*BKK**2
  194:    30       CONTINUE
  195:          ELSE
  196: *
  197: *           Compute L'*A*L
  198: *
  199:             DO 40 K = 1, N
  200: *
  201: *              Update the lower triangle of A(1:k,1:k)
  202: *
  203:                AKK = A( K, K )
  204:                BKK = B( K, K )
  205:                CALL ZLACGV( K-1, A( K, 1 ), LDA )
  206:                CALL ZTRMV( UPLO, 'Conjugate transpose', 'Non-unit', K-1,
  207:      $                     B, LDB, A( K, 1 ), LDA )
  208:                CT = HALF*AKK
  209:                CALL ZLACGV( K-1, B( K, 1 ), LDB )
  210:                CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
  211:                CALL ZHER2( UPLO, K-1, CONE, A( K, 1 ), LDA, B( K, 1 ),
  212:      $                     LDB, A, LDA )
  213:                CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
  214:                CALL ZLACGV( K-1, B( K, 1 ), LDB )
  215:                CALL ZDSCAL( K-1, BKK, A( K, 1 ), LDA )
  216:                CALL ZLACGV( K-1, A( K, 1 ), LDA )
  217:                A( K, K ) = AKK*BKK**2
  218:    40       CONTINUE
  219:          END IF
  220:       END IF
  221:       RETURN
  222: *
  223: *     End of ZHEGS2
  224: *
  225:       END