@@ -250,10 +250,11 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
250
250
PARAMETER ( WANDS = .TRUE. )
251
251
* ..
252
252
* .. Local Scalars ..
253
- LOGICAL DTRONG , WEAK
253
+ LOGICAL STRONG , WEAK
254
254
INTEGER I, IDUM, LINFO, M
255
- DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS,
256
- $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS
255
+ DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORMA, DNORMB, DSCALE,
256
+ $ DSUM, EPS, F, G, SA, SB, SCALE, SMLNUM,
257
+ $ THRESHA, THRESHB
257
258
* ..
258
259
* .. Local Arrays ..
259
260
INTEGER IWORK( LDST )
@@ -293,7 +294,7 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
293
294
END IF
294
295
*
295
296
WEAK = .FALSE.
296
- DTRONG = .FALSE.
297
+ STRONG = .FALSE.
297
298
*
298
299
* Make a local copy of selected block
299
300
*
@@ -310,9 +311,12 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
310
311
DSUM = ONE
311
312
CALL DLACPY( ' Full' , M, M, S, LDST, WORK, M )
312
313
CALL DLASSQ( M* M, WORK, 1 , DSCALE, DSUM )
314
+ DNORMA = DSCALE* SQRT ( DSUM )
315
+ DSCALE = ZERO
316
+ DSUM = ONE
313
317
CALL DLACPY( ' Full' , M, M, T, LDST, WORK, M )
314
318
CALL DLASSQ( M* M, WORK, 1 , DSCALE, DSUM )
315
- DNORM = DSCALE* SQRT ( DSUM )
319
+ DNORMB = DSCALE* SQRT ( DSUM )
316
320
*
317
321
* THRES has been changed from
318
322
* THRESH = MAX( TEN*EPS*SA, SMLNUM )
@@ -322,7 +326,8 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
322
326
* "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by
323
327
* Jim Demmel and Guillaume Revy. See forum post 1783.
324
328
*
325
- THRESH = MAX ( TWENTY* EPS* DNORM, SMLNUM )
329
+ THRESHA = MAX ( TWENTY* EPS* DNORMA, SMLNUM )
330
+ THRESHB = MAX ( TWENTY* EPS* DNORMB, SMLNUM )
326
331
*
327
332
IF ( M.EQ. 2 ) THEN
328
333
*
@@ -333,8 +338,8 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
333
338
*
334
339
F = S( 2 , 2 )* T( 1 , 1 ) - T( 2 , 2 )* S( 1 , 1 )
335
340
G = S( 2 , 2 )* T( 1 , 2 ) - T( 2 , 2 )* S( 1 , 2 )
336
- SB = ABS ( T ( 2 , 2 ) )
337
- SA = ABS ( S( 2 , 2 ) )
341
+ SA = ABS ( S ( 2 , 2 ) ) * ABS ( T( 1 , 1 ) )
342
+ SB = ABS ( S( 1 , 1 ) ) * ABS ( T ( 2 , 2 ) )
338
343
CALL DLARTG( F, G, IR( 1 , 2 ), IR( 1 , 1 ), DDUM )
339
344
IR( 2 , 1 ) = - IR( 1 , 2 )
340
345
IR( 2 , 2 ) = IR( 1 , 1 )
@@ -356,18 +361,20 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
356
361
LI( 2 , 2 ) = LI( 1 , 1 )
357
362
LI( 1 , 2 ) = - LI( 2 , 1 )
358
363
*
359
- * Weak stability test:
360
- * |S21| + |T21| <= O(EPS * F-norm((S, T )))
364
+ * Weak stability test: |S21| <= O(EPS F-norm((A)))
365
+ * and |T21| <= O(EPS F-norm((B )))
361
366
*
362
- WS = ABS ( S( 2 , 1 ) ) + ABS ( T( 2 , 1 ) )
363
- WEAK = WS .LE. THRESH
367
+ WEAK = ABS ( S( 2 , 1 ) ) .LE. THRESHA .AND.
368
+ $ ABS ( T( 2 , 1 ) ) .LE. THRESHB
364
369
IF ( .NOT. WEAK )
365
370
$ GO TO 70
366
371
*
367
372
IF ( WANDS ) THEN
368
373
*
369
374
* Strong stability test:
370
- * F-norm((A-QL**T*S*QR, B-QL**T*T*QR)) <= O(EPS*F-norm((A,B)))
375
+ * F-norm((A-QL**H*S*QR)) <= O(EPS*F-norm((A)))
376
+ * and
377
+ * F-norm((B-QL**H*T*QR)) <= O(EPS*F-norm((B)))
371
378
*
372
379
CALL DLACPY( ' Full' , M, M, A( J1, J1 ), LDA, WORK( M* M+1 ),
373
380
$ M )
@@ -378,17 +385,20 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
378
385
DSCALE = ZERO
379
386
DSUM = ONE
380
387
CALL DLASSQ( M* M, WORK( M* M+1 ), 1 , DSCALE, DSUM )
388
+ SA = DSCALE* SQRT ( DSUM )
381
389
*
382
390
CALL DLACPY( ' Full' , M, M, B( J1, J1 ), LDB, WORK( M* M+1 ),
383
391
$ M )
384
392
CALL DGEMM( ' N' , ' N' , M, M, M, ONE, LI, LDST, T, LDST, ZERO,
385
393
$ WORK, M )
386
394
CALL DGEMM( ' N' , ' T' , M, M, M, - ONE, WORK, M, IR, LDST, ONE,
387
395
$ WORK( M* M+1 ), M )
396
+ DSCALE = ZERO
397
+ DSUM = ONE
388
398
CALL DLASSQ( M* M, WORK( M* M+1 ), 1 , DSCALE, DSUM )
389
- SS = DSCALE* SQRT ( DSUM )
390
- DTRONG = SS .LE. THRESH
391
- IF ( .NOT. DTRONG )
399
+ SB = DSCALE* SQRT ( DSUM )
400
+ STRONG = SA .LE. THRESHA .AND. SB .LE. THRESHB
401
+ IF ( .NOT. STRONG )
392
402
$ GO TO 70
393
403
END IF
394
404
*
@@ -439,6 +449,8 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
439
449
$ IR( N2+1 , N1+1 ), LDST, T, LDST, T( N1+1 , N1+1 ),
440
450
$ LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM,
441
451
$ LINFO )
452
+ IF ( LINFO.NE. 0 )
453
+ $ GO TO 70
442
454
*
443
455
* Compute orthogonal matrix QL:
444
456
*
@@ -538,14 +550,14 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
538
550
*
539
551
* Decide which method to use.
540
552
* Weak stability test:
541
- * F-norm(S21) <= O(EPS * F-norm((S, T )))
553
+ * F-norm(S21) <= O(EPS * F-norm((S)))
542
554
*
543
- IF ( BQRA21.LE. BRQA21 .AND. BQRA21.LE. THRESH ) THEN
555
+ IF ( BQRA21.LE. BRQA21 .AND. BQRA21.LE. THRESHA ) THEN
544
556
CALL DLACPY( ' F' , M, M, SCPY, LDST, S, LDST )
545
557
CALL DLACPY( ' F' , M, M, TCPY, LDST, T, LDST )
546
558
CALL DLACPY( ' F' , M, M, IRCOP, LDST, IR, LDST )
547
559
CALL DLACPY( ' F' , M, M, LICOP, LDST, LI, LDST )
548
- ELSE IF ( BRQA21.GE. THRESH ) THEN
560
+ ELSE IF ( BRQA21.GE. THRESHA ) THEN
549
561
GO TO 70
550
562
END IF
551
563
*
@@ -556,7 +568,9 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
556
568
IF ( WANDS ) THEN
557
569
*
558
570
* Strong stability test:
559
- * F-norm((A-QL*S*QR**T, B-QL*T*QR**T)) <= O(EPS*F-norm((A,B)))
571
+ * F-norm((A-QL**H*S*QR)) <= O(EPS*F-norm((A)))
572
+ * and
573
+ * F-norm((B-QL**H*T*QR)) <= O(EPS*F-norm((B)))
560
574
*
561
575
CALL DLACPY( ' Full' , M, M, A( J1, J1 ), LDA, WORK( M* M+1 ),
562
576
$ M )
@@ -567,17 +581,20 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
567
581
DSCALE = ZERO
568
582
DSUM = ONE
569
583
CALL DLASSQ( M* M, WORK( M* M+1 ), 1 , DSCALE, DSUM )
584
+ SA = DSCALE* SQRT ( DSUM )
570
585
*
571
586
CALL DLACPY( ' Full' , M, M, B( J1, J1 ), LDB, WORK( M* M+1 ),
572
587
$ M )
573
588
CALL DGEMM( ' N' , ' N' , M, M, M, ONE, LI, LDST, T, LDST, ZERO,
574
589
$ WORK, M )
575
590
CALL DGEMM( ' N' , ' N' , M, M, M, - ONE, WORK, M, IR, LDST, ONE,
576
591
$ WORK( M* M+1 ), M )
592
+ DSCALE = ZERO
593
+ DSUM = ONE
577
594
CALL DLASSQ( M* M, WORK( M* M+1 ), 1 , DSCALE, DSUM )
578
- SS = DSCALE* SQRT ( DSUM )
579
- DTRONG = ( SS .LE. THRESH )
580
- IF ( .NOT. DTRONG )
595
+ SB = DSCALE* SQRT ( DSUM )
596
+ STRONG = SA .LE. THRESHA .AND. SB .LE. THRESHB
597
+ IF ( .NOT. STRONG )
581
598
$ GO TO 70
582
599
*
583
600
END IF
0 commit comments