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