|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, 00002 $ LDC, WORK, LWORK, INFO ) 00003 * 00004 * -- LAPACK routine (version 3.2) -- 00005 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00006 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00007 * November 2006 00008 * 00009 * .. Scalar Arguments .. 00010 CHARACTER SIDE, TRANS 00011 INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N 00012 * .. 00013 * .. Array Arguments .. 00014 REAL A( LDA, * ), C( LDC, * ), TAU( * ), 00015 $ WORK( * ) 00016 * .. 00017 * 00018 * Purpose 00019 * ======= 00020 * 00021 * SORMHR overwrites the general real M-by-N matrix C with 00022 * 00023 * SIDE = 'L' SIDE = 'R' 00024 * TRANS = 'N': Q * C C * Q 00025 * TRANS = 'T': Q**T * C C * Q**T 00026 * 00027 * where Q is a real orthogonal matrix of order nq, with nq = m if 00028 * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of 00029 * IHI-ILO elementary reflectors, as returned by SGEHRD: 00030 * 00031 * Q = H(ilo) H(ilo+1) . . . H(ihi-1). 00032 * 00033 * Arguments 00034 * ========= 00035 * 00036 * SIDE (input) CHARACTER*1 00037 * = 'L': apply Q or Q**T from the Left; 00038 * = 'R': apply Q or Q**T from the Right. 00039 * 00040 * TRANS (input) CHARACTER*1 00041 * = 'N': No transpose, apply Q; 00042 * = 'T': Transpose, apply Q**T. 00043 * 00044 * M (input) INTEGER 00045 * The number of rows of the matrix C. M >= 0. 00046 * 00047 * N (input) INTEGER 00048 * The number of columns of the matrix C. N >= 0. 00049 * 00050 * ILO (input) INTEGER 00051 * IHI (input) INTEGER 00052 * ILO and IHI must have the same values as in the previous call 00053 * of SGEHRD. Q is equal to the unit matrix except in the 00054 * submatrix Q(ilo+1:ihi,ilo+1:ihi). 00055 * If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and 00056 * ILO = 1 and IHI = 0, if M = 0; 00057 * if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and 00058 * ILO = 1 and IHI = 0, if N = 0. 00059 * 00060 * A (input) REAL array, dimension 00061 * (LDA,M) if SIDE = 'L' 00062 * (LDA,N) if SIDE = 'R' 00063 * The vectors which define the elementary reflectors, as 00064 * returned by SGEHRD. 00065 * 00066 * LDA (input) INTEGER 00067 * The leading dimension of the array A. 00068 * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. 00069 * 00070 * TAU (input) REAL array, dimension 00071 * (M-1) if SIDE = 'L' 00072 * (N-1) if SIDE = 'R' 00073 * TAU(i) must contain the scalar factor of the elementary 00074 * reflector H(i), as returned by SGEHRD. 00075 * 00076 * C (input/output) REAL array, dimension (LDC,N) 00077 * On entry, the M-by-N matrix C. 00078 * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. 00079 * 00080 * LDC (input) INTEGER 00081 * The leading dimension of the array C. LDC >= max(1,M). 00082 * 00083 * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) 00084 * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. 00085 * 00086 * LWORK (input) INTEGER 00087 * The dimension of the array WORK. 00088 * If SIDE = 'L', LWORK >= max(1,N); 00089 * if SIDE = 'R', LWORK >= max(1,M). 00090 * For optimum performance LWORK >= N*NB if SIDE = 'L', and 00091 * LWORK >= M*NB if SIDE = 'R', where NB is the optimal 00092 * blocksize. 00093 * 00094 * If LWORK = -1, then a workspace query is assumed; the routine 00095 * only calculates the optimal size of the WORK array, returns 00096 * this value as the first entry of the WORK array, and no error 00097 * message related to LWORK is issued by XERBLA. 00098 * 00099 * INFO (output) INTEGER 00100 * = 0: successful exit 00101 * < 0: if INFO = -i, the i-th argument had an illegal value 00102 * 00103 * ===================================================================== 00104 * 00105 * .. Local Scalars .. 00106 LOGICAL LEFT, LQUERY 00107 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW 00108 * .. 00109 * .. External Functions .. 00110 LOGICAL LSAME 00111 INTEGER ILAENV 00112 EXTERNAL ILAENV, LSAME 00113 * .. 00114 * .. External Subroutines .. 00115 EXTERNAL SORMQR, XERBLA 00116 * .. 00117 * .. Intrinsic Functions .. 00118 INTRINSIC MAX, MIN 00119 * .. 00120 * .. Executable Statements .. 00121 * 00122 * Test the input arguments 00123 * 00124 INFO = 0 00125 NH = IHI - ILO 00126 LEFT = LSAME( SIDE, 'L' ) 00127 LQUERY = ( LWORK.EQ.-1 ) 00128 * 00129 * NQ is the order of Q and NW is the minimum dimension of WORK 00130 * 00131 IF( LEFT ) THEN 00132 NQ = M 00133 NW = N 00134 ELSE 00135 NQ = N 00136 NW = M 00137 END IF 00138 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 00139 INFO = -1 00140 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) 00141 $ THEN 00142 INFO = -2 00143 ELSE IF( M.LT.0 ) THEN 00144 INFO = -3 00145 ELSE IF( N.LT.0 ) THEN 00146 INFO = -4 00147 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN 00148 INFO = -5 00149 ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN 00150 INFO = -6 00151 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 00152 INFO = -8 00153 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 00154 INFO = -11 00155 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN 00156 INFO = -13 00157 END IF 00158 * 00159 IF( INFO.EQ.0 ) THEN 00160 IF( LEFT ) THEN 00161 NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, NH, N, NH, -1 ) 00162 ELSE 00163 NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, NH, NH, -1 ) 00164 END IF 00165 LWKOPT = MAX( 1, NW )*NB 00166 WORK( 1 ) = LWKOPT 00167 END IF 00168 * 00169 IF( INFO.NE.0 ) THEN 00170 CALL XERBLA( 'SORMHR', -INFO ) 00171 RETURN 00172 ELSE IF( LQUERY ) THEN 00173 RETURN 00174 END IF 00175 * 00176 * Quick return if possible 00177 * 00178 IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN 00179 WORK( 1 ) = 1 00180 RETURN 00181 END IF 00182 * 00183 IF( LEFT ) THEN 00184 MI = NH 00185 NI = N 00186 I1 = ILO + 1 00187 I2 = 1 00188 ELSE 00189 MI = M 00190 NI = NH 00191 I1 = 1 00192 I2 = ILO + 1 00193 END IF 00194 * 00195 CALL SORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA, 00196 $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO ) 00197 * 00198 WORK( 1 ) = LWKOPT 00199 RETURN 00200 * 00201 * End of SORMHR 00202 * 00203 END
1.7.3 
