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
      SUBROUTINE DBDT01MNKDALDAQLDQDEPTLDPTWORK,
     $                   RESID )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            KDLDALDPTLDQMN
      DOUBLE PRECISION   RESID
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   ALDA* ), D* ), E* ), PTLDPT* ),
     $                   QLDQ* ), WORK* )
*     ..
*
*  Purpose
*  =======
*
*  DBDT01 reconstructs a general matrix A from its bidiagonal form
*     A = Q * B * P'
*  where Q (m by min(m,n)) and P' (min(m,n) by n) are orthogonal
*  matrices and B is bidiagonal.
*
*  The test ratio to test the reduction is
*     RESID = norm( A - Q * B * PT ) / ( n * norm(A) * EPS )
*  where PT = P' and EPS is the machine precision.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrices A and Q.
*
*  N       (input) INTEGER
*          The number of columns of the matrices A and P'.
*
*  KD      (input) INTEGER
*          If KD = 0, B is diagonal and the array E is not referenced.
*          If KD = 1, the reduction was performed by xGEBRD; B is upper
*          bidiagonal if M >= N, and lower bidiagonal if M < N.
*          If KD = -1, the reduction was performed by xGBBRD; B is
*          always upper bidiagonal.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
*          The m by n matrix A.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
*          The m by min(m,n) orthogonal matrix Q in the reduction
*          A = Q * B * P'.
*
*  LDQ     (input) INTEGER
*          The leading dimension of the array Q.  LDQ >= max(1,M).
*
*  D       (input) DOUBLE PRECISION array, dimension (min(M,N))
*          The diagonal elements of the bidiagonal matrix B.
*
*  E       (input) DOUBLE PRECISION array, dimension (min(M,N)-1)
*          The superdiagonal elements of the bidiagonal matrix B if
*          m >= n, or the subdiagonal elements of B if m < n.
*
*  PT      (input) DOUBLE PRECISION array, dimension (LDPT,N)
*          The min(m,n) by n orthogonal matrix P' in the reduction
*          A = Q * B * P'.
*
*  LDPT    (input) INTEGER
*          The leading dimension of the array PT.
*          LDPT >= max(1,min(M,N)).
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (M+N)
*
*  RESID   (output) DOUBLE PRECISION
*          The test ratio:  norm(A - Q * B * P') / ( n * norm(A) * EPS )
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZEROONE
      PARAMETER          ( ZERO = 0.0D+0ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            IJ
      DOUBLE PRECISION   ANORMEPS
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DASUMDLAMCHDLANGE
      EXTERNAL           DASUMDLAMCHDLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPYDGEMV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLEMAXMIN
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IFM.LE.0 .OR. N.LE.0 ) THEN
         RESID = ZERO
         RETURN
      END IF
*
*     Compute A - Q * B * P' one column at a time.
*
      RESID = ZERO
      IFKD.NE.0 ) THEN
*
*        B is bidiagonal.
*
         IFKD.NE.0 .AND. M.GE.N ) THEN
*
*           B is upper bidiagonal and M >= N.
*
            DO 20 J = 1N
               CALL DCOPYMA1J ), 1WORK1 )
               DO 10 I = 1N - 1
                  WORKM+I ) = DI )*PTIJ ) + EI )*PTI+1J )
   10          CONTINUE
               WORKM+N ) = DN )*PTNJ )
               CALL DGEMV'No transpose'MN-ONEQLDQ,
     $                     WORKM+1 ), 1ONEWORK1 )
               RESID = MAXRESIDDASUMMWORK1 ) )
   20       CONTINUE
         ELSE IFKD.LT.0 ) THEN
*
*           B is upper bidiagonal and M < N.
*
            DO 40 J = 1N
               CALL DCOPYMA1J ), 1WORK1 )
               DO 30 I = 1M - 1
                  WORKM+I ) = DI )*PTIJ ) + EI )*PTI+1J )
   30          CONTINUE
               WORKM+M ) = DM )*PTMJ )
               CALL DGEMV'No transpose'MM-ONEQLDQ,
     $                     WORKM+1 ), 1ONEWORK1 )
               RESID = MAXRESIDDASUMMWORK1 ) )
   40       CONTINUE
         ELSE
*
*           B is lower bidiagonal.
*
            DO 60 J = 1N
               CALL DCOPYMA1J ), 1WORK1 )
               WORKM+1 ) = D1 )*PT1J )
               DO 50 I = 2M
                  WORKM+I ) = EI-1 )*PTI-1J ) +
     $                          DI )*PTIJ )
   50          CONTINUE
               CALL DGEMV'No transpose'MM-ONEQLDQ,
     $                     WORKM+1 ), 1ONEWORK1 )
               RESID = MAXRESIDDASUMMWORK1 ) )
   60       CONTINUE
         END IF
      ELSE
*
*        B is diagonal.
*
         IFM.GE.N ) THEN
            DO 80 J = 1N
               CALL DCOPYMA1J ), 1WORK1 )
               DO 70 I = 1N
                  WORKM+I ) = DI )*PTIJ )
   70          CONTINUE
               CALL DGEMV'No transpose'MN-ONEQLDQ,
     $                     WORKM+1 ), 1ONEWORK1 )
               RESID = MAXRESIDDASUMMWORK1 ) )
   80       CONTINUE
         ELSE
            DO 100 J = 1N
               CALL DCOPYMA1J ), 1WORK1 )
               DO 90 I = 1M
                  WORKM+I ) = DI )*PTIJ )
   90          CONTINUE
               CALL DGEMV'No transpose'MM-ONEQLDQ,
     $                     WORKM+1 ), 1ONEWORK1 )
               RESID = MAXRESIDDASUMMWORK1 ) )
  100       CONTINUE
         END IF
      END IF
*
*     Compute norm(A - Q * B * P') / ( n * norm(A) * EPS )
*
      ANORM = DLANGE'1'MNALDAWORK )
      EPS = DLAMCH'Precision' )
*
      IFANORM.LE.ZERO ) THEN
         IFRESID.NE.ZERO )
     $      RESID = ONE / EPS
      ELSE
         IFANORM.GE.RESID ) THEN
            RESID = ( RESID / ANORM ) / ( DBLEN )*EPS )
         ELSE
            IFANORM.LT.ONE ) THEN
               RESID = ( MINRESIDDBLEN )*ANORM ) / ANORM ) /
     $                 ( DBLEN )*EPS )
            ELSE
               RESID = MINRESID / ANORMDBLEN ) ) /
     $                 ( DBLEN )*EPS )
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DBDT01
*
      END