zunt03.f

Go to the documentation of this file.

*> \brief \b ZUNT03
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZUNT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK,
*                          RWORK, RESULT, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER*( * )    RC
*       INTEGER            INFO, K, LDU, LDV, LWORK, MU, MV, N
*       DOUBLE PRECISION   RESULT
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   RWORK( * )
*       COMPLEX*16         U( LDU, * ), V( LDV, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZUNT03 compares two unitary matrices U and V to see if their
*> corresponding rows or columns span the same spaces.  The rows are
*> checked if RC = 'R', and the columns are checked if RC = 'C'.
*>
*> RESULT is the maximum of
*>
*>    | V*V' - I | / ( MV ulp ), if RC = 'R', or
*>
*>    | V'*V - I | / ( MV ulp ), if RC = 'C',
*>
*> and the maximum over rows (or columns) 1 to K of
*>
*>    | U(i) - S*V(i) |/ ( N ulp )
*>
*> where abs(S) = 1 (chosen to minimize the expression), U(i) is the
*> i-th row (column) of U, and V(i) is the i-th row (column) of V.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] RC
*> \verbatim
*>          RC is CHARACTER*1
*>          If RC = 'R' the rows of U and V are to be compared.
*>          If RC = 'C' the columns of U and V are to be compared.
*> \endverbatim
*>
*> \param[in] MU
*> \verbatim
*>          MU is INTEGER
*>          The number of rows of U if RC = 'R', and the number of
*>          columns if RC = 'C'.  If MU = 0 ZUNT03 does nothing.
*>          MU must be at least zero.
*> \endverbatim
*>
*> \param[in] MV
*> \verbatim
*>          MV is INTEGER
*>          The number of rows of V if RC = 'R', and the number of
*>          columns if RC = 'C'.  If MV = 0 ZUNT03 does nothing.
*>          MV must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          If RC = 'R', the number of columns in the matrices U and V,
*>          and if RC = 'C', the number of rows in U and V.  If N = 0
*>          ZUNT03 does nothing.  N must be at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*>          K is INTEGER
*>          The number of rows or columns of U and V to compare.
*>          0 <= K <= max(MU,MV).
*> \endverbatim
*>
*> \param[in] U
*> \verbatim
*>          U is COMPLEX*16 array, dimension (LDU,N)
*>          The first matrix to compare.  If RC = 'R', U is MU by N, and
*>          if RC = 'C', U is N by MU.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of U.  If RC = 'R', LDU >= max(1,MU),
*>          and if RC = 'C', LDU >= max(1,N).
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*>          V is COMPLEX*16 array, dimension (LDV,N)
*>          The second matrix to compare.  If RC = 'R', V is MV by N, and
*>          if RC = 'C', V is N by MV.
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*>          LDV is INTEGER
*>          The leading dimension of V.  If RC = 'R', LDV >= max(1,MV),
*>          and if RC = 'C', LDV >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The length of the array WORK.  For best performance, LWORK
*>          should be at least N*N if RC = 'C' or M*M if RC = 'R', but
*>          the tests will be done even if LWORK is 0.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (max(MV,N))
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is DOUBLE PRECISION
*>          The value computed by the test described above.  RESULT is
*>          limited to 1/ulp to avoid overflow.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          0  indicates a successful exit
*>          -k indicates the k-th parameter had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_eig
*
*  =====================================================================
      SUBROUTINE zunt03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK,
     $                   RWORK, RESULT, INFO )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      CHARACTER*( * )    RC
      INTEGER            INFO, K, LDU, LDV, LWORK, MU, MV, N
      DOUBLE PRECISION   RESULT
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   RWORK( * )
      COMPLEX*16         U( ldu, * ), V( ldv, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      parameter( zero = 0.0d0, one = 1.0d0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IRC, J, LMX
      DOUBLE PRECISION   RES1, RES2, ULP
      COMPLEX*16         S, SU, SV
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IZAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           lsame, izamax, dlamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, dcmplx, max, min
*     ..
*     .. External Subroutines ..
      EXTERNAL           xerbla, zunt01
*     ..
*     .. Executable Statements ..
*
*     Check inputs
*
      info = 0
      IF( lsame( rc, 'R' ) ) THEN
         irc = 0
      ELSE IF( lsame( rc, 'C' ) ) THEN
         irc = 1
      ELSE
         irc = -1
      END IF
      IF( irc.EQ.-1 ) THEN
         info = -1
      ELSE IF( mu.LT.0 ) THEN
         info = -2
      ELSE IF( mv.LT.0 ) THEN
         info = -3
      ELSE IF( n.LT.0 ) THEN
         info = -4
      ELSE IF( k.LT.0 .OR. k.GT.max( mu, mv ) ) THEN
         info = -5
      ELSE IF( ( irc.EQ.0 .AND. ldu.LT.max( 1, mu ) ) .OR.
     $         ( irc.EQ.1 .AND. ldu.LT.max( 1, n ) ) ) THEN
         info = -7
      ELSE IF( ( irc.EQ.0 .AND. ldv.LT.max( 1, mv ) ) .OR.
     $         ( irc.EQ.1 .AND. ldv.LT.max( 1, n ) ) ) THEN
         info = -9
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'ZUNT03', -info )
         RETURN
      END IF
*
*     Initialize result
*
      result = zero
      IF( mu.EQ.0 .OR. mv.EQ.0 .OR. n.EQ.0 )
     $   RETURN
*
*     Machine constants
*
      ulp = dlamch( 'Precision' )
*
      IF( irc.EQ.0 ) THEN
*
*        Compare rows
*
         res1 = zero
         DO 20 i = 1, k
            lmx = izamax( n, u( i, 1 ), ldu )
            IF( v( i, lmx ).EQ.dcmplx( zero ) ) THEN
               sv = one
            ELSE
               sv = abs( v( i, lmx ) ) / v( i, lmx )
            END IF
            IF( u( i, lmx ).EQ.dcmplx( zero ) ) THEN
               su = one
            ELSE
               su = abs( u( i, lmx ) ) / u( i, lmx )
            END IF
            s = sv / su
            DO 10 j = 1, n
               res1 = max( res1, abs( u( i, j )-s*v( i, j ) ) )
   10       CONTINUE
   20    CONTINUE
         res1 = res1 / ( dble( n )*ulp )
*
*        Compute orthogonality of rows of V.
*
         CALL zunt01( 'Rows', mv, n, v, ldv, work, lwork, rwork, res2 )
*
      ELSE
*
*        Compare columns
*
         res1 = zero
         DO 40 i = 1, k
            lmx = izamax( n, u( 1, i ), 1 )
            IF( v( lmx, i ).EQ.dcmplx( zero ) ) THEN
               sv = one
            ELSE
               sv = abs( v( lmx, i ) ) / v( lmx, i )
            END IF
            IF( u( lmx, i ).EQ.dcmplx( zero ) ) THEN
               su = one
            ELSE
               su = abs( u( lmx, i ) ) / u( lmx, i )
            END IF
            s = sv / su
            DO 30 j = 1, n
               res1 = max( res1, abs( u( j, i )-s*v( j, i ) ) )
   30       CONTINUE
   40    CONTINUE
         res1 = res1 / ( dble( n )*ulp )
*
*        Compute orthogonality of columns of V.
*
         CALL zunt01( 'Columns', n, mv, v, ldv, work, lwork, rwork,
     $                res2 )
      END IF
*
      result = min( max( res1, res2 ), one / ulp )
      RETURN
*
*     End of ZUNT03
*
      END