1: *> \brief \b DLASQ5
2: *
3: * =========== DOCUMENTATION ===========
4: *
5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
7: *
8: *> \htmlonly
9: *> Download DLASQ5 + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasq5.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasq5.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasq5.f">
15: *> [TXT]</a>
16: *> \endhtmlonly
17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
22: * DNM1, DNM2, IEEE )
23: *
24: * .. Scalar Arguments ..
25: * LOGICAL IEEE
26: * INTEGER I0, N0, PP
27: * DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
28: * ..
29: * .. Array Arguments ..
30: * DOUBLE PRECISION Z( * )
31: * ..
32: *
33: *
34: *> \par Purpose:
35: * =============
36: *>
37: *> \verbatim
38: *>
39: *> DLASQ5 computes one dqds transform in ping-pong form, one
40: *> version for IEEE machines another for non IEEE machines.
41: *> \endverbatim
42: *
43: * Arguments:
44: * ==========
45: *
46: *> \param[in] I0
47: *> \verbatim
48: *> I0 is INTEGER
49: *> First index.
50: *> \endverbatim
51: *>
52: *> \param[in] N0
53: *> \verbatim
54: *> N0 is INTEGER
55: *> Last index.
56: *> \endverbatim
57: *>
58: *> \param[in] Z
59: *> \verbatim
60: *> Z is DOUBLE PRECISION array, dimension ( 4*N )
61: *> Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
62: *> an extra argument.
63: *> \endverbatim
64: *>
65: *> \param[in] PP
66: *> \verbatim
67: *> PP is INTEGER
68: *> PP=0 for ping, PP=1 for pong.
69: *> \endverbatim
70: *>
71: *> \param[in] TAU
72: *> \verbatim
73: *> TAU is DOUBLE PRECISION
74: *> This is the shift.
75: *> \endverbatim
76: *>
77: *> \param[out] DMIN
78: *> \verbatim
79: *> DMIN is DOUBLE PRECISION
80: *> Minimum value of d.
81: *> \endverbatim
82: *>
83: *> \param[out] DMIN1
84: *> \verbatim
85: *> DMIN1 is DOUBLE PRECISION
86: *> Minimum value of d, excluding D( N0 ).
87: *> \endverbatim
88: *>
89: *> \param[out] DMIN2
90: *> \verbatim
91: *> DMIN2 is DOUBLE PRECISION
92: *> Minimum value of d, excluding D( N0 ) and D( N0-1 ).
93: *> \endverbatim
94: *>
95: *> \param[out] DN
96: *> \verbatim
97: *> DN is DOUBLE PRECISION
98: *> d(N0), the last value of d.
99: *> \endverbatim
100: *>
101: *> \param[out] DNM1
102: *> \verbatim
103: *> DNM1 is DOUBLE PRECISION
104: *> d(N0-1).
105: *> \endverbatim
106: *>
107: *> \param[out] DNM2
108: *> \verbatim
109: *> DNM2 is DOUBLE PRECISION
110: *> d(N0-2).
111: *> \endverbatim
112: *>
113: *> \param[in] IEEE
114: *> \verbatim
115: *> IEEE is LOGICAL
116: *> Flag for IEEE or non IEEE arithmetic.
117: *> \endverbatim
118: *
119: * Authors:
120: * ========
121: *
122: *> \author Univ. of Tennessee
123: *> \author Univ. of California Berkeley
124: *> \author Univ. of Colorado Denver
125: *> \author NAG Ltd.
126: *
127: *> \date November 2011
128: *
129: *> \ingroup auxOTHERcomputational
130: *
131: * =====================================================================
132: SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
133: $ DNM1, DNM2, IEEE )
134: *
135: * -- LAPACK computational routine (version 3.4.0) --
136: * -- LAPACK is a software package provided by Univ. of Tennessee, --
137: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
138: * November 2011
139: *
140: * .. Scalar Arguments ..
141: LOGICAL IEEE
142: INTEGER I0, N0, PP
143: DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
144: * ..
145: * .. Array Arguments ..
146: DOUBLE PRECISION Z( * )
147: * ..
148: *
149: * =====================================================================
150: *
151: * .. Parameter ..
152: DOUBLE PRECISION ZERO
153: PARAMETER ( ZERO = 0.0D0 )
154: * ..
155: * .. Local Scalars ..
156: INTEGER J4, J4P2
157: DOUBLE PRECISION D, EMIN, TEMP
158: * ..
159: * .. Intrinsic Functions ..
160: INTRINSIC MIN
161: * ..
162: * .. Executable Statements ..
163: *
164: IF( ( N0-I0-1 ).LE.0 )
165: $ RETURN
166: *
167: J4 = 4*I0 + PP - 3
168: EMIN = Z( J4+4 )
169: D = Z( J4 ) - TAU
170: DMIN = D
171: DMIN1 = -Z( J4 )
172: *
173: IF( IEEE ) THEN
174: *
175: * Code for IEEE arithmetic.
176: *
177: IF( PP.EQ.0 ) THEN
178: DO 10 J4 = 4*I0, 4*( N0-3 ), 4
179: Z( J4-2 ) = D + Z( J4-1 )
180: TEMP = Z( J4+1 ) / Z( J4-2 )
181: D = D*TEMP - TAU
182: DMIN = MIN( DMIN, D )
183: Z( J4 ) = Z( J4-1 )*TEMP
184: EMIN = MIN( Z( J4 ), EMIN )
185: 10 CONTINUE
186: ELSE
187: DO 20 J4 = 4*I0, 4*( N0-3 ), 4
188: Z( J4-3 ) = D + Z( J4 )
189: TEMP = Z( J4+2 ) / Z( J4-3 )
190: D = D*TEMP - TAU
191: DMIN = MIN( DMIN, D )
192: Z( J4-1 ) = Z( J4 )*TEMP
193: EMIN = MIN( Z( J4-1 ), EMIN )
194: 20 CONTINUE
195: END IF
196: *
197: * Unroll last two steps.
198: *
199: DNM2 = D
200: DMIN2 = DMIN
201: J4 = 4*( N0-2 ) - PP
202: J4P2 = J4 + 2*PP - 1
203: Z( J4-2 ) = DNM2 + Z( J4P2 )
204: Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
205: DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
206: DMIN = MIN( DMIN, DNM1 )
207: *
208: DMIN1 = DMIN
209: J4 = J4 + 4
210: J4P2 = J4 + 2*PP - 1
211: Z( J4-2 ) = DNM1 + Z( J4P2 )
212: Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
213: DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
214: DMIN = MIN( DMIN, DN )
215: *
216: ELSE
217: *
218: * Code for non IEEE arithmetic.
219: *
220: IF( PP.EQ.0 ) THEN
221: DO 30 J4 = 4*I0, 4*( N0-3 ), 4
222: Z( J4-2 ) = D + Z( J4-1 )
223: IF( D.LT.ZERO ) THEN
224: RETURN
225: ELSE
226: Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
227: D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
228: END IF
229: DMIN = MIN( DMIN, D )
230: EMIN = MIN( EMIN, Z( J4 ) )
231: 30 CONTINUE
232: ELSE
233: DO 40 J4 = 4*I0, 4*( N0-3 ), 4
234: Z( J4-3 ) = D + Z( J4 )
235: IF( D.LT.ZERO ) THEN
236: RETURN
237: ELSE
238: Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
239: D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
240: END IF
241: DMIN = MIN( DMIN, D )
242: EMIN = MIN( EMIN, Z( J4-1 ) )
243: 40 CONTINUE
244: END IF
245: *
246: * Unroll last two steps.
247: *
248: DNM2 = D
249: DMIN2 = DMIN
250: J4 = 4*( N0-2 ) - PP
251: J4P2 = J4 + 2*PP - 1
252: Z( J4-2 ) = DNM2 + Z( J4P2 )
253: IF( DNM2.LT.ZERO ) THEN
254: RETURN
255: ELSE
256: Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
257: DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
258: END IF
259: DMIN = MIN( DMIN, DNM1 )
260: *
261: DMIN1 = DMIN
262: J4 = J4 + 4
263: J4P2 = J4 + 2*PP - 1
264: Z( J4-2 ) = DNM1 + Z( J4P2 )
265: IF( DNM1.LT.ZERO ) THEN
266: RETURN
267: ELSE
268: Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
269: DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
270: END IF
271: DMIN = MIN( DMIN, DN )
272: *
273: END IF
274: *
275: Z( J4+2 ) = DN
276: Z( 4*N0-PP ) = EMIN
277: RETURN
278: *
279: * End of DLASQ5
280: *
281: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dlasq5.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack