LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
stfttr.f
Go to the documentation of this file.
1 *> \brief \b STFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full format (TR).
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download STFTTR + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stfttr.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/stfttr.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stfttr.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE STFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )
22 *
23 * .. Scalar Arguments ..
24 * CHARACTER TRANSR, UPLO
25 * INTEGER INFO, N, LDA
26 * ..
27 * .. Array Arguments ..
28 * REAL A( 0: LDA-1, 0: * ), ARF( 0: * )
29 * ..
30 *
31 *
32 *> \par Purpose:
33 * =============
34 *>
35 *> \verbatim
36 *>
37 *> STFTTR copies a triangular matrix A from rectangular full packed
38 *> format (TF) to standard full format (TR).
39 *> \endverbatim
40 *
41 * Arguments:
42 * ==========
43 *
44 *> \param[in] TRANSR
45 *> \verbatim
46 *> TRANSR is CHARACTER*1
47 *> = 'N': ARF is in Normal format;
48 *> = 'T': ARF is in Transpose format.
49 *> \endverbatim
50 *>
51 *> \param[in] UPLO
52 *> \verbatim
53 *> UPLO is CHARACTER*1
54 *> = 'U': A is upper triangular;
55 *> = 'L': A is lower triangular.
56 *> \endverbatim
57 *>
58 *> \param[in] N
59 *> \verbatim
60 *> N is INTEGER
61 *> The order of the matrices ARF and A. N >= 0.
62 *> \endverbatim
63 *>
64 *> \param[in] ARF
65 *> \verbatim
66 *> ARF is REAL array, dimension (N*(N+1)/2).
67 *> On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
68 *> matrix A in RFP format. See the "Notes" below for more
69 *> details.
70 *> \endverbatim
71 *>
72 *> \param[out] A
73 *> \verbatim
74 *> A is REAL array, dimension (LDA,N)
75 *> On exit, the triangular matrix A. If UPLO = 'U', the
76 *> leading N-by-N upper triangular part of the array A contains
77 *> the upper triangular matrix, and the strictly lower
78 *> triangular part of A is not referenced. If UPLO = 'L', the
79 *> leading N-by-N lower triangular part of the array A contains
80 *> the lower triangular matrix, and the strictly upper
81 *> triangular part of A is not referenced.
82 *> \endverbatim
83 *>
84 *> \param[in] LDA
85 *> \verbatim
86 *> LDA is INTEGER
87 *> The leading dimension of the array A. LDA >= max(1,N).
88 *> \endverbatim
89 *>
90 *> \param[out] INFO
91 *> \verbatim
92 *> INFO is INTEGER
93 *> = 0: successful exit
94 *> < 0: if INFO = -i, the i-th argument had an illegal value
95 *> \endverbatim
96 *
97 * Authors:
98 * ========
99 *
100 *> \author Univ. of Tennessee
101 *> \author Univ. of California Berkeley
102 *> \author Univ. of Colorado Denver
103 *> \author NAG Ltd.
104 *
105 *> \date September 2012
106 *
107 *> \ingroup realOTHERcomputational
108 *
109 *> \par Further Details:
110 * =====================
111 *>
112 *> \verbatim
113 *>
114 *> We first consider Rectangular Full Packed (RFP) Format when N is
115 *> even. We give an example where N = 6.
116 *>
117 *> AP is Upper AP is Lower
118 *>
119 *> 00 01 02 03 04 05 00
120 *> 11 12 13 14 15 10 11
121 *> 22 23 24 25 20 21 22
122 *> 33 34 35 30 31 32 33
123 *> 44 45 40 41 42 43 44
124 *> 55 50 51 52 53 54 55
125 *>
126 *>
127 *> Let TRANSR = 'N'. RFP holds AP as follows:
128 *> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
129 *> three columns of AP upper. The lower triangle A(4:6,0:2) consists of
130 *> the transpose of the first three columns of AP upper.
131 *> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
132 *> three columns of AP lower. The upper triangle A(0:2,0:2) consists of
133 *> the transpose of the last three columns of AP lower.
134 *> This covers the case N even and TRANSR = 'N'.
135 *>
136 *> RFP A RFP A
137 *>
138 *> 03 04 05 33 43 53
139 *> 13 14 15 00 44 54
140 *> 23 24 25 10 11 55
141 *> 33 34 35 20 21 22
142 *> 00 44 45 30 31 32
143 *> 01 11 55 40 41 42
144 *> 02 12 22 50 51 52
145 *>
146 *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
147 *> transpose of RFP A above. One therefore gets:
148 *>
149 *>
150 *> RFP A RFP A
151 *>
152 *> 03 13 23 33 00 01 02 33 00 10 20 30 40 50
153 *> 04 14 24 34 44 11 12 43 44 11 21 31 41 51
154 *> 05 15 25 35 45 55 22 53 54 55 22 32 42 52
155 *>
156 *>
157 *> We then consider Rectangular Full Packed (RFP) Format when N is
158 *> odd. We give an example where N = 5.
159 *>
160 *> AP is Upper AP is Lower
161 *>
162 *> 00 01 02 03 04 00
163 *> 11 12 13 14 10 11
164 *> 22 23 24 20 21 22
165 *> 33 34 30 31 32 33
166 *> 44 40 41 42 43 44
167 *>
168 *>
169 *> Let TRANSR = 'N'. RFP holds AP as follows:
170 *> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
171 *> three columns of AP upper. The lower triangle A(3:4,0:1) consists of
172 *> the transpose of the first two columns of AP upper.
173 *> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
174 *> three columns of AP lower. The upper triangle A(0:1,1:2) consists of
175 *> the transpose of the last two columns of AP lower.
176 *> This covers the case N odd and TRANSR = 'N'.
177 *>
178 *> RFP A RFP A
179 *>
180 *> 02 03 04 00 33 43
181 *> 12 13 14 10 11 44
182 *> 22 23 24 20 21 22
183 *> 00 33 34 30 31 32
184 *> 01 11 44 40 41 42
185 *>
186 *> Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
187 *> transpose of RFP A above. One therefore gets:
188 *>
189 *> RFP A RFP A
190 *>
191 *> 02 12 22 00 01 00 10 20 30 40 50
192 *> 03 13 23 33 11 33 11 21 31 41 51
193 *> 04 14 24 34 44 43 44 22 32 42 52
194 *> \endverbatim
195 *
196 * =====================================================================
197  SUBROUTINE stfttr( TRANSR, UPLO, N, ARF, A, LDA, INFO )
198 *
199 * -- LAPACK computational routine (version 3.4.2) --
200 * -- LAPACK is a software package provided by Univ. of Tennessee, --
201 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
202 * September 2012
203 *
204 * .. Scalar Arguments ..
205  CHARACTER TRANSR, UPLO
206  INTEGER INFO, N, LDA
207 * ..
208 * .. Array Arguments ..
209  REAL A( 0: lda-1, 0: * ), ARF( 0: * )
210 * ..
211 *
212 * =====================================================================
213 *
214 * ..
215 * .. Local Scalars ..
216  LOGICAL LOWER, NISODD, NORMALTRANSR
217  INTEGER N1, N2, K, NT, NX2, NP1X2
218  INTEGER I, J, L, IJ
219 * ..
220 * .. External Functions ..
221  LOGICAL LSAME
222  EXTERNAL lsame
223 * ..
224 * .. External Subroutines ..
225  EXTERNAL xerbla
226 * ..
227 * .. Intrinsic Functions ..
228  INTRINSIC max, mod
229 * ..
230 * .. Executable Statements ..
231 *
232 * Test the input parameters.
233 *
234  info = 0
235  normaltransr = lsame( transr, 'N' )
236  lower = lsame( uplo, 'L' )
237  IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'T' ) ) THEN
238  info = -1
239  ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
240  info = -2
241  ELSE IF( n.LT.0 ) THEN
242  info = -3
243  ELSE IF( lda.LT.max( 1, n ) ) THEN
244  info = -6
245  END IF
246  IF( info.NE.0 ) THEN
247  CALL xerbla( 'STFTTR', -info )
248  RETURN
249  END IF
250 *
251 * Quick return if possible
252 *
253  IF( n.LE.1 ) THEN
254  IF( n.EQ.1 ) THEN
255  a( 0, 0 ) = arf( 0 )
256  END IF
257  RETURN
258  END IF
259 *
260 * Size of array ARF(0:nt-1)
261 *
262  nt = n*( n+1 ) / 2
263 *
264 * set N1 and N2 depending on LOWER: for N even N1=N2=K
265 *
266  IF( lower ) THEN
267  n2 = n / 2
268  n1 = n - n2
269  ELSE
270  n1 = n / 2
271  n2 = n - n1
272  END IF
273 *
274 * If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2.
275 * If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is
276 * N--by--(N+1)/2.
277 *
278  IF( mod( n, 2 ).EQ.0 ) THEN
279  k = n / 2
280  nisodd = .false.
281  IF( .NOT.lower )
282  $ np1x2 = n + n + 2
283  ELSE
284  nisodd = .true.
285  IF( .NOT.lower )
286  $ nx2 = n + n
287  END IF
288 *
289  IF( nisodd ) THEN
290 *
291 * N is odd
292 *
293  IF( normaltransr ) THEN
294 *
295 * N is odd and TRANSR = 'N'
296 *
297  IF( lower ) THEN
298 *
299 * N is odd, TRANSR = 'N', and UPLO = 'L'
300 *
301  ij = 0
302  DO j = 0, n2
303  DO i = n1, n2 + j
304  a( n2+j, i ) = arf( ij )
305  ij = ij + 1
306  END DO
307  DO i = j, n - 1
308  a( i, j ) = arf( ij )
309  ij = ij + 1
310  END DO
311  END DO
312 *
313  ELSE
314 *
315 * N is odd, TRANSR = 'N', and UPLO = 'U'
316 *
317  ij = nt - n
318  DO j = n - 1, n1, -1
319  DO i = 0, j
320  a( i, j ) = arf( ij )
321  ij = ij + 1
322  END DO
323  DO l = j - n1, n1 - 1
324  a( j-n1, l ) = arf( ij )
325  ij = ij + 1
326  END DO
327  ij = ij - nx2
328  END DO
329 *
330  END IF
331 *
332  ELSE
333 *
334 * N is odd and TRANSR = 'T'
335 *
336  IF( lower ) THEN
337 *
338 * N is odd, TRANSR = 'T', and UPLO = 'L'
339 *
340  ij = 0
341  DO j = 0, n2 - 1
342  DO i = 0, j
343  a( j, i ) = arf( ij )
344  ij = ij + 1
345  END DO
346  DO i = n1 + j, n - 1
347  a( i, n1+j ) = arf( ij )
348  ij = ij + 1
349  END DO
350  END DO
351  DO j = n2, n - 1
352  DO i = 0, n1 - 1
353  a( j, i ) = arf( ij )
354  ij = ij + 1
355  END DO
356  END DO
357 *
358  ELSE
359 *
360 * N is odd, TRANSR = 'T', and UPLO = 'U'
361 *
362  ij = 0
363  DO j = 0, n1
364  DO i = n1, n - 1
365  a( j, i ) = arf( ij )
366  ij = ij + 1
367  END DO
368  END DO
369  DO j = 0, n1 - 1
370  DO i = 0, j
371  a( i, j ) = arf( ij )
372  ij = ij + 1
373  END DO
374  DO l = n2 + j, n - 1
375  a( n2+j, l ) = arf( ij )
376  ij = ij + 1
377  END DO
378  END DO
379 *
380  END IF
381 *
382  END IF
383 *
384  ELSE
385 *
386 * N is even
387 *
388  IF( normaltransr ) THEN
389 *
390 * N is even and TRANSR = 'N'
391 *
392  IF( lower ) THEN
393 *
394 * N is even, TRANSR = 'N', and UPLO = 'L'
395 *
396  ij = 0
397  DO j = 0, k - 1
398  DO i = k, k + j
399  a( k+j, i ) = arf( ij )
400  ij = ij + 1
401  END DO
402  DO i = j, n - 1
403  a( i, j ) = arf( ij )
404  ij = ij + 1
405  END DO
406  END DO
407 *
408  ELSE
409 *
410 * N is even, TRANSR = 'N', and UPLO = 'U'
411 *
412  ij = nt - n - 1
413  DO j = n - 1, k, -1
414  DO i = 0, j
415  a( i, j ) = arf( ij )
416  ij = ij + 1
417  END DO
418  DO l = j - k, k - 1
419  a( j-k, l ) = arf( ij )
420  ij = ij + 1
421  END DO
422  ij = ij - np1x2
423  END DO
424 *
425  END IF
426 *
427  ELSE
428 *
429 * N is even and TRANSR = 'T'
430 *
431  IF( lower ) THEN
432 *
433 * N is even, TRANSR = 'T', and UPLO = 'L'
434 *
435  ij = 0
436  j = k
437  DO i = k, n - 1
438  a( i, j ) = arf( ij )
439  ij = ij + 1
440  END DO
441  DO j = 0, k - 2
442  DO i = 0, j
443  a( j, i ) = arf( ij )
444  ij = ij + 1
445  END DO
446  DO i = k + 1 + j, n - 1
447  a( i, k+1+j ) = arf( ij )
448  ij = ij + 1
449  END DO
450  END DO
451  DO j = k - 1, n - 1
452  DO i = 0, k - 1
453  a( j, i ) = arf( ij )
454  ij = ij + 1
455  END DO
456  END DO
457 *
458  ELSE
459 *
460 * N is even, TRANSR = 'T', and UPLO = 'U'
461 *
462  ij = 0
463  DO j = 0, k
464  DO i = k, n - 1
465  a( j, i ) = arf( ij )
466  ij = ij + 1
467  END DO
468  END DO
469  DO j = 0, k - 2
470  DO i = 0, j
471  a( i, j ) = arf( ij )
472  ij = ij + 1
473  END DO
474  DO l = k + 1 + j, n - 1
475  a( k+1+j, l ) = arf( ij )
476  ij = ij + 1
477  END DO
478  END DO
479 * Note that here, on exit of the loop, J = K-1
480  DO i = 0, j
481  a( i, j ) = arf( ij )
482  ij = ij + 1
483  END DO
484 *
485  END IF
486 *
487  END IF
488 *
489  END IF
490 *
491  RETURN
492 *
493 * End of STFTTR
494 *
495  END
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
stfttr
subroutine stfttr(TRANSR, UPLO, N, ARF, A, LDA, INFO)
STFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full f...
Definition: stfttr.f:198