LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine dort01 ( character  ROWCOL,
integer  M,
integer  N,
double precision, dimension( ldu, * )  U,
integer  LDU,
double precision, dimension( * )  WORK,
integer  LWORK,
double precision  RESID 
)

DORT01

Purpose: 
 DORT01 checks that the matrix U is orthogonal by computing the ratio

    RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
 or
    RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.

 Alternatively, if there isn't sufficient workspace to form
 I - U*U' or I - U'*U, the ratio is computed as

    RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
 or
    RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.

 where EPS is the machine precision.  ROWCOL is used only if m = n;
 if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is
 assumed to be 'R'.
Parameters
[in]ROWCOL
          ROWCOL is CHARACTER
          Specifies whether the rows or columns of U should be checked
          for orthogonality.  Used only if M = N.
          = 'R':  Check for orthogonal rows of U
          = 'C':  Check for orthogonal columns of U
[in]M
          M is INTEGER
          The number of rows of the matrix U.
[in]N
          N is INTEGER
          The number of columns of the matrix U.
[in]U
          U is DOUBLE PRECISION array, dimension (LDU,N)
          The orthogonal matrix U.  U is checked for orthogonal columns
          if m > n or if m = n and ROWCOL = 'C'.  U is checked for
          orthogonal rows if m < n or if m = n and ROWCOL = 'R'.
[in]LDU
          LDU is INTEGER
          The leading dimension of the array U.  LDU >= max(1,M).
[out]WORK
          WORK is DOUBLE PRECISION array, dimension (LWORK)
[in]LWORK
          LWORK is INTEGER
          The length of the array WORK.  For best performance, LWORK
          should be at least N*(N+1) if ROWCOL = 'C' or M*(M+1) if
          ROWCOL = 'R', but the test will be done even if LWORK is 0.
[out]RESID
          RESID is DOUBLE PRECISION
          RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or
          RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
November 2011

Definition at line 118 of file dort01.f.

118 *
119 * -- LAPACK test routine (version 3.4.0) --
120 * -- LAPACK is a software package provided by Univ. of Tennessee, --
121 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
122 * November 2011
123 *
124 * .. Scalar Arguments ..
125  CHARACTER rowcol
126  INTEGER ldu, lwork, m, n
127  DOUBLE PRECISION resid
128 * ..
129 * .. Array Arguments ..
130  DOUBLE PRECISION u( ldu, * ), work( * )
131 * ..
132 *
133 * =====================================================================
134 *
135 * .. Parameters ..
136  DOUBLE PRECISION zero, one
137  parameter ( zero = 0.0d+0, one = 1.0d+0 )
138 * ..
139 * .. Local Scalars ..
140  CHARACTER transu
141  INTEGER i, j, k, ldwork, mnmin
142  DOUBLE PRECISION eps, tmp
143 * ..
144 * .. External Functions ..
145  LOGICAL lsame
146  DOUBLE PRECISION ddot, dlamch, dlansy
147  EXTERNAL lsame, ddot, dlamch, dlansy
148 * ..
149 * .. External Subroutines ..
150  EXTERNAL dlaset, dsyrk
151 * ..
152 * .. Intrinsic Functions ..
153  INTRINSIC abs, dble, max, min
154 * ..
155 * .. Executable Statements ..
156 *
157  resid = zero
158 *
159 * Quick return if possible
160 *
161  IF( m.LE.0 .OR. n.LE.0 )
162  $ RETURN
163 *
164  eps = dlamch( 'Precision' )
165  IF( m.LT.n .OR. ( m.EQ.n .AND. lsame( rowcol, 'R' ) ) ) THEN
166  transu = 'N'
167  k = n
168  ELSE
169  transu = 'T'
170  k = m
171  END IF
172  mnmin = min( m, n )
173 *
174  IF( ( mnmin+1 )*mnmin.LE.lwork ) THEN
175  ldwork = mnmin
176  ELSE
177  ldwork = 0
178  END IF
179  IF( ldwork.GT.0 ) THEN
180 *
181 * Compute I - U*U' or I - U'*U.
182 *
183  CALL dlaset( 'Upper', mnmin, mnmin, zero, one, work, ldwork )
184  CALL dsyrk( 'Upper', transu, mnmin, k, -one, u, ldu, one, work,
185  $ ldwork )
186 *
187 * Compute norm( I - U*U' ) / ( K * EPS ) .
188 *
189  resid = dlansy( '1', 'Upper', mnmin, work, ldwork,
190  $ work( ldwork*mnmin+1 ) )
191  resid = ( resid / dble( k ) ) / eps
192  ELSE IF( transu.EQ.'T' ) THEN
193 *
194 * Find the maximum element in abs( I - U'*U ) / ( m * EPS )
195 *
196  DO 20 j = 1, n
197  DO 10 i = 1, j
198  IF( i.NE.j ) THEN
199  tmp = zero
200  ELSE
201  tmp = one
202  END IF
203  tmp = tmp - ddot( m, u( 1, i ), 1, u( 1, j ), 1 )
204  resid = max( resid, abs( tmp ) )
205  10 CONTINUE
206  20 CONTINUE
207  resid = ( resid / dble( m ) ) / eps
208  ELSE
209 *
210 * Find the maximum element in abs( I - U*U' ) / ( n * EPS )
211 *
212  DO 40 j = 1, m
213  DO 30 i = 1, j
214  IF( i.NE.j ) THEN
215  tmp = zero
216  ELSE
217  tmp = one
218  END IF
219  tmp = tmp - ddot( n, u( j, 1 ), ldu, u( i, 1 ), ldu )
220  resid = max( resid, abs( tmp ) )
221  30 CONTINUE
222  40 CONTINUE
223  resid = ( resid / dble( n ) ) / eps
224  END IF
225  RETURN
226 *
227 * End of DORT01
228 *
dlaset
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: dlaset.f:112
dlansy
double precision function dlansy(NORM, UPLO, N, A, LDA, WORK)
DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix.
Definition: dlansy.f:124
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
ddot
double precision function ddot(N, DX, INCX, DY, INCY)
DDOT
Definition: ddot.f:53
dsyrk
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
Definition: dsyrk.f:171
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55

Here is the call graph for this function:

Here is the caller graph for this function: