drotmg()

subroutine drotmg	(	double precision	dd1,
		double precision	dd2,
		double precision	dx1,
		double precision	dy1,
		double precision, dimension(5)	dparam )

DROTMG

Purpose:

!>
!>    CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
!>    THE SECOND COMPONENT OF THE 2-VECTOR  (DSQRT(DD1)*DX1,DSQRT(DD2)*>    DY2)**T.
!>    WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
!>
!>    DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
!>
!>      (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
!>    H=(          )    (          )    (          )    (          )
!>      (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
!>    LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
!>    RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
!>    VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
!>
!>    THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
!>    INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
!>    OF DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
!>
!> 

Parameters

[in,out]	DD1	!> DD1 is DOUBLE PRECISION !>
[in,out]	DD2	!> DD2 is DOUBLE PRECISION !>
[in,out]	DX1	!> DX1 is DOUBLE PRECISION !>
[in]	DY1	!> DY1 is DOUBLE PRECISION !>
[out]	DPARAM	!> DPARAM is DOUBLE PRECISION array, dimension (5) !> DPARAM(1)=DFLAG !> DPARAM(2)=DH11 !> DPARAM(3)=DH21 !> DPARAM(4)=DH12 !> DPARAM(5)=DH22 !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 89 of file drotmg.f.

*
*  -- Reference BLAS level1 routine --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION DD1,DD2,DX1,DY1
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION DPARAM(5)
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
     $                 DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC dabs
*     ..
*     .. Data statements ..
*
      DATA zero,one,two/0.d0,1.d0,2.d0/
      DATA gam,gamsq,rgamsq/4096.d0,16777216.d0,5.9604645d-8/
*     ..
 
      IF (dd1.LT.zero) THEN
*        GO ZERO-H-D-AND-DX1..
         dflag = -one
         dh11 = zero
         dh12 = zero
         dh21 = zero
         dh22 = zero
*
         dd1 = zero
         dd2 = zero
         dx1 = zero
      ELSE
*        CASE-DD1-NONNEGATIVE
         dp2 = dd2*dy1
         IF (dp2.EQ.zero) THEN
            dflag = -two
            dparam(1) = dflag
            RETURN
         END IF
*        REGULAR-CASE..
         dp1 = dd1*dx1
         dq2 = dp2*dy1
         dq1 = dp1*dx1
*
         IF (dabs(dq1).GT.dabs(dq2)) THEN
            dh21 = -dy1/dx1
            dh12 = dp2/dp1
*
            du = one - dh12*dh21
*
           IF (du.GT.zero) THEN
             dflag = zero
             dd1 = dd1/du
             dd2 = dd2/du
             dx1 = dx1*du
           ELSE
*            This code path if here for safety. We do not expect this
*            condition to ever hold except in edge cases with rounding
*            errors. See DOI: 10.1145/355841.355847
             dflag = -one
             dh11 = zero
             dh12 = zero
             dh21 = zero
             dh22 = zero
*
             dd1 = zero
             dd2 = zero
             dx1 = zero
           END IF
         ELSE
 
            IF (dq2.LT.zero) THEN
*              GO ZERO-H-D-AND-DX1..
               dflag = -one
               dh11 = zero
               dh12 = zero
               dh21 = zero
               dh22 = zero
*
               dd1 = zero
               dd2 = zero
               dx1 = zero
            ELSE
               dflag = one
               dh11 = dp1/dp2
               dh22 = dx1/dy1
               du = one + dh11*dh22
               dtemp = dd2/du
               dd2 = dd1/du
               dd1 = dtemp
               dx1 = dy1*du
            END IF
         END IF
 
*     PROCEDURE..SCALE-CHECK
         IF (dd1.NE.zero) THEN
            DO WHILE ((dd1.LE.rgamsq) .OR. (dd1.GE.gamsq))
               IF (dflag.EQ.zero) THEN
                  dh11 = one
                  dh22 = one
                  dflag = -one
               ELSE
                  dh21 = -one
                  dh12 = one
                  dflag = -one
               END IF
               IF (dd1.LE.rgamsq) THEN
                  dd1 = dd1*gam**2
                  dx1 = dx1/gam
                  dh11 = dh11/gam
                  dh12 = dh12/gam
               ELSE
                  dd1 = dd1/gam**2
                  dx1 = dx1*gam
                  dh11 = dh11*gam
                  dh12 = dh12*gam
               END IF
            ENDDO
         END IF
 
         IF (dd2.NE.zero) THEN
            DO WHILE ( (dabs(dd2).LE.rgamsq) .OR. (dabs(dd2).GE.gamsq) )
               IF (dflag.EQ.zero) THEN
                  dh11 = one
                  dh22 = one
                  dflag = -one
               ELSE
                  dh21 = -one
                  dh12 = one
                  dflag = -one
               END IF
               IF (dabs(dd2).LE.rgamsq) THEN
                  dd2 = dd2*gam**2
                  dh21 = dh21/gam
                  dh22 = dh22/gam
               ELSE
                  dd2 = dd2/gam**2
                  dh21 = dh21*gam
                  dh22 = dh22*gam
               END IF
            END DO
         END IF
 
      END IF
 
      IF (dflag.LT.zero) THEN
         dparam(2) = dh11
         dparam(3) = dh21
         dparam(4) = dh12
         dparam(5) = dh22
      ELSE IF (dflag.EQ.zero) THEN
         dparam(3) = dh21
         dparam(4) = dh12
      ELSE
         dparam(2) = dh11
         dparam(5) = dh22
      END IF
 
      dparam(1) = dflag
      RETURN
*
*     End of DROTMG
*

Here is the caller graph for this function: