"Fossies" - the Fresh Open Source Software Archive

Member "lapack-3.9.1/TESTING/EIG/cbdt02.f" (25 Mar 2021, 5021 Bytes) of package /linux/misc/lapack-3.9.1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Fortran 77 source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "cbdt02.f": 3.9.0_vs_3.9.1.

    1 *> \brief \b CBDT02
    2 *
    3 *  =========== DOCUMENTATION ===========
    4 *
    5 * Online html documentation available at
    6 *            http://www.netlib.org/lapack/explore-html/
    7 *
    8 *  Definition:
    9 *  ===========
   10 *
   11 *       SUBROUTINE CBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RWORK,
   12 *                          RESID )
   13 *
   14 *       .. Scalar Arguments ..
   15 *       INTEGER            LDB, LDC, LDU, M, N
   16 *       REAL               RESID
   17 *       ..
   18 *       .. Array Arguments ..
   19 *       REAL               RWORK( * )
   20 *       COMPLEX            B( LDB, * ), C( LDC, * ), U( LDU, * ),
   21 *      $                   WORK( * )
   22 *       ..
   23 *
   24 *
   25 *> \par Purpose:
   26 *  =============
   27 *>
   28 *> \verbatim
   29 *>
   30 *> CBDT02 tests the change of basis C = U' * B by computing the residual
   31 *>
   32 *>    RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ),
   33 *>
   34 *> where B and C are M by N matrices, U is an M by M orthogonal matrix,
   35 *> and EPS is the machine precision.
   36 *> \endverbatim
   37 *
   38 *  Arguments:
   39 *  ==========
   40 *
   41 *> \param[in] M
   42 *> \verbatim
   43 *>          M is INTEGER
   44 *>          The number of rows of the matrices B and C and the order of
   45 *>          the matrix Q.
   46 *> \endverbatim
   47 *>
   48 *> \param[in] N
   49 *> \verbatim
   50 *>          N is INTEGER
   51 *>          The number of columns of the matrices B and C.
   52 *> \endverbatim
   53 *>
   54 *> \param[in] B
   55 *> \verbatim
   56 *>          B is COMPLEX array, dimension (LDB,N)
   57 *>          The m by n matrix B.
   58 *> \endverbatim
   59 *>
   60 *> \param[in] LDB
   61 *> \verbatim
   62 *>          LDB is INTEGER
   63 *>          The leading dimension of the array B.  LDB >= max(1,M).
   64 *> \endverbatim
   65 *>
   66 *> \param[in] C
   67 *> \verbatim
   68 *>          C is COMPLEX array, dimension (LDC,N)
   69 *>          The m by n matrix C, assumed to contain U' * B.
   70 *> \endverbatim
   71 *>
   72 *> \param[in] LDC
   73 *> \verbatim
   74 *>          LDC is INTEGER
   75 *>          The leading dimension of the array C.  LDC >= max(1,M).
   76 *> \endverbatim
   77 *>
   78 *> \param[in] U
   79 *> \verbatim
   80 *>          U is COMPLEX array, dimension (LDU,M)
   81 *>          The m by m orthogonal matrix U.
   82 *> \endverbatim
   83 *>
   84 *> \param[in] LDU
   85 *> \verbatim
   86 *>          LDU is INTEGER
   87 *>          The leading dimension of the array U.  LDU >= max(1,M).
   88 *> \endverbatim
   89 *>
   90 *> \param[out] WORK
   91 *> \verbatim
   92 *>          WORK is COMPLEX array, dimension (M)
   93 *> \endverbatim
   94 *>
   95 *> \param[out] RWORK
   96 *> \verbatim
   97 *>          RWORK is REAL array, dimension (M)
   98 *> \endverbatim
   99 *>
  100 *> \param[out] RESID
  101 *> \verbatim
  102 *>          RESID is REAL
  103 *>          RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ),
  104 *> \endverbatim
  105 *
  106 *  Authors:
  107 *  ========
  108 *
  109 *> \author Univ. of Tennessee
  110 *> \author Univ. of California Berkeley
  111 *> \author Univ. of Colorado Denver
  112 *> \author NAG Ltd.
  113 *
  114 *> \ingroup complex_eig
  115 *
  116 *  =====================================================================
  117       SUBROUTINE CBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RWORK,
  118      $                   RESID )
  119 *
  120 *  -- LAPACK test routine --
  121 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
  122 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  123 *
  124 *     .. Scalar Arguments ..
  125       INTEGER            LDB, LDC, LDU, M, N
  126       REAL               RESID
  127 *     ..
  128 *     .. Array Arguments ..
  129       REAL               RWORK( * )
  130       COMPLEX            B( LDB, * ), C( LDC, * ), U( LDU, * ),
  131      $                   WORK( * )
  132 *     ..
  133 *
  134 * ======================================================================
  135 *
  136 *     .. Parameters ..
  137       REAL               ZERO, ONE
  138       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
  139 *     ..
  140 *     .. Local Scalars ..
  141       INTEGER            J
  142       REAL               BNORM, EPS, REALMN
  143 *     ..
  144 *     .. External Functions ..
  145       REAL               CLANGE, SCASUM, SLAMCH
  146       EXTERNAL           CLANGE, SCASUM, SLAMCH
  147 *     ..
  148 *     .. External Subroutines ..
  149       EXTERNAL           CCOPY, CGEMV
  150 *     ..
  151 *     .. Intrinsic Functions ..
  152       INTRINSIC          CMPLX, MAX, MIN, REAL
  153 *     ..
  154 *     .. Executable Statements ..
  155 *
  156 *     Quick return if possible
  157 *
  158       RESID = ZERO
  159       IF( M.LE.0 .OR. N.LE.0 )
  160      $   RETURN
  161       REALMN = REAL( MAX( M, N ) )
  162       EPS = SLAMCH( 'Precision' )
  163 *
  164 *     Compute norm( B - U * C )
  165 *
  166       DO 10 J = 1, N
  167          CALL CCOPY( M, B( 1, J ), 1, WORK, 1 )
  168          CALL CGEMV( 'No transpose', M, M, -CMPLX( ONE ), U, LDU,
  169      $               C( 1, J ), 1, CMPLX( ONE ), WORK, 1 )
  170          RESID = MAX( RESID, SCASUM( M, WORK, 1 ) )
  171    10 CONTINUE
  172 *
  173 *     Compute norm of B.
  174 *
  175       BNORM = CLANGE( '1', M, N, B, LDB, RWORK )
  176 *
  177       IF( BNORM.LE.ZERO ) THEN
  178          IF( RESID.NE.ZERO )
  179      $      RESID = ONE / EPS
  180       ELSE
  181          IF( BNORM.GE.RESID ) THEN
  182             RESID = ( RESID / BNORM ) / ( REALMN*EPS )
  183          ELSE
  184             IF( BNORM.LT.ONE ) THEN
  185                RESID = ( MIN( RESID, REALMN*BNORM ) / BNORM ) /
  186      $                 ( REALMN*EPS )
  187             ELSE
  188                RESID = MIN( RESID / BNORM, REALMN ) / ( REALMN*EPS )
  189             END IF
  190          END IF
  191       END IF
  192       RETURN
  193 *
  194 *     End of CBDT02
  195 *
  196       END