LAPACK  3.7.1
LAPACK: Linear Algebra PACKage
slaqtr.f
Go to the documentation of this file.
1 *> \brief \b SLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of special form, in real arithmetic.
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download SLAQTR + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slaqtr.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slaqtr.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slaqtr.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK,
22 * INFO )
23 *
24 * .. Scalar Arguments ..
25 * LOGICAL LREAL, LTRAN
26 * INTEGER INFO, LDT, N
27 * REAL SCALE, W
28 * ..
29 * .. Array Arguments ..
30 * REAL B( * ), T( LDT, * ), WORK( * ), X( * )
31 * ..
32 *
33 *
34 *> \par Purpose:
35 * =============
36 *>
37 *> \verbatim
38 *>
39 *> SLAQTR solves the real quasi-triangular system
40 *>
41 *> op(T)*p = scale*c, if LREAL = .TRUE.
42 *>
43 *> or the complex quasi-triangular systems
44 *>
45 *> op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.
46 *>
47 *> in real arithmetic, where T is upper quasi-triangular.
48 *> If LREAL = .FALSE., then the first diagonal block of T must be
49 *> 1 by 1, B is the specially structured matrix
50 *>
51 *> B = [ b(1) b(2) ... b(n) ]
52 *> [ w ]
53 *> [ w ]
54 *> [ . ]
55 *> [ w ]
56 *>
57 *> op(A) = A or A**T, A**T denotes the transpose of
58 *> matrix A.
59 *>
60 *> On input, X = [ c ]. On output, X = [ p ].
61 *> [ d ] [ q ]
62 *>
63 *> This subroutine is designed for the condition number estimation
64 *> in routine STRSNA.
65 *> \endverbatim
66 *
67 * Arguments:
68 * ==========
69 *
70 *> \param[in] LTRAN
71 *> \verbatim
72 *> LTRAN is LOGICAL
73 *> On entry, LTRAN specifies the option of conjugate transpose:
74 *> = .FALSE., op(T+i*B) = T+i*B,
75 *> = .TRUE., op(T+i*B) = (T+i*B)**T.
76 *> \endverbatim
77 *>
78 *> \param[in] LREAL
79 *> \verbatim
80 *> LREAL is LOGICAL
81 *> On entry, LREAL specifies the input matrix structure:
82 *> = .FALSE., the input is complex
83 *> = .TRUE., the input is real
84 *> \endverbatim
85 *>
86 *> \param[in] N
87 *> \verbatim
88 *> N is INTEGER
89 *> On entry, N specifies the order of T+i*B. N >= 0.
90 *> \endverbatim
91 *>
92 *> \param[in] T
93 *> \verbatim
94 *> T is REAL array, dimension (LDT,N)
95 *> On entry, T contains a matrix in Schur canonical form.
96 *> If LREAL = .FALSE., then the first diagonal block of T must
97 *> be 1 by 1.
98 *> \endverbatim
99 *>
100 *> \param[in] LDT
101 *> \verbatim
102 *> LDT is INTEGER
103 *> The leading dimension of the matrix T. LDT >= max(1,N).
104 *> \endverbatim
105 *>
106 *> \param[in] B
107 *> \verbatim
108 *> B is REAL array, dimension (N)
109 *> On entry, B contains the elements to form the matrix
110 *> B as described above.
111 *> If LREAL = .TRUE., B is not referenced.
112 *> \endverbatim
113 *>
114 *> \param[in] W
115 *> \verbatim
116 *> W is REAL
117 *> On entry, W is the diagonal element of the matrix B.
118 *> If LREAL = .TRUE., W is not referenced.
119 *> \endverbatim
120 *>
121 *> \param[out] SCALE
122 *> \verbatim
123 *> SCALE is REAL
124 *> On exit, SCALE is the scale factor.
125 *> \endverbatim
126 *>
127 *> \param[in,out] X
128 *> \verbatim
129 *> X is REAL array, dimension (2*N)
130 *> On entry, X contains the right hand side of the system.
131 *> On exit, X is overwritten by the solution.
132 *> \endverbatim
133 *>
134 *> \param[out] WORK
135 *> \verbatim
136 *> WORK is REAL array, dimension (N)
137 *> \endverbatim
138 *>
139 *> \param[out] INFO
140 *> \verbatim
141 *> INFO is INTEGER
142 *> On exit, INFO is set to
143 *> 0: successful exit.
144 *> 1: the some diagonal 1 by 1 block has been perturbed by
145 *> a small number SMIN to keep nonsingularity.
146 *> 2: the some diagonal 2 by 2 block has been perturbed by
147 *> a small number in SLALN2 to keep nonsingularity.
148 *> NOTE: In the interests of speed, this routine does not
149 *> check the inputs for errors.
150 *> \endverbatim
151 *
152 * Authors:
153 * ========
154 *
155 *> \author Univ. of Tennessee
156 *> \author Univ. of California Berkeley
157 *> \author Univ. of Colorado Denver
158 *> \author NAG Ltd.
159 *
160 *> \date December 2016
161 *
162 *> \ingroup realOTHERauxiliary
163 *
164 * =====================================================================
165  SUBROUTINE slaqtr( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK,
166  $ INFO )
167 *
168 * -- LAPACK auxiliary routine (version 3.7.0) --
169 * -- LAPACK is a software package provided by Univ. of Tennessee, --
170 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
171 * December 2016
172 *
173 * .. Scalar Arguments ..
174  LOGICAL LREAL, LTRAN
175  INTEGER INFO, LDT, N
176  REAL SCALE, W
177 * ..
178 * .. Array Arguments ..
179  REAL B( * ), T( ldt, * ), WORK( * ), X( * )
180 * ..
181 *
182 * =====================================================================
183 *
184 * .. Parameters ..
185  REAL ZERO, ONE
186  parameter( zero = 0.0e+0, one = 1.0e+0 )
187 * ..
188 * .. Local Scalars ..
189  LOGICAL NOTRAN
190  INTEGER I, IERR, J, J1, J2, JNEXT, K, N1, N2
191  REAL BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW,
192  $ smlnum, sr, tjj, tmp, xj, xmax, xnorm, z
193 * ..
194 * .. Local Arrays ..
195  REAL D( 2, 2 ), V( 2, 2 )
196 * ..
197 * .. External Functions ..
198  INTEGER ISAMAX
199  REAL SASUM, SDOT, SLAMCH, SLANGE
200  EXTERNAL isamax, sasum, sdot, slamch, slange
201 * ..
202 * .. External Subroutines ..
203  EXTERNAL saxpy, sladiv, slaln2, sscal
204 * ..
205 * .. Intrinsic Functions ..
206  INTRINSIC abs, max
207 * ..
208 * .. Executable Statements ..
209 *
210 * Do not test the input parameters for errors
211 *
212  notran = .NOT.ltran
213  info = 0
214 *
215 * Quick return if possible
216 *
217  IF( n.EQ.0 )
218  $ RETURN
219 *
220 * Set constants to control overflow
221 *
222  eps = slamch( 'P' )
223  smlnum = slamch( 'S' ) / eps
224  bignum = one / smlnum
225 *
226  xnorm = slange( 'M', n, n, t, ldt, d )
227  IF( .NOT.lreal )
228  $ xnorm = max( xnorm, abs( w ), slange( 'M', n, 1, b, n, d ) )
229  smin = max( smlnum, eps*xnorm )
230 *
231 * Compute 1-norm of each column of strictly upper triangular
232 * part of T to control overflow in triangular solver.
233 *
234  work( 1 ) = zero
235  DO 10 j = 2, n
236  work( j ) = sasum( j-1, t( 1, j ), 1 )
237  10 CONTINUE
238 *
239  IF( .NOT.lreal ) THEN
240  DO 20 i = 2, n
241  work( i ) = work( i ) + abs( b( i ) )
242  20 CONTINUE
243  END IF
244 *
245  n2 = 2*n
246  n1 = n
247  IF( .NOT.lreal )
248  $ n1 = n2
249  k = isamax( n1, x, 1 )
250  xmax = abs( x( k ) )
251  scale = one
252 *
253  IF( xmax.GT.bignum ) THEN
254  scale = bignum / xmax
255  CALL sscal( n1, scale, x, 1 )
256  xmax = bignum
257  END IF
258 *
259  IF( lreal ) THEN
260 *
261  IF( notran ) THEN
262 *
263 * Solve T*p = scale*c
264 *
265  jnext = n
266  DO 30 j = n, 1, -1
267  IF( j.GT.jnext )
268  $ GO TO 30
269  j1 = j
270  j2 = j
271  jnext = j - 1
272  IF( j.GT.1 ) THEN
273  IF( t( j, j-1 ).NE.zero ) THEN
274  j1 = j - 1
275  jnext = j - 2
276  END IF
277  END IF
278 *
279  IF( j1.EQ.j2 ) THEN
280 *
281 * Meet 1 by 1 diagonal block
282 *
283 * Scale to avoid overflow when computing
284 * x(j) = b(j)/T(j,j)
285 *
286  xj = abs( x( j1 ) )
287  tjj = abs( t( j1, j1 ) )
288  tmp = t( j1, j1 )
289  IF( tjj.LT.smin ) THEN
290  tmp = smin
291  tjj = smin
292  info = 1
293  END IF
294 *
295  IF( xj.EQ.zero )
296  $ GO TO 30
297 *
298  IF( tjj.LT.one ) THEN
299  IF( xj.GT.bignum*tjj ) THEN
300  rec = one / xj
301  CALL sscal( n, rec, x, 1 )
302  scale = scale*rec
303  xmax = xmax*rec
304  END IF
305  END IF
306  x( j1 ) = x( j1 ) / tmp
307  xj = abs( x( j1 ) )
308 *
309 * Scale x if necessary to avoid overflow when adding a
310 * multiple of column j1 of T.
311 *
312  IF( xj.GT.one ) THEN
313  rec = one / xj
314  IF( work( j1 ).GT.( bignum-xmax )*rec ) THEN
315  CALL sscal( n, rec, x, 1 )
316  scale = scale*rec
317  END IF
318  END IF
319  IF( j1.GT.1 ) THEN
320  CALL saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 )
321  k = isamax( j1-1, x, 1 )
322  xmax = abs( x( k ) )
323  END IF
324 *
325  ELSE
326 *
327 * Meet 2 by 2 diagonal block
328 *
329 * Call 2 by 2 linear system solve, to take
330 * care of possible overflow by scaling factor.
331 *
332  d( 1, 1 ) = x( j1 )
333  d( 2, 1 ) = x( j2 )
334  CALL slaln2( .false., 2, 1, smin, one, t( j1, j1 ),
335  $ ldt, one, one, d, 2, zero, zero, v, 2,
336  $ scaloc, xnorm, ierr )
337  IF( ierr.NE.0 )
338  $ info = 2
339 *
340  IF( scaloc.NE.one ) THEN
341  CALL sscal( n, scaloc, x, 1 )
342  scale = scale*scaloc
343  END IF
344  x( j1 ) = v( 1, 1 )
345  x( j2 ) = v( 2, 1 )
346 *
347 * Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2))
348 * to avoid overflow in updating right-hand side.
349 *
350  xj = max( abs( v( 1, 1 ) ), abs( v( 2, 1 ) ) )
351  IF( xj.GT.one ) THEN
352  rec = one / xj
353  IF( max( work( j1 ), work( j2 ) ).GT.
354  $ ( bignum-xmax )*rec ) THEN
355  CALL sscal( n, rec, x, 1 )
356  scale = scale*rec
357  END IF
358  END IF
359 *
360 * Update right-hand side
361 *
362  IF( j1.GT.1 ) THEN
363  CALL saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 )
364  CALL saxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 )
365  k = isamax( j1-1, x, 1 )
366  xmax = abs( x( k ) )
367  END IF
368 *
369  END IF
370 *
371  30 CONTINUE
372 *
373  ELSE
374 *
375 * Solve T**T*p = scale*c
376 *
377  jnext = 1
378  DO 40 j = 1, n
379  IF( j.LT.jnext )
380  $ GO TO 40
381  j1 = j
382  j2 = j
383  jnext = j + 1
384  IF( j.LT.n ) THEN
385  IF( t( j+1, j ).NE.zero ) THEN
386  j2 = j + 1
387  jnext = j + 2
388  END IF
389  END IF
390 *
391  IF( j1.EQ.j2 ) THEN
392 *
393 * 1 by 1 diagonal block
394 *
395 * Scale if necessary to avoid overflow in forming the
396 * right-hand side element by inner product.
397 *
398  xj = abs( x( j1 ) )
399  IF( xmax.GT.one ) THEN
400  rec = one / xmax
401  IF( work( j1 ).GT.( bignum-xj )*rec ) THEN
402  CALL sscal( n, rec, x, 1 )
403  scale = scale*rec
404  xmax = xmax*rec
405  END IF
406  END IF
407 *
408  x( j1 ) = x( j1 ) - sdot( j1-1, t( 1, j1 ), 1, x, 1 )
409 *
410  xj = abs( x( j1 ) )
411  tjj = abs( t( j1, j1 ) )
412  tmp = t( j1, j1 )
413  IF( tjj.LT.smin ) THEN
414  tmp = smin
415  tjj = smin
416  info = 1
417  END IF
418 *
419  IF( tjj.LT.one ) THEN
420  IF( xj.GT.bignum*tjj ) THEN
421  rec = one / xj
422  CALL sscal( n, rec, x, 1 )
423  scale = scale*rec
424  xmax = xmax*rec
425  END IF
426  END IF
427  x( j1 ) = x( j1 ) / tmp
428  xmax = max( xmax, abs( x( j1 ) ) )
429 *
430  ELSE
431 *
432 * 2 by 2 diagonal block
433 *
434 * Scale if necessary to avoid overflow in forming the
435 * right-hand side elements by inner product.
436 *
437  xj = max( abs( x( j1 ) ), abs( x( j2 ) ) )
438  IF( xmax.GT.one ) THEN
439  rec = one / xmax
440  IF( max( work( j2 ), work( j1 ) ).GT.( bignum-xj )*
441  $ rec ) THEN
442  CALL sscal( n, rec, x, 1 )
443  scale = scale*rec
444  xmax = xmax*rec
445  END IF
446  END IF
447 *
448  d( 1, 1 ) = x( j1 ) - sdot( j1-1, t( 1, j1 ), 1, x,
449  $ 1 )
450  d( 2, 1 ) = x( j2 ) - sdot( j1-1, t( 1, j2 ), 1, x,
451  $ 1 )
452 *
453  CALL slaln2( .true., 2, 1, smin, one, t( j1, j1 ),
454  $ ldt, one, one, d, 2, zero, zero, v, 2,
455  $ scaloc, xnorm, ierr )
456  IF( ierr.NE.0 )
457  $ info = 2
458 *
459  IF( scaloc.NE.one ) THEN
460  CALL sscal( n, scaloc, x, 1 )
461  scale = scale*scaloc
462  END IF
463  x( j1 ) = v( 1, 1 )
464  x( j2 ) = v( 2, 1 )
465  xmax = max( abs( x( j1 ) ), abs( x( j2 ) ), xmax )
466 *
467  END IF
468  40 CONTINUE
469  END IF
470 *
471  ELSE
472 *
473  sminw = max( eps*abs( w ), smin )
474  IF( notran ) THEN
475 *
476 * Solve (T + iB)*(p+iq) = c+id
477 *
478  jnext = n
479  DO 70 j = n, 1, -1
480  IF( j.GT.jnext )
481  $ GO TO 70
482  j1 = j
483  j2 = j
484  jnext = j - 1
485  IF( j.GT.1 ) THEN
486  IF( t( j, j-1 ).NE.zero ) THEN
487  j1 = j - 1
488  jnext = j - 2
489  END IF
490  END IF
491 *
492  IF( j1.EQ.j2 ) THEN
493 *
494 * 1 by 1 diagonal block
495 *
496 * Scale if necessary to avoid overflow in division
497 *
498  z = w
499  IF( j1.EQ.1 )
500  $ z = b( 1 )
501  xj = abs( x( j1 ) ) + abs( x( n+j1 ) )
502  tjj = abs( t( j1, j1 ) ) + abs( z )
503  tmp = t( j1, j1 )
504  IF( tjj.LT.sminw ) THEN
505  tmp = sminw
506  tjj = sminw
507  info = 1
508  END IF
509 *
510  IF( xj.EQ.zero )
511  $ GO TO 70
512 *
513  IF( tjj.LT.one ) THEN
514  IF( xj.GT.bignum*tjj ) THEN
515  rec = one / xj
516  CALL sscal( n2, rec, x, 1 )
517  scale = scale*rec
518  xmax = xmax*rec
519  END IF
520  END IF
521  CALL sladiv( x( j1 ), x( n+j1 ), tmp, z, sr, si )
522  x( j1 ) = sr
523  x( n+j1 ) = si
524  xj = abs( x( j1 ) ) + abs( x( n+j1 ) )
525 *
526 * Scale x if necessary to avoid overflow when adding a
527 * multiple of column j1 of T.
528 *
529  IF( xj.GT.one ) THEN
530  rec = one / xj
531  IF( work( j1 ).GT.( bignum-xmax )*rec ) THEN
532  CALL sscal( n2, rec, x, 1 )
533  scale = scale*rec
534  END IF
535  END IF
536 *
537  IF( j1.GT.1 ) THEN
538  CALL saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 )
539  CALL saxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,
540  $ x( n+1 ), 1 )
541 *
542  x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 )
543  x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 )
544 *
545  xmax = zero
546  DO 50 k = 1, j1 - 1
547  xmax = max( xmax, abs( x( k ) )+
548  $ abs( x( k+n ) ) )
549  50 CONTINUE
550  END IF
551 *
552  ELSE
553 *
554 * Meet 2 by 2 diagonal block
555 *
556  d( 1, 1 ) = x( j1 )
557  d( 2, 1 ) = x( j2 )
558  d( 1, 2 ) = x( n+j1 )
559  d( 2, 2 ) = x( n+j2 )
560  CALL slaln2( .false., 2, 2, sminw, one, t( j1, j1 ),
561  $ ldt, one, one, d, 2, zero, -w, v, 2,
562  $ scaloc, xnorm, ierr )
563  IF( ierr.NE.0 )
564  $ info = 2
565 *
566  IF( scaloc.NE.one ) THEN
567  CALL sscal( 2*n, scaloc, x, 1 )
568  scale = scaloc*scale
569  END IF
570  x( j1 ) = v( 1, 1 )
571  x( j2 ) = v( 2, 1 )
572  x( n+j1 ) = v( 1, 2 )
573  x( n+j2 ) = v( 2, 2 )
574 *
575 * Scale X(J1), .... to avoid overflow in
576 * updating right hand side.
577 *
578  xj = max( abs( v( 1, 1 ) )+abs( v( 1, 2 ) ),
579  $ abs( v( 2, 1 ) )+abs( v( 2, 2 ) ) )
580  IF( xj.GT.one ) THEN
581  rec = one / xj
582  IF( max( work( j1 ), work( j2 ) ).GT.
583  $ ( bignum-xmax )*rec ) THEN
584  CALL sscal( n2, rec, x, 1 )
585  scale = scale*rec
586  END IF
587  END IF
588 *
589 * Update the right-hand side.
590 *
591  IF( j1.GT.1 ) THEN
592  CALL saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 )
593  CALL saxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 )
594 *
595  CALL saxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,
596  $ x( n+1 ), 1 )
597  CALL saxpy( j1-1, -x( n+j2 ), t( 1, j2 ), 1,
598  $ x( n+1 ), 1 )
599 *
600  x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) +
601  $ b( j2 )*x( n+j2 )
602  x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) -
603  $ b( j2 )*x( j2 )
604 *
605  xmax = zero
606  DO 60 k = 1, j1 - 1
607  xmax = max( abs( x( k ) )+abs( x( k+n ) ),
608  $ xmax )
609  60 CONTINUE
610  END IF
611 *
612  END IF
613  70 CONTINUE
614 *
615  ELSE
616 *
617 * Solve (T + iB)**T*(p+iq) = c+id
618 *
619  jnext = 1
620  DO 80 j = 1, n
621  IF( j.LT.jnext )
622  $ GO TO 80
623  j1 = j
624  j2 = j
625  jnext = j + 1
626  IF( j.LT.n ) THEN
627  IF( t( j+1, j ).NE.zero ) THEN
628  j2 = j + 1
629  jnext = j + 2
630  END IF
631  END IF
632 *
633  IF( j1.EQ.j2 ) THEN
634 *
635 * 1 by 1 diagonal block
636 *
637 * Scale if necessary to avoid overflow in forming the
638 * right-hand side element by inner product.
639 *
640  xj = abs( x( j1 ) ) + abs( x( j1+n ) )
641  IF( xmax.GT.one ) THEN
642  rec = one / xmax
643  IF( work( j1 ).GT.( bignum-xj )*rec ) THEN
644  CALL sscal( n2, rec, x, 1 )
645  scale = scale*rec
646  xmax = xmax*rec
647  END IF
648  END IF
649 *
650  x( j1 ) = x( j1 ) - sdot( j1-1, t( 1, j1 ), 1, x, 1 )
651  x( n+j1 ) = x( n+j1 ) - sdot( j1-1, t( 1, j1 ), 1,
652  $ x( n+1 ), 1 )
653  IF( j1.GT.1 ) THEN
654  x( j1 ) = x( j1 ) - b( j1 )*x( n+1 )
655  x( n+j1 ) = x( n+j1 ) + b( j1 )*x( 1 )
656  END IF
657  xj = abs( x( j1 ) ) + abs( x( j1+n ) )
658 *
659  z = w
660  IF( j1.EQ.1 )
661  $ z = b( 1 )
662 *
663 * Scale if necessary to avoid overflow in
664 * complex division
665 *
666  tjj = abs( t( j1, j1 ) ) + abs( z )
667  tmp = t( j1, j1 )
668  IF( tjj.LT.sminw ) THEN
669  tmp = sminw
670  tjj = sminw
671  info = 1
672  END IF
673 *
674  IF( tjj.LT.one ) THEN
675  IF( xj.GT.bignum*tjj ) THEN
676  rec = one / xj
677  CALL sscal( n2, rec, x, 1 )
678  scale = scale*rec
679  xmax = xmax*rec
680  END IF
681  END IF
682  CALL sladiv( x( j1 ), x( n+j1 ), tmp, -z, sr, si )
683  x( j1 ) = sr
684  x( j1+n ) = si
685  xmax = max( abs( x( j1 ) )+abs( x( j1+n ) ), xmax )
686 *
687  ELSE
688 *
689 * 2 by 2 diagonal block
690 *
691 * Scale if necessary to avoid overflow in forming the
692 * right-hand side element by inner product.
693 *
694  xj = max( abs( x( j1 ) )+abs( x( n+j1 ) ),
695  $ abs( x( j2 ) )+abs( x( n+j2 ) ) )
696  IF( xmax.GT.one ) THEN
697  rec = one / xmax
698  IF( max( work( j1 ), work( j2 ) ).GT.
699  $ ( bignum-xj ) / xmax ) THEN
700  CALL sscal( n2, rec, x, 1 )
701  scale = scale*rec
702  xmax = xmax*rec
703  END IF
704  END IF
705 *
706  d( 1, 1 ) = x( j1 ) - sdot( j1-1, t( 1, j1 ), 1, x,
707  $ 1 )
708  d( 2, 1 ) = x( j2 ) - sdot( j1-1, t( 1, j2 ), 1, x,
709  $ 1 )
710  d( 1, 2 ) = x( n+j1 ) - sdot( j1-1, t( 1, j1 ), 1,
711  $ x( n+1 ), 1 )
712  d( 2, 2 ) = x( n+j2 ) - sdot( j1-1, t( 1, j2 ), 1,
713  $ x( n+1 ), 1 )
714  d( 1, 1 ) = d( 1, 1 ) - b( j1 )*x( n+1 )
715  d( 2, 1 ) = d( 2, 1 ) - b( j2 )*x( n+1 )
716  d( 1, 2 ) = d( 1, 2 ) + b( j1 )*x( 1 )
717  d( 2, 2 ) = d( 2, 2 ) + b( j2 )*x( 1 )
718 *
719  CALL slaln2( .true., 2, 2, sminw, one, t( j1, j1 ),
720  $ ldt, one, one, d, 2, zero, w, v, 2,
721  $ scaloc, xnorm, ierr )
722  IF( ierr.NE.0 )
723  $ info = 2
724 *
725  IF( scaloc.NE.one ) THEN
726  CALL sscal( n2, scaloc, x, 1 )
727  scale = scaloc*scale
728  END IF
729  x( j1 ) = v( 1, 1 )
730  x( j2 ) = v( 2, 1 )
731  x( n+j1 ) = v( 1, 2 )
732  x( n+j2 ) = v( 2, 2 )
733  xmax = max( abs( x( j1 ) )+abs( x( n+j1 ) ),
734  $ abs( x( j2 ) )+abs( x( n+j2 ) ), xmax )
735 *
736  END IF
737 *
738  80 CONTINUE
739 *
740  END IF
741 *
742  END IF
743 *
744  RETURN
745 *
746 * End of SLAQTR
747 *
748  END
sladiv
subroutine sladiv(A, B, C, D, P, Q)
SLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
Definition: sladiv.f:93
slaln2
subroutine slaln2(LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, LDB, WR, WI, X, LDX, SCALE, XNORM, INFO)
SLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form.
Definition: slaln2.f:220
saxpy
subroutine saxpy(N, SA, SX, INCX, SY, INCY)
SAXPY
Definition: saxpy.f:91
sscal
subroutine sscal(N, SA, SX, INCX)
SSCAL
Definition: sscal.f:81
slaqtr
subroutine slaqtr(LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO)
SLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of sp...
Definition: slaqtr.f:167