LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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
[in,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.
Date
November 2011

Definition at line 92 of file drotmg.f.

92 *
93 * -- Reference BLAS level1 routine (version 3.4.0) --
94 * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
95 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
96 * November 2011
97 *
98 * .. Scalar Arguments ..
99  DOUBLE PRECISION dd1,dd2,dx1,dy1
100 * ..
101 * .. Array Arguments ..
102  DOUBLE PRECISION dparam(5)
103 * ..
104 *
105 * =====================================================================
106 *
107 * .. Local Scalars ..
108  DOUBLE PRECISION dflag,dh11,dh12,dh21,dh22,dp1,dp2,dq1,dq2,dtemp,
109  $ du,gam,gamsq,one,rgamsq,two,zero
110 * ..
111 * .. Intrinsic Functions ..
112  INTRINSIC dabs
113 * ..
114 * .. Data statements ..
115 *
116  DATA zero,one,two/0.d0,1.d0,2.d0/
117  DATA gam,gamsq,rgamsq/4096.d0,16777216.d0,5.9604645d-8/
118 * ..
119 
120  IF (dd1.LT.zero) THEN
121 * GO ZERO-H-D-AND-DX1..
122  dflag = -one
123  dh11 = zero
124  dh12 = zero
125  dh21 = zero
126  dh22 = zero
127 *
128  dd1 = zero
129  dd2 = zero
130  dx1 = zero
131  ELSE
132 * CASE-DD1-NONNEGATIVE
133  dp2 = dd2*dy1
134  IF (dp2.EQ.zero) THEN
135  dflag = -two
136  dparam(1) = dflag
137  RETURN
138  END IF
139 * REGULAR-CASE..
140  dp1 = dd1*dx1
141  dq2 = dp2*dy1
142  dq1 = dp1*dx1
143 *
144  IF (dabs(dq1).GT.dabs(dq2)) THEN
145  dh21 = -dy1/dx1
146  dh12 = dp2/dp1
147 *
148  du = one - dh12*dh21
149 *
150  IF (du.GT.zero) THEN
151  dflag = zero
152  dd1 = dd1/du
153  dd2 = dd2/du
154  dx1 = dx1*du
155  END IF
156  ELSE
157 
158  IF (dq2.LT.zero) THEN
159 * GO ZERO-H-D-AND-DX1..
160  dflag = -one
161  dh11 = zero
162  dh12 = zero
163  dh21 = zero
164  dh22 = zero
165 *
166  dd1 = zero
167  dd2 = zero
168  dx1 = zero
169  ELSE
170  dflag = one
171  dh11 = dp1/dp2
172  dh22 = dx1/dy1
173  du = one + dh11*dh22
174  dtemp = dd2/du
175  dd2 = dd1/du
176  dd1 = dtemp
177  dx1 = dy1*du
178  END IF
179  END IF
180 
181 * PROCEDURE..SCALE-CHECK
182  IF (dd1.NE.zero) THEN
183  DO WHILE ((dd1.LE.rgamsq) .OR. (dd1.GE.gamsq))
184  IF (dflag.EQ.zero) THEN
185  dh11 = one
186  dh22 = one
187  dflag = -one
188  ELSE
189  dh21 = -one
190  dh12 = one
191  dflag = -one
192  END IF
193  IF (dd1.LE.rgamsq) THEN
194  dd1 = dd1*gam**2
195  dx1 = dx1/gam
196  dh11 = dh11/gam
197  dh12 = dh12/gam
198  ELSE
199  dd1 = dd1/gam**2
200  dx1 = dx1*gam
201  dh11 = dh11*gam
202  dh12 = dh12*gam
203  END IF
204  ENDDO
205  END IF
206 
207  IF (dd2.NE.zero) THEN
208  DO WHILE ( (dabs(dd2).LE.rgamsq) .OR. (dabs(dd2).GE.gamsq) )
209  IF (dflag.EQ.zero) THEN
210  dh11 = one
211  dh22 = one
212  dflag = -one
213  ELSE
214  dh21 = -one
215  dh12 = one
216  dflag = -one
217  END IF
218  IF (dabs(dd2).LE.rgamsq) THEN
219  dd2 = dd2*gam**2
220  dh21 = dh21/gam
221  dh22 = dh22/gam
222  ELSE
223  dd2 = dd2/gam**2
224  dh21 = dh21*gam
225  dh22 = dh22*gam
226  END IF
227  END DO
228  END IF
229 
230  END IF
231 
232  IF (dflag.LT.zero) THEN
233  dparam(2) = dh11
234  dparam(3) = dh21
235  dparam(4) = dh12
236  dparam(5) = dh22
237  ELSE IF (dflag.EQ.zero) THEN
238  dparam(3) = dh21
239  dparam(4) = dh12
240  ELSE
241  dparam(2) = dh11
242  dparam(5) = dh22
243  END IF
244 
245  dparam(1) = dflag
246  RETURN

Here is the caller graph for this function: