Skip to content

Commit 4f466dd

Browse files
weslleyspereiraweslleyspereira
committed
Fix bound checks for gamma in xTGSJA
1 parent 6433162 commit 4f466dd

4 files changed

Lines changed: 115 additions & 60 deletions

File tree

‎SRC/ctgsja.f‎

Lines changed: 23 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -409,7 +409,7 @@ SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
409409
LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
410410
INTEGER I, J, KCYCLE
411411
REAL A1, A3, B1, B3, CSQ, CSU, CSV, ERROR, GAMMA,
412-
$ RWK, SSMIN, SFMIN
412+
$ RWK, SSMIN, SFMIN, HUGE
413413
COMPLEX A2, B2, SNQ, SNU, SNV
414414
* ..
415415
* .. External Functions ..
@@ -469,6 +469,7 @@ SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
469469
* Safe minimum
470470
*
471471
SFMIN = SLAMCH( 'Safe minimum' )
472+
HUGE = SLAMCH( 'O' )
472473
*
473474
* Initialize U, V and Q, if necessary
474475
*
@@ -616,21 +617,30 @@ SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
616617
IF( ABS(A1).GE.SFMIN ) THEN
617618
GAMMA = B1 / A1
618619
*
619-
IF( GAMMA.LT.ZERO ) THEN
620-
CALL CSSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
621-
IF( WANTV )
622-
$ CALL CSSCAL( P, -ONE, V( 1, I ), 1 )
623-
END IF
620+
IF( GAMMA.LE.HUGE ) THEN
621+
*
622+
IF( GAMMA.LT.ZERO ) THEN
623+
CALL CSSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
624+
IF( WANTV )
625+
$ CALL CSSCAL( P, -ONE, V( 1, I ), 1 )
626+
END IF
624627
*
625-
CALL SLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
626-
$ RWK )
628+
CALL SLARTG( ABS( GAMMA ), ONE, BETA( K+I ),
629+
$ ALPHA( K+I ), RWK )
630+
*
631+
IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
632+
CALL CSSCAL( L-I+1, ONE / ALPHA( K+I ),
633+
$ A( K+I, N-L+I ), LDA )
634+
ELSE
635+
CALL CSSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
636+
$ LDB )
637+
CALL CCOPY( L-I+1, B( I, N-L+I ), LDB,
638+
$ A( K+I, N-L+I ), LDA )
639+
END IF
627640
*
628-
IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
629-
CALL CSSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
630-
$ LDA )
631641
ELSE
632-
CALL CSSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
633-
$ LDB )
642+
ALPHA( K+I ) = ZERO
643+
BETA( K+I ) = ONE
634644
CALL CCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
635645
$ LDA )
636646
END IF

‎SRC/dtgsja.f‎

Lines changed: 31 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -405,15 +405,16 @@ SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
405405
LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
406406
INTEGER I, J, KCYCLE
407407
DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, ERROR,
408-
$ GAMMA, RWK, SNQ, SNU, SNV, SSMIN
408+
$ GAMMA, RWK, SNQ, SNU, SNV, SSMIN, SFMIN, HUGE
409409
* ..
410410
* .. External Functions ..
411411
LOGICAL LSAME
412412
EXTERNAL LSAME
413413
* ..
414414
* .. External Subroutines ..
415+
DOUBLE PRECISION DLAMCH
415416
EXTERNAL DCOPY, DLAGS2, DLAPLL, DLARTG, DLASET, DROT,
416-
$ DSCAL, XERBLA
417+
$ DSCAL, XERBLA, DLAMCH
417418
* ..
418419
* .. Intrinsic Functions ..
419420
INTRINSIC ABS, MAX, MIN
@@ -460,6 +461,11 @@ SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
460461
RETURN
461462
END IF
462463
*
464+
* Safe minimum
465+
*
466+
SFMIN = DLAMCH( 'Safe minimum' )
467+
HUGE = DLAMCH( 'O' )
468+
*
463469
* Initialize U, V and Q, if necessary
464470
*
465471
IF( INITU )
@@ -594,26 +600,35 @@ SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
594600
A1 = A( K+I, N-L+I )
595601
B1 = B( I, N-L+I )
596602
*
597-
IF( A1.NE.ZERO ) THEN
603+
IF( ABS(A1).GE.SFMIN ) THEN
598604
GAMMA = B1 / A1
599605
*
600-
* change sign if necessary
606+
IF( GAMMA.LE.HUGE ) THEN
601607
*
602-
IF( GAMMA.LT.ZERO ) THEN
603-
CALL DSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
604-
IF( WANTV )
605-
$ CALL DSCAL( P, -ONE, V( 1, I ), 1 )
606-
END IF
608+
* change sign if necessary
609+
*
610+
IF( GAMMA.LT.ZERO ) THEN
611+
CALL DSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
612+
IF( WANTV )
613+
$ CALL DSCAL( P, -ONE, V( 1, I ), 1 )
614+
END IF
607615
*
608-
CALL DLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
609-
$ RWK )
616+
CALL DLARTG( ABS( GAMMA ), ONE, BETA( K+I ),
617+
$ ALPHA( K+I ), RWK )
618+
*
619+
IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
620+
CALL DSCAL( L-I+1, ONE / ALPHA( K+I ),
621+
$ A( K+I, N-L+I ), LDA )
622+
ELSE
623+
CALL DSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
624+
$ LDB )
625+
CALL DCOPY( L-I+1, B( I, N-L+I ), LDB,
626+
$ A( K+I, N-L+I ), LDA )
627+
END IF
610628
*
611-
IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
612-
CALL DSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
613-
$ LDA )
614629
ELSE
615-
CALL DSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
616-
$ LDB )
630+
ALPHA( K+I ) = ZERO
631+
BETA( K+I ) = ONE
617632
CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
618633
$ LDA )
619634
END IF

‎SRC/stgsja.f‎

Lines changed: 31 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -405,15 +405,16 @@ SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
405405
LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
406406
INTEGER I, J, KCYCLE
407407
REAL A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, ERROR,
408-
$ GAMMA, RWK, SNQ, SNU, SNV, SSMIN
408+
$ GAMMA, RWK, SNQ, SNU, SNV, SSMIN, SFMIN, HUGE
409409
* ..
410410
* .. External Functions ..
411411
LOGICAL LSAME
412412
EXTERNAL LSAME
413413
* ..
414414
* .. External Subroutines ..
415+
REAL SLAMCH
415416
EXTERNAL SCOPY, SLAGS2, SLAPLL, SLARTG, SLASET, SROT,
416-
$ SSCAL, XERBLA
417+
$ SSCAL, XERBLA, SLAMCH
417418
* ..
418419
* .. Intrinsic Functions ..
419420
INTRINSIC ABS, MAX, MIN
@@ -460,6 +461,11 @@ SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
460461
RETURN
461462
END IF
462463
*
464+
* Safe minimum
465+
*
466+
SFMIN = SLAMCH( 'Safe minimum' )
467+
HUGE = SLAMCH( 'O' )
468+
*
463469
* Initialize U, V and Q, if necessary
464470
*
465471
IF( INITU )
@@ -594,26 +600,35 @@ SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
594600
A1 = A( K+I, N-L+I )
595601
B1 = B( I, N-L+I )
596602
*
597-
IF( A1.NE.ZERO ) THEN
603+
IF( ABS(A1).GE.SFMIN ) THEN
598604
GAMMA = B1 / A1
599605
*
600-
* change sign if necessary
606+
IF( GAMMA.LE.HUGE ) THEN
601607
*
602-
IF( GAMMA.LT.ZERO ) THEN
603-
CALL SSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
604-
IF( WANTV )
605-
$ CALL SSCAL( P, -ONE, V( 1, I ), 1 )
606-
END IF
608+
* change sign if necessary
607609
*
608-
CALL SLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
609-
$ RWK )
610+
IF( GAMMA.LT.ZERO ) THEN
611+
CALL SSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
612+
IF( WANTV )
613+
$ CALL SSCAL( P, -ONE, V( 1, I ), 1 )
614+
END IF
610615
*
611-
IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
612-
CALL SSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
613-
$ LDA )
614-
ELSE
615-
CALL SSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
616+
CALL SLARTG( ABS( GAMMA ), ONE, BETA( K+I ),
617+
$ ALPHA( K+I ),RWK )
618+
*
619+
IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
620+
CALL SSCAL( L-I+1, ONE / ALPHA( K+I ),
621+
$ A( K+I, N-L+I ),LDA )
622+
ELSE
623+
CALL SSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
616624
$ LDB )
625+
CALL SCOPY( L-I+1, B( I, N-L+I ), LDB,
626+
$ A( K+I, N-L+I ),LDA )
627+
END IF
628+
*
629+
ELSE
630+
ALPHA( K+I ) = ZERO
631+
BETA( K+I ) = ONE
617632
CALL SCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
618633
$ LDA )
619634
END IF

‎SRC/ztgsja.f‎

Lines changed: 30 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -409,16 +409,17 @@ SUBROUTINE ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
409409
LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
410410
INTEGER I, J, KCYCLE
411411
DOUBLE PRECISION A1, A3, B1, B3, CSQ, CSU, CSV, ERROR, GAMMA,
412-
$ RWK, SSMIN
412+
$ RWK, SSMIN, SFMIN, HUGE
413413
COMPLEX*16 A2, B2, SNQ, SNU, SNV
414414
* ..
415415
* .. External Functions ..
416416
LOGICAL LSAME
417417
EXTERNAL LSAME
418418
* ..
419419
* .. External Subroutines ..
420+
DOUBLE PRECISION DLAMCH
420421
EXTERNAL DLARTG, XERBLA, ZCOPY, ZDSCAL, ZLAGS2, ZLAPLL,
421-
$ ZLASET, ZROT
422+
$ ZLASET, ZROT, DLAMCH
422423
* ..
423424
* .. Intrinsic Functions ..
424425
INTRINSIC ABS, DBLE, DCONJG, MAX, MIN
@@ -465,6 +466,11 @@ SUBROUTINE ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
465466
RETURN
466467
END IF
467468
*
469+
* Safe minimum
470+
*
471+
SFMIN = DLAMCH( 'Safe minimum' )
472+
HUGE = DLAMCH( 'O' )
473+
*
468474
* Initialize U, V and Q, if necessary
469475
*
470476
IF( INITU )
@@ -608,24 +614,33 @@ SUBROUTINE ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
608614
A1 = DBLE( A( K+I, N-L+I ) )
609615
B1 = DBLE( B( I, N-L+I ) )
610616
*
611-
IF( A1.NE.ZERO ) THEN
617+
IF( ABS(A1).GE.SFMIN ) THEN
612618
GAMMA = B1 / A1
613619
*
614-
IF( GAMMA.LT.ZERO ) THEN
615-
CALL ZDSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
616-
IF( WANTV )
617-
$ CALL ZDSCAL( P, -ONE, V( 1, I ), 1 )
618-
END IF
620+
IF( GAMMA.LE.HUGE ) THEN
619621
*
620-
CALL DLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
621-
$ RWK )
622+
IF( GAMMA.LT.ZERO ) THEN
623+
CALL ZDSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
624+
IF( WANTV )
625+
$ CALL ZDSCAL( P, -ONE, V( 1, I ), 1 )
626+
END IF
627+
*
628+
CALL ZLARTG( ABS( GAMMA ), ONE, BETA( K+I ),
629+
$ ALPHA( K+I ), RWK )
630+
*
631+
IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
632+
CALL ZDSCAL( L-I+1, ONE / ALPHA( K+I ),
633+
$ A( K+I, N-L+I ), LDA )
634+
ELSE
635+
CALL ZDSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
636+
$ LDB )
637+
CALL ZCOPY( L-I+1, B( I, N-L+I ), LDB,
638+
$ A( K+I, N-L+I ), LDA )
639+
END IF
622640
*
623-
IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
624-
CALL ZDSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
625-
$ LDA )
626641
ELSE
627-
CALL ZDSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
628-
$ LDB )
642+
ALPHA( K+I ) = ZERO
643+
BETA( K+I ) = ONE
629644
CALL ZCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
630645
$ LDA )
631646
END IF

0 commit comments

Comments
 (0)