```001:       SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
002:      \$                   LDQ, Z, LDZ, INFO )
003: *
004: *  -- LAPACK routine (version 3.2) --
005: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
006: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
007: *     November 2006
008: *
009: *     .. Scalar Arguments ..
010:       CHARACTER          COMPQ, COMPZ
011:       INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
012: *     ..
013: *     .. Array Arguments ..
014:       REAL               A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
015:      \$                   Z( LDZ, * )
016: *     ..
017: *
018: *  Purpose
019: *  =======
020: *
021: *  SGGHRD reduces a pair of real matrices (A,B) to generalized upper
022: *  Hessenberg form using orthogonal transformations, where A is a
023: *  general matrix and B is upper triangular.  The form of the
024: *  generalized eigenvalue problem is
025: *     A*x = lambda*B*x,
026: *  and B is typically made upper triangular by computing its QR
027: *  factorization and moving the orthogonal matrix Q to the left side
028: *  of the equation.
029: *
030: *  This subroutine simultaneously reduces A to a Hessenberg matrix H:
031: *     Q**T*A*Z = H
032: *  and transforms B to another upper triangular matrix T:
033: *     Q**T*B*Z = T
034: *  in order to reduce the problem to its standard form
035: *     H*y = lambda*T*y
036: *  where y = Z**T*x.
037: *
038: *  The orthogonal matrices Q and Z are determined as products of Givens
039: *  rotations.  They may either be formed explicitly, or they may be
040: *  postmultiplied into input matrices Q1 and Z1, so that
041: *
042: *       Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T
043: *
044: *       Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T
045: *
046: *  If Q1 is the orthogonal matrix from the QR factorization of B in the
047: *  original equation A*x = lambda*B*x, then SGGHRD reduces the original
048: *  problem to generalized Hessenberg form.
049: *
050: *  Arguments
051: *  =========
052: *
053: *  COMPQ   (input) CHARACTER*1
054: *          = 'N': do not compute Q;
055: *          = 'I': Q is initialized to the unit matrix, and the
056: *                 orthogonal matrix Q is returned;
057: *          = 'V': Q must contain an orthogonal matrix Q1 on entry,
058: *                 and the product Q1*Q is returned.
059: *
060: *  COMPZ   (input) CHARACTER*1
061: *          = 'N': do not compute Z;
062: *          = 'I': Z is initialized to the unit matrix, and the
063: *                 orthogonal matrix Z is returned;
064: *          = 'V': Z must contain an orthogonal matrix Z1 on entry,
065: *                 and the product Z1*Z is returned.
066: *
067: *  N       (input) INTEGER
068: *          The order of the matrices A and B.  N >= 0.
069: *
070: *  ILO     (input) INTEGER
071: *  IHI     (input) INTEGER
072: *          ILO and IHI mark the rows and columns of A which are to be
073: *          reduced.  It is assumed that A is already upper triangular
074: *          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are
075: *          normally set by a previous call to SGGBAL; otherwise they
076: *          should be set to 1 and N respectively.
077: *          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
078: *
079: *  A       (input/output) REAL array, dimension (LDA, N)
080: *          On entry, the N-by-N general matrix to be reduced.
081: *          On exit, the upper triangle and the first subdiagonal of A
082: *          are overwritten with the upper Hessenberg matrix H, and the
083: *          rest is set to zero.
084: *
085: *  LDA     (input) INTEGER
086: *          The leading dimension of the array A.  LDA >= max(1,N).
087: *
088: *  B       (input/output) REAL array, dimension (LDB, N)
089: *          On entry, the N-by-N upper triangular matrix B.
090: *          On exit, the upper triangular matrix T = Q**T B Z.  The
091: *          elements below the diagonal are set to zero.
092: *
093: *  LDB     (input) INTEGER
094: *          The leading dimension of the array B.  LDB >= max(1,N).
095: *
096: *  Q       (input/output) REAL array, dimension (LDQ, N)
097: *          On entry, if COMPQ = 'V', the orthogonal matrix Q1,
098: *          typically from the QR factorization of B.
099: *          On exit, if COMPQ='I', the orthogonal matrix Q, and if
100: *          COMPQ = 'V', the product Q1*Q.
101: *          Not referenced if COMPQ='N'.
102: *
103: *  LDQ     (input) INTEGER
104: *          The leading dimension of the array Q.
105: *          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
106: *
107: *  Z       (input/output) REAL array, dimension (LDZ, N)
108: *          On entry, if COMPZ = 'V', the orthogonal matrix Z1.
109: *          On exit, if COMPZ='I', the orthogonal matrix Z, and if
110: *          COMPZ = 'V', the product Z1*Z.
111: *          Not referenced if COMPZ='N'.
112: *
113: *  LDZ     (input) INTEGER
114: *          The leading dimension of the array Z.
115: *          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
116: *
117: *  INFO    (output) INTEGER
118: *          = 0:  successful exit.
119: *          < 0:  if INFO = -i, the i-th argument had an illegal value.
120: *
121: *  Further Details
122: *  ===============
123: *
124: *  This routine reduces A to Hessenberg and B to triangular form by
125: *  an unblocked reduction, as described in _Matrix_Computations_,
126: *  by Golub and Van Loan (Johns Hopkins Press.)
127: *
128: *  =====================================================================
129: *
130: *     .. Parameters ..
131:       REAL               ONE, ZERO
132:       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
133: *     ..
134: *     .. Local Scalars ..
135:       LOGICAL            ILQ, ILZ
136:       INTEGER            ICOMPQ, ICOMPZ, JCOL, JROW
137:       REAL               C, S, TEMP
138: *     ..
139: *     .. External Functions ..
140:       LOGICAL            LSAME
141:       EXTERNAL           LSAME
142: *     ..
143: *     .. External Subroutines ..
144:       EXTERNAL           SLARTG, SLASET, SROT, XERBLA
145: *     ..
146: *     .. Intrinsic Functions ..
147:       INTRINSIC          MAX
148: *     ..
149: *     .. Executable Statements ..
150: *
151: *     Decode COMPQ
152: *
153:       IF( LSAME( COMPQ, 'N' ) ) THEN
154:          ILQ = .FALSE.
155:          ICOMPQ = 1
156:       ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
157:          ILQ = .TRUE.
158:          ICOMPQ = 2
159:       ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
160:          ILQ = .TRUE.
161:          ICOMPQ = 3
162:       ELSE
163:          ICOMPQ = 0
164:       END IF
165: *
166: *     Decode COMPZ
167: *
168:       IF( LSAME( COMPZ, 'N' ) ) THEN
169:          ILZ = .FALSE.
170:          ICOMPZ = 1
171:       ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
172:          ILZ = .TRUE.
173:          ICOMPZ = 2
174:       ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
175:          ILZ = .TRUE.
176:          ICOMPZ = 3
177:       ELSE
178:          ICOMPZ = 0
179:       END IF
180: *
181: *     Test the input parameters.
182: *
183:       INFO = 0
184:       IF( ICOMPQ.LE.0 ) THEN
185:          INFO = -1
186:       ELSE IF( ICOMPZ.LE.0 ) THEN
187:          INFO = -2
188:       ELSE IF( N.LT.0 ) THEN
189:          INFO = -3
190:       ELSE IF( ILO.LT.1 ) THEN
191:          INFO = -4
192:       ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
193:          INFO = -5
194:       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
195:          INFO = -7
196:       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
197:          INFO = -9
198:       ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
199:          INFO = -11
200:       ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
201:          INFO = -13
202:       END IF
203:       IF( INFO.NE.0 ) THEN
204:          CALL XERBLA( 'SGGHRD', -INFO )
205:          RETURN
206:       END IF
207: *
208: *     Initialize Q and Z if desired.
209: *
210:       IF( ICOMPQ.EQ.3 )
211:      \$   CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
212:       IF( ICOMPZ.EQ.3 )
213:      \$   CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
214: *
215: *     Quick return if possible
216: *
217:       IF( N.LE.1 )
218:      \$   RETURN
219: *
220: *     Zero out lower triangle of B
221: *
222:       DO 20 JCOL = 1, N - 1
223:          DO 10 JROW = JCOL + 1, N
224:             B( JROW, JCOL ) = ZERO
225:    10    CONTINUE
226:    20 CONTINUE
227: *
228: *     Reduce A and B
229: *
230:       DO 40 JCOL = ILO, IHI - 2
231: *
232:          DO 30 JROW = IHI, JCOL + 2, -1
233: *
234: *           Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
235: *
236:             TEMP = A( JROW-1, JCOL )
237:             CALL SLARTG( TEMP, A( JROW, JCOL ), C, S,
238:      \$                   A( JROW-1, JCOL ) )
239:             A( JROW, JCOL ) = ZERO
240:             CALL SROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
241:      \$                 A( JROW, JCOL+1 ), LDA, C, S )
242:             CALL SROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
243:      \$                 B( JROW, JROW-1 ), LDB, C, S )
244:             IF( ILQ )
245:      \$         CALL SROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S )
246: *
247: *           Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
248: *
249:             TEMP = B( JROW, JROW )
250:             CALL SLARTG( TEMP, B( JROW, JROW-1 ), C, S,
251:      \$                   B( JROW, JROW ) )
252:             B( JROW, JROW-1 ) = ZERO
253:             CALL SROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
254:             CALL SROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
255:      \$                 S )
256:             IF( ILZ )
257:      \$         CALL SROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
258:    30    CONTINUE
259:    40 CONTINUE
260: *
261:       RETURN
262: *
263: *     End of SGGHRD
264: *
265:       END
266: ```