LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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.

90 *
91 * -- Reference BLAS level1 routine --
92 * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
93 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
94 *
95 * .. Scalar Arguments ..
96  DOUBLE PRECISION DD1,DD2,DX1,DY1
97 * ..
98 * .. Array Arguments ..
99  DOUBLE PRECISION DPARAM(5)
100 * ..
101 *
102 * =====================================================================
103 *
104 * .. Local Scalars ..
105  DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
106  $ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
107 * ..
108 * .. Intrinsic Functions ..
109  INTRINSIC dabs
110 * ..
111 * .. Data statements ..
112 *
113  DATA zero,one,two/0.d0,1.d0,2.d0/
114  DATA gam,gamsq,rgamsq/4096.d0,16777216.d0,5.9604645d-8/
115 * ..
116 
117  IF (dd1.LT.zero) THEN
118 * GO ZERO-H-D-AND-DX1..
119  dflag = -one
120  dh11 = zero
121  dh12 = zero
122  dh21 = zero
123  dh22 = zero
124 *
125  dd1 = zero
126  dd2 = zero
127  dx1 = zero
128  ELSE
129 * CASE-DD1-NONNEGATIVE
130  dp2 = dd2*dy1
131  IF (dp2.EQ.zero) THEN
132  dflag = -two
133  dparam(1) = dflag
134  RETURN
135  END IF
136 * REGULAR-CASE..
137  dp1 = dd1*dx1
138  dq2 = dp2*dy1
139  dq1 = dp1*dx1
140 *
141  IF (dabs(dq1).GT.dabs(dq2)) THEN
142  dh21 = -dy1/dx1
143  dh12 = dp2/dp1
144 *
145  du = one - dh12*dh21
146 *
147  IF (du.GT.zero) THEN
148  dflag = zero
149  dd1 = dd1/du
150  dd2 = dd2/du
151  dx1 = dx1*du
152  ELSE
153 * This code path if here for safety. We do not expect this
154 * condition to ever hold except in edge cases with rounding
155 * errors. See DOI: 10.1145/355841.355847
156  dflag = -one
157  dh11 = zero
158  dh12 = zero
159  dh21 = zero
160  dh22 = zero
161 *
162  dd1 = zero
163  dd2 = zero
164  dx1 = zero
165  END IF
166  ELSE
167 
168  IF (dq2.LT.zero) THEN
169 * GO ZERO-H-D-AND-DX1..
170  dflag = -one
171  dh11 = zero
172  dh12 = zero
173  dh21 = zero
174  dh22 = zero
175 *
176  dd1 = zero
177  dd2 = zero
178  dx1 = zero
179  ELSE
180  dflag = one
181  dh11 = dp1/dp2
182  dh22 = dx1/dy1
183  du = one + dh11*dh22
184  dtemp = dd2/du
185  dd2 = dd1/du
186  dd1 = dtemp
187  dx1 = dy1*du
188  END IF
189  END IF
190 
191 * PROCEDURE..SCALE-CHECK
192  IF (dd1.NE.zero) THEN
193  DO WHILE ((dd1.LE.rgamsq) .OR. (dd1.GE.gamsq))
194  IF (dflag.EQ.zero) THEN
195  dh11 = one
196  dh22 = one
197  dflag = -one
198  ELSE
199  dh21 = -one
200  dh12 = one
201  dflag = -one
202  END IF
203  IF (dd1.LE.rgamsq) THEN
204  dd1 = dd1*gam**2
205  dx1 = dx1/gam
206  dh11 = dh11/gam
207  dh12 = dh12/gam
208  ELSE
209  dd1 = dd1/gam**2
210  dx1 = dx1*gam
211  dh11 = dh11*gam
212  dh12 = dh12*gam
213  END IF
214  ENDDO
215  END IF
216 
217  IF (dd2.NE.zero) THEN
218  DO WHILE ( (dabs(dd2).LE.rgamsq) .OR. (dabs(dd2).GE.gamsq) )
219  IF (dflag.EQ.zero) THEN
220  dh11 = one
221  dh22 = one
222  dflag = -one
223  ELSE
224  dh21 = -one
225  dh12 = one
226  dflag = -one
227  END IF
228  IF (dabs(dd2).LE.rgamsq) THEN
229  dd2 = dd2*gam**2
230  dh21 = dh21/gam
231  dh22 = dh22/gam
232  ELSE
233  dd2 = dd2/gam**2
234  dh21 = dh21*gam
235  dh22 = dh22*gam
236  END IF
237  END DO
238  END IF
239 
240  END IF
241 
242  IF (dflag.LT.zero) THEN
243  dparam(2) = dh11
244  dparam(3) = dh21
245  dparam(4) = dh12
246  dparam(5) = dh22
247  ELSE IF (dflag.EQ.zero) THEN
248  dparam(3) = dh21
249  dparam(4) = dh12
250  ELSE
251  dparam(2) = dh11
252  dparam(5) = dh22
253  END IF
254 
255  dparam(1) = dflag
256  RETURN
257 *
258 * End of DROTMG
259 *
Here is the caller graph for this function: