|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) 00002 * 00003 * -- LAPACK 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 INTEGER IHI, ILO, INFO, LDA, LWORK, N 00010 * .. 00011 * .. Array Arguments .. 00012 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) 00013 * .. 00014 * 00015 * Purpose 00016 * ======= 00017 * 00018 * DORGHR generates a real orthogonal matrix Q which is defined as the 00019 * product of IHI-ILO elementary reflectors of order N, as returned by 00020 * DGEHRD: 00021 * 00022 * Q = H(ilo) H(ilo+1) . . . H(ihi-1). 00023 * 00024 * Arguments 00025 * ========= 00026 * 00027 * N (input) INTEGER 00028 * The order of the matrix Q. N >= 0. 00029 * 00030 * ILO (input) INTEGER 00031 * IHI (input) INTEGER 00032 * ILO and IHI must have the same values as in the previous call 00033 * of DGEHRD. Q is equal to the unit matrix except in the 00034 * submatrix Q(ilo+1:ihi,ilo+1:ihi). 00035 * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. 00036 * 00037 * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) 00038 * On entry, the vectors which define the elementary reflectors, 00039 * as returned by DGEHRD. 00040 * On exit, the N-by-N orthogonal matrix Q. 00041 * 00042 * LDA (input) INTEGER 00043 * The leading dimension of the array A. LDA >= max(1,N). 00044 * 00045 * TAU (input) DOUBLE PRECISION array, dimension (N-1) 00046 * TAU(i) must contain the scalar factor of the elementary 00047 * reflector H(i), as returned by DGEHRD. 00048 * 00049 * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) 00050 * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. 00051 * 00052 * LWORK (input) INTEGER 00053 * The dimension of the array WORK. LWORK >= IHI-ILO. 00054 * For optimum performance LWORK >= (IHI-ILO)*NB, where NB is 00055 * the optimal blocksize. 00056 * 00057 * If LWORK = -1, then a workspace query is assumed; the routine 00058 * only calculates the optimal size of the WORK array, returns 00059 * this value as the first entry of the WORK array, and no error 00060 * message related to LWORK is issued by XERBLA. 00061 * 00062 * INFO (output) INTEGER 00063 * = 0: successful exit 00064 * < 0: if INFO = -i, the i-th argument had an illegal value 00065 * 00066 * ===================================================================== 00067 * 00068 * .. Parameters .. 00069 DOUBLE PRECISION ZERO, ONE 00070 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 00071 * .. 00072 * .. Local Scalars .. 00073 LOGICAL LQUERY 00074 INTEGER I, IINFO, J, LWKOPT, NB, NH 00075 * .. 00076 * .. External Subroutines .. 00077 EXTERNAL DORGQR, XERBLA 00078 * .. 00079 * .. External Functions .. 00080 INTEGER ILAENV 00081 EXTERNAL ILAENV 00082 * .. 00083 * .. Intrinsic Functions .. 00084 INTRINSIC MAX, MIN 00085 * .. 00086 * .. Executable Statements .. 00087 * 00088 * Test the input arguments 00089 * 00090 INFO = 0 00091 NH = IHI - ILO 00092 LQUERY = ( LWORK.EQ.-1 ) 00093 IF( N.LT.0 ) THEN 00094 INFO = -1 00095 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN 00096 INFO = -2 00097 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN 00098 INFO = -3 00099 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 00100 INFO = -5 00101 ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN 00102 INFO = -8 00103 END IF 00104 * 00105 IF( INFO.EQ.0 ) THEN 00106 NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 ) 00107 LWKOPT = MAX( 1, NH )*NB 00108 WORK( 1 ) = LWKOPT 00109 END IF 00110 * 00111 IF( INFO.NE.0 ) THEN 00112 CALL XERBLA( 'DORGHR', -INFO ) 00113 RETURN 00114 ELSE IF( LQUERY ) THEN 00115 RETURN 00116 END IF 00117 * 00118 * Quick return if possible 00119 * 00120 IF( N.EQ.0 ) THEN 00121 WORK( 1 ) = 1 00122 RETURN 00123 END IF 00124 * 00125 * Shift the vectors which define the elementary reflectors one 00126 * column to the right, and set the first ilo and the last n-ihi 00127 * rows and columns to those of the unit matrix 00128 * 00129 DO 40 J = IHI, ILO + 1, -1 00130 DO 10 I = 1, J - 1 00131 A( I, J ) = ZERO 00132 10 CONTINUE 00133 DO 20 I = J + 1, IHI 00134 A( I, J ) = A( I, J-1 ) 00135 20 CONTINUE 00136 DO 30 I = IHI + 1, N 00137 A( I, J ) = ZERO 00138 30 CONTINUE 00139 40 CONTINUE 00140 DO 60 J = 1, ILO 00141 DO 50 I = 1, N 00142 A( I, J ) = ZERO 00143 50 CONTINUE 00144 A( J, J ) = ONE 00145 60 CONTINUE 00146 DO 80 J = IHI + 1, N 00147 DO 70 I = 1, N 00148 A( I, J ) = ZERO 00149 70 CONTINUE 00150 A( J, J ) = ONE 00151 80 CONTINUE 00152 * 00153 IF( NH.GT.0 ) THEN 00154 * 00155 * Generate Q(ilo+1:ihi,ilo+1:ihi) 00156 * 00157 CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ), 00158 $ WORK, LWORK, IINFO ) 00159 END IF 00160 WORK( 1 ) = LWKOPT 00161 RETURN 00162 * 00163 * End of DORGHR 00164 * 00165 END
1.7.3 
