Annotation of rpl/lapack/blas/drotmg.f, revision 1.9
1.9 ! bertrand 1: *> \brief \b DROTMG
1.1 bertrand 2: *
1.9 ! bertrand 3: * =========== DOCUMENTATION ===========
1.1 bertrand 4: *
1.9 ! bertrand 5: * Online html documentation available at
! 6: * http://www.netlib.org/lapack/explore-html/
1.1 bertrand 7: *
1.9 ! bertrand 8: * Definition:
! 9: * ===========
! 10: *
! 11: * SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
! 12: *
! 13: * .. Scalar Arguments ..
! 14: * DOUBLE PRECISION DD1,DD2,DX1,DY1
! 15: * ..
! 16: * .. Array Arguments ..
! 17: * DOUBLE PRECISION DPARAM(5)
! 18: * ..
! 19: *
! 20: *
! 21: *> \par Purpose:
! 22: * =============
! 23: *>
! 24: *> \verbatim
! 25: *>
! 26: *> CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
! 27: *> THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*> DY2)**T.
! 28: *> WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
! 29: *>
! 30: *> DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
! 31: *>
! 32: *> (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
! 33: *> H=( ) ( ) ( ) ( )
! 34: *> (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
! 35: *> LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
! 36: *> RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
! 37: *> VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
! 38: *>
! 39: *> THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
! 40: *> INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
! 41: *> OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
! 42: *>
! 43: *> \endverbatim
! 44: *
! 45: * Arguments:
! 46: * ==========
! 47: *
! 48: *> \param[in,out] DD1
! 49: *> \verbatim
! 50: *> DD1 is DOUBLE PRECISION
! 51: *> \endverbatim
! 52: *>
! 53: *> \param[in,out] DD2
! 54: *> \verbatim
! 55: *> DD2 is DOUBLE PRECISION
! 56: *> \endverbatim
! 57: *>
! 58: *> \param[in,out] DX1
! 59: *> \verbatim
! 60: *> DX1 is DOUBLE PRECISION
! 61: *> \endverbatim
! 62: *>
! 63: *> \param[in] DY1
! 64: *> \verbatim
! 65: *> DY1 is DOUBLE PRECISION
! 66: *> \endverbatim
! 67: *>
! 68: *> \param[in,out] DPARAM
! 69: *> \verbatim
! 70: *> DPARAM is DOUBLE PRECISION array, dimension 5
! 71: *> DPARAM(1)=DFLAG
! 72: *> DPARAM(2)=DH11
! 73: *> DPARAM(3)=DH21
! 74: *> DPARAM(4)=DH12
! 75: *> DPARAM(5)=DH22
! 76: *> \endverbatim
! 77: *
! 78: * Authors:
! 79: * ========
! 80: *
! 81: *> \author Univ. of Tennessee
! 82: *> \author Univ. of California Berkeley
! 83: *> \author Univ. of Colorado Denver
! 84: *> \author NAG Ltd.
1.1 bertrand 85: *
1.9 ! bertrand 86: *> \date November 2011
1.1 bertrand 87: *
1.9 ! bertrand 88: *> \ingroup double_blas_level1
1.1 bertrand 89: *
1.9 ! bertrand 90: * =====================================================================
! 91: SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
1.1 bertrand 92: *
1.9 ! bertrand 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
1.1 bertrand 97: *
1.9 ! bertrand 98: * .. Scalar Arguments ..
! 99: DOUBLE PRECISION DD1,DD2,DX1,DY1
! 100: * ..
! 101: * .. Array Arguments ..
! 102: DOUBLE PRECISION DPARAM(5)
! 103: * ..
1.1 bertrand 104: *
105: * =====================================================================
106: *
107: * .. Local Scalars ..
108: DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
1.8 bertrand 109: $ DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
1.1 bertrand 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:
1.8 bertrand 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:
1.1 bertrand 181: * PROCEDURE..SCALE-CHECK
1.8 bertrand 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:
1.4 bertrand 232: IF (DFLAG.LT.ZERO) THEN
1.8 bertrand 233: DPARAM(2) = DH11
234: DPARAM(3) = DH21
235: DPARAM(4) = DH12
236: DPARAM(5) = DH22
1.4 bertrand 237: ELSE IF (DFLAG.EQ.ZERO) THEN
1.8 bertrand 238: DPARAM(3) = DH21
239: DPARAM(4) = DH12
1.4 bertrand 240: ELSE
1.8 bertrand 241: DPARAM(2) = DH11
242: DPARAM(5) = DH22
1.4 bertrand 243: END IF
1.8 bertrand 244:
1.1 bertrand 245: DPARAM(1) = DFLAG
246: RETURN
247: END
1.8 bertrand 248:
249:
250:
251:
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to drotmg.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / blas