1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
|
*> \brief \b SORBDB6
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SORBDB6 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sorbdb6.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sorbdb6.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sorbdb6.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
* LDQ2, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
* $ N
* ..
* .. Array Arguments ..
* REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*>\verbatim
*>
*> SORBDB6 orthogonalizes the column vector
*> X = [ X1 ]
*> [ X2 ]
*> with respect to the columns of
*> Q = [ Q1 ] .
*> [ Q2 ]
*> The columns of Q must be orthonormal.
*>
*> If the projection is zero according to Kahan's "twice is enough"
*> criterion, then the zero vector is returned.
*>
*>\endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M1
*> \verbatim
*> M1 is INTEGER
*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
*> \endverbatim
*>
*> \param[in] M2
*> \verbatim
*> M2 is INTEGER
*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns in Q1 and Q2. 0 <= N.
*> \endverbatim
*>
*> \param[in,out] X1
*> \verbatim
*> X1 is REAL array, dimension (M1)
*> On entry, the top part of the vector to be orthogonalized.
*> On exit, the top part of the projected vector.
*> \endverbatim
*>
*> \param[in] INCX1
*> \verbatim
*> INCX1 is INTEGER
*> Increment for entries of X1.
*> \endverbatim
*>
*> \param[in,out] X2
*> \verbatim
*> X2 is REAL array, dimension (M2)
*> On entry, the bottom part of the vector to be
*> orthogonalized. On exit, the bottom part of the projected
*> vector.
*> \endverbatim
*>
*> \param[in] INCX2
*> \verbatim
*> INCX2 is INTEGER
*> Increment for entries of X2.
*> \endverbatim
*>
*> \param[in] Q1
*> \verbatim
*> Q1 is REAL array, dimension (LDQ1, N)
*> The top part of the orthonormal basis matrix.
*> \endverbatim
*>
*> \param[in] LDQ1
*> \verbatim
*> LDQ1 is INTEGER
*> The leading dimension of Q1. LDQ1 >= M1.
*> \endverbatim
*>
*> \param[in] Q2
*> \verbatim
*> Q2 is REAL array, dimension (LDQ2, N)
*> The bottom part of the orthonormal basis matrix.
*> \endverbatim
*>
*> \param[in] LDQ2
*> \verbatim
*> LDQ2 is INTEGER
*> The leading dimension of Q2. LDQ2 >= M2.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is REAL array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK. LWORK >= N.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit.
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date July 2012
*
*> \ingroup realOTHERcomputational
*
* =====================================================================
SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
$ LDQ2, WORK, LWORK, INFO )
*
* -- LAPACK computational routine (version 3.7.1) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* July 2012
*
* .. Scalar Arguments ..
INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
$ N
* ..
* .. Array Arguments ..
REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ALPHASQ, REALONE, REALZERO
PARAMETER ( ALPHASQ = 0.01E0, REALONE = 1.0E0,
$ REALZERO = 0.0E0 )
REAL NEGONE, ONE, ZERO
PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
INTEGER I
REAL NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
* ..
* .. External Subroutines ..
EXTERNAL SGEMV, SLASSQ, XERBLA
* ..
* .. Intrinsic Function ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test input arguments
*
INFO = 0
IF( M1 .LT. 0 ) THEN
INFO = -1
ELSE IF( M2 .LT. 0 ) THEN
INFO = -2
ELSE IF( N .LT. 0 ) THEN
INFO = -3
ELSE IF( INCX1 .LT. 1 ) THEN
INFO = -5
ELSE IF( INCX2 .LT. 1 ) THEN
INFO = -7
ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
INFO = -9
ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
INFO = -11
ELSE IF( LWORK .LT. N ) THEN
INFO = -13
END IF
*
IF( INFO .NE. 0 ) THEN
CALL XERBLA( 'SORBDB6', -INFO )
RETURN
END IF
*
* First, project X onto the orthogonal complement of Q's column
* space
*
SCL1 = REALZERO
SSQ1 = REALONE
CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
SCL2 = REALZERO
SSQ2 = REALONE
CALL SLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2
*
IF( M1 .EQ. 0 ) THEN
DO I = 1, N
WORK(I) = ZERO
END DO
ELSE
CALL SGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
$ 1 )
END IF
*
CALL SGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
*
CALL SGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
$ INCX1 )
CALL SGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
$ INCX2 )
*
SCL1 = REALZERO
SSQ1 = REALONE
CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
SCL2 = REALZERO
SSQ2 = REALONE
CALL SLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
*
* If projection is sufficiently large in norm, then stop.
* If projection is zero, then stop.
* Otherwise, project again.
*
IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN
RETURN
END IF
*
IF( NORMSQ2 .EQ. ZERO ) THEN
RETURN
END IF
*
NORMSQ1 = NORMSQ2
*
DO I = 1, N
WORK(I) = ZERO
END DO
*
IF( M1 .EQ. 0 ) THEN
DO I = 1, N
WORK(I) = ZERO
END DO
ELSE
CALL SGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
$ 1 )
END IF
*
CALL SGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
*
CALL SGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
$ INCX1 )
CALL SGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
$ INCX2 )
*
SCL1 = REALZERO
SSQ1 = REALONE
CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
SCL2 = REALZERO
SSQ2 = REALONE
CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
*
* If second projection is sufficiently large in norm, then do
* nothing more. Alternatively, if it shrunk significantly, then
* truncate it to zero.
*
IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN
DO I = 1, M1
X1(I) = ZERO
END DO
DO I = 1, M2
X2(I) = ZERO
END DO
END IF
*
RETURN
*
* End of SORBDB6
*
END
|
