1        2        3        4        5        6        7        8        9       10       11       12       13       14       15       16       17       18       19       20       21       22       23       24       25       26       27       28       29       30       31       32       33       34       35       36       37       38       39       40       41       42       43       44       45       46       47       48       49       50       51       52       53       54       55       56       57       58       59       60       61       62       63       64       65       66       67       68       69       70       71       72       73       74       75       76       77       78       79       80       81       82       83       84       85       86       87       88       89       90       91       92       93       94       95       96       97       98       99      100      101      102      103      104      105      106      107      108      109      110      111      112      113      114      115      116      117      118      119      120      121      122      123      124      125      126      127      128      129      130      131      132      133      134      135      136      137      138      139      140      141      142      143      144      145      146      147      148      149      150      151      152      153      154      155      156      157      158      159      160      161      162      163      164      165 SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * *  -- LAPACK routine (version 3.2) -- *  -- LAPACK is a software package provided by Univ. of Tennessee,    -- *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- *     November 2006 * *     .. Scalar Arguments ..       INTEGER            IHI, ILO, INFO, LDA, LWORK, N *     .. *     .. Array Arguments ..       DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * ) *     .. * *  Purpose *  ======= * *  DORGHR generates a real orthogonal matrix Q which is defined as the *  product of IHI-ILO elementary reflectors of order N, as returned by *  DGEHRD: * *  Q = H(ilo) H(ilo+1) . . . H(ihi-1). * *  Arguments *  ========= * *  N       (input) INTEGER *          The order of the matrix Q. N >= 0. * *  ILO     (input) INTEGER *  IHI     (input) INTEGER *          ILO and IHI must have the same values as in the previous call *          of DGEHRD. Q is equal to the unit matrix except in the *          submatrix Q(ilo+1:ihi,ilo+1:ihi). *          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * *  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) *          On entry, the vectors which define the elementary reflectors, *          as returned by DGEHRD. *          On exit, the N-by-N orthogonal matrix Q. * *  LDA     (input) INTEGER *          The leading dimension of the array A. LDA >= max(1,N). * *  TAU     (input) DOUBLE PRECISION array, dimension (N-1) *          TAU(i) must contain the scalar factor of the elementary *          reflector H(i), as returned by DGEHRD. * *  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * *  LWORK   (input) INTEGER *          The dimension of the array WORK. LWORK >= IHI-ILO. *          For optimum performance LWORK >= (IHI-ILO)*NB, where NB is *          the optimal blocksize. * *          If LWORK = -1, then a workspace query is assumed; the routine *          only calculates the optimal size of the WORK array, returns *          this value as the first entry of the WORK array, and no error *          message related to LWORK is issued by XERBLA. * *  INFO    (output) INTEGER *          = 0:  successful exit *          < 0:  if INFO = -i, the i-th argument had an illegal value * *  ===================================================================== * *     .. Parameters ..       DOUBLE PRECISION   ZERO, ONE       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 ) *     .. *     .. Local Scalars ..       LOGICAL            LQUERY       INTEGER            I, IINFO, J, LWKOPT, NB, NH *     .. *     .. External Subroutines ..       EXTERNAL           DORGQR, XERBLA *     .. *     .. External Functions ..       INTEGER            ILAENV       EXTERNAL           ILAENV *     .. *     .. Intrinsic Functions ..       INTRINSIC          MAX, MIN *     .. *     .. Executable Statements .. * *     Test the input arguments *       INFO = 0       NH = IHI - ILO       LQUERY = ( LWORK.EQ.-1 )       IF( N.LT.0 ) THEN          INFO = -1       ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN          INFO = -2       ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN          INFO = -3       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN          INFO = -5       ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN          INFO = -8       END IF *       IF( INFO.EQ.0 ) THEN          NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 )          LWKOPT = MAX( 1, NH )*NB          WORK( 1 ) = LWKOPT       END IF *       IF( INFO.NE.0 ) THEN          CALL XERBLA( 'DORGHR', -INFO )          RETURN       ELSE IF( LQUERY ) THEN          RETURN       END IF * *     Quick return if possible *       IF( N.EQ.0 ) THEN          WORK( 1 ) = 1          RETURN       END IF * *     Shift the vectors which define the elementary reflectors one *     column to the right, and set the first ilo and the last n-ihi *     rows and columns to those of the unit matrix *       DO 40 J = IHI, ILO + 1, -1          DO 10 I = 1, J - 1             A( I, J ) = ZERO    10    CONTINUE          DO 20 I = J + 1, IHI             A( I, J ) = A( I, J-1 )    20    CONTINUE          DO 30 I = IHI + 1, N             A( I, J ) = ZERO    30    CONTINUE    40 CONTINUE       DO 60 J = 1, ILO          DO 50 I = 1, N             A( I, J ) = ZERO    50    CONTINUE          A( J, J ) = ONE    60 CONTINUE       DO 80 J = IHI + 1, N          DO 70 I = 1, N             A( I, J ) = ZERO    70    CONTINUE          A( J, J ) = ONE    80 CONTINUE *       IF( NH.GT.0 ) THEN * *        Generate Q(ilo+1:ihi,ilo+1:ihi) *          CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),      \$                WORK, LWORK, IINFO )       END IF       WORK( 1 ) = LWKOPT       RETURN * *     End of DORGHR *       END