SRC/stfttr.f

   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