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