00001 SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) 00002 * 00003 * -- LAPACK auxiliary routine (version 3.2) -- 00004 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00005 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 CHARACTER EQUED, UPLO 00010 INTEGER LDA, N 00011 DOUBLE PRECISION AMAX, SCOND 00012 * .. 00013 * .. Array Arguments .. 00014 DOUBLE PRECISION S( * ) 00015 COMPLEX*16 A( LDA, * ) 00016 * .. 00017 * 00018 * Purpose 00019 * ======= 00020 * 00021 * ZLAQHE equilibrates a Hermitian matrix A using the scaling factors 00022 * in the vector S. 00023 * 00024 * Arguments 00025 * ========= 00026 * 00027 * UPLO (input) CHARACTER*1 00028 * Specifies whether the upper or lower triangular part of the 00029 * Hermitian matrix A is stored. 00030 * = 'U': Upper triangular 00031 * = 'L': Lower triangular 00032 * 00033 * N (input) INTEGER 00034 * The order of the matrix A. N >= 0. 00035 * 00036 * A (input/output) COMPLEX*16 array, dimension (LDA,N) 00037 * On entry, the Hermitian matrix A. If UPLO = 'U', the leading 00038 * n by n upper triangular part of A contains the upper 00039 * triangular part of the matrix A, and the strictly lower 00040 * triangular part of A is not referenced. If UPLO = 'L', the 00041 * leading n by n lower triangular part of A contains the lower 00042 * triangular part of the matrix A, and the strictly upper 00043 * triangular part of A is not referenced. 00044 * 00045 * On exit, if EQUED = 'Y', the equilibrated matrix: 00046 * diag(S) * A * diag(S). 00047 * 00048 * LDA (input) INTEGER 00049 * The leading dimension of the array A. LDA >= max(N,1). 00050 * 00051 * S (input) DOUBLE PRECISION array, dimension (N) 00052 * The scale factors for A. 00053 * 00054 * SCOND (input) DOUBLE PRECISION 00055 * Ratio of the smallest S(i) to the largest S(i). 00056 * 00057 * AMAX (input) DOUBLE PRECISION 00058 * Absolute value of largest matrix entry. 00059 * 00060 * EQUED (output) CHARACTER*1 00061 * Specifies whether or not equilibration was done. 00062 * = 'N': No equilibration. 00063 * = 'Y': Equilibration was done, i.e., A has been replaced by 00064 * diag(S) * A * diag(S). 00065 * 00066 * Internal Parameters 00067 * =================== 00068 * 00069 * THRESH is a threshold value used to decide if scaling should be done 00070 * based on the ratio of the scaling factors. If SCOND < THRESH, 00071 * scaling is done. 00072 * 00073 * LARGE and SMALL are threshold values used to decide if scaling should 00074 * be done based on the absolute size of the largest matrix element. 00075 * If AMAX > LARGE or AMAX < SMALL, scaling is done. 00076 * 00077 * ===================================================================== 00078 * 00079 * .. Parameters .. 00080 DOUBLE PRECISION ONE, THRESH 00081 PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 ) 00082 * .. 00083 * .. Local Scalars .. 00084 INTEGER I, J 00085 DOUBLE PRECISION CJ, LARGE, SMALL 00086 * .. 00087 * .. External Functions .. 00088 LOGICAL LSAME 00089 DOUBLE PRECISION DLAMCH 00090 EXTERNAL LSAME, DLAMCH 00091 * .. 00092 * .. Intrinsic Functions .. 00093 INTRINSIC DBLE 00094 * .. 00095 * .. Executable Statements .. 00096 * 00097 * Quick return if possible 00098 * 00099 IF( N.LE.0 ) THEN 00100 EQUED = 'N' 00101 RETURN 00102 END IF 00103 * 00104 * Initialize LARGE and SMALL. 00105 * 00106 SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) 00107 LARGE = ONE / SMALL 00108 * 00109 IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN 00110 * 00111 * No equilibration 00112 * 00113 EQUED = 'N' 00114 ELSE 00115 * 00116 * Replace A by diag(S) * A * diag(S). 00117 * 00118 IF( LSAME( UPLO, 'U' ) ) THEN 00119 * 00120 * Upper triangle of A is stored. 00121 * 00122 DO 20 J = 1, N 00123 CJ = S( J ) 00124 DO 10 I = 1, J - 1 00125 A( I, J ) = CJ*S( I )*A( I, J ) 00126 10 CONTINUE 00127 A( J, J ) = CJ*CJ*DBLE( A( J, J ) ) 00128 20 CONTINUE 00129 ELSE 00130 * 00131 * Lower triangle of A is stored. 00132 * 00133 DO 40 J = 1, N 00134 CJ = S( J ) 00135 A( J, J ) = CJ*CJ*DBLE( A( J, J ) ) 00136 DO 30 I = J + 1, N 00137 A( I, J ) = CJ*S( I )*A( I, J ) 00138 30 CONTINUE 00139 40 CONTINUE 00140 END IF 00141 EQUED = 'Y' 00142 END IF 00143 * 00144 RETURN 00145 * 00146 * End of ZLAQHE 00147 * 00148 END
1.7.2