LAPACK: TESTING/LIN/cppt03.f Source File

Go to the documentation of this file.
00001       SUBROUTINE CPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND,
00002      $                   RESID )
00003 *
00004 *  -- LAPACK test routine (version 3.1) --
00005 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00006 *     November 2006
00007 *
00008 *     .. Scalar Arguments ..
00009       CHARACTER          UPLO
00010       INTEGER            LDWORK, N
00011       REAL               RCOND, RESID
00012 *     ..
00013 *     .. Array Arguments ..
00014       REAL               RWORK( * )
00015       COMPLEX            A( * ), AINV( * ), WORK( LDWORK, * )
00016 *     ..
00017 *
00018 *  Purpose
00019 *  =======
00020 *
00021 *  CPPT03 computes the residual for a Hermitian packed matrix times its
00022 *  inverse:
00023 *     norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
00024 *  where EPS is the machine epsilon.
00025 *
00026 *  Arguments
00027 *  ==========
00028 *
00029 *  UPLO    (input) CHARACTER*1
00030 *          Specifies whether the upper or lower triangular part of the
00031 *          Hermitian matrix A is stored:
00032 *          = 'U':  Upper triangular
00033 *          = 'L':  Lower triangular
00034 *
00035 *  N       (input) INTEGER
00036 *          The number of rows and columns of the matrix A.  N >= 0.
00037 *
00038 *  A       (input) COMPLEX array, dimension (N*(N+1)/2)
00039 *          The original Hermitian matrix A, stored as a packed
00040 *          triangular matrix.
00041 *
00042 *  AINV    (input) COMPLEX array, dimension (N*(N+1)/2)
00043 *          The (Hermitian) inverse of the matrix A, stored as a packed
00044 *          triangular matrix.
00045 *
00046 *  WORK    (workspace) COMPLEX array, dimension (LDWORK,N)
00047 *
00048 *  LDWORK  (input) INTEGER
00049 *          The leading dimension of the array WORK.  LDWORK >= max(1,N).
00050 *
00051 *  RWORK   (workspace) REAL array, dimension (N)
00052 *
00053 *  RCOND   (output) REAL
00054 *          The reciprocal of the condition number of A, computed as
00055 *          ( 1/norm(A) ) / norm(AINV).
00056 *
00057 *  RESID   (output) REAL
00058 *          norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
00059 *
00060 *  =====================================================================
00061 *
00062 *     .. Parameters ..
00063       REAL               ZERO, ONE
00064       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
00065       COMPLEX            CZERO, CONE
00066       PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
00067      $                   CONE = ( 1.0E+0, 0.0E+0 ) )
00068 *     ..
00069 *     .. Local Scalars ..
00070       INTEGER            I, J, JJ
00071       REAL               AINVNM, ANORM, EPS
00072 *     ..
00073 *     .. External Functions ..
00074       LOGICAL            LSAME
00075       REAL               CLANGE, CLANHP, SLAMCH
00076       EXTERNAL           LSAME, CLANGE, CLANHP, SLAMCH
00077 *     ..
00078 *     .. Intrinsic Functions ..
00079       INTRINSIC          CONJG, REAL
00080 *     ..
00081 *     .. External Subroutines ..
00082       EXTERNAL           CCOPY, CHPMV
00083 *     ..
00084 *     .. Executable Statements ..
00085 *
00086 *     Quick exit if N = 0.
00087 *
00088       IF( N.LE.0 ) THEN
00089          RCOND = ONE
00090          RESID = ZERO
00091          RETURN
00092       END IF
00093 *
00094 *     Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
00095 *
00096       EPS = SLAMCH( 'Epsilon' )
00097       ANORM = CLANHP( '1', UPLO, N, A, RWORK )
00098       AINVNM = CLANHP( '1', UPLO, N, AINV, RWORK )
00099       IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
00100          RCOND = ZERO
00101          RESID = ONE / EPS
00102          RETURN
00103       END IF
00104       RCOND = ( ONE/ANORM ) / AINVNM
00105 *
00106 *     UPLO = 'U':
00107 *     Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and
00108 *     expand it to a full matrix, then multiply by A one column at a
00109 *     time, moving the result one column to the left.
00110 *
00111       IF( LSAME( UPLO, 'U' ) ) THEN
00112 *
00113 *        Copy AINV
00114 *
00115          JJ = 1
00116          DO 20 J = 1, N - 1
00117             CALL CCOPY( J, AINV( JJ ), 1, WORK( 1, J+1 ), 1 )
00118             DO 10 I = 1, J - 1
00119                WORK( J, I+1 ) = CONJG( AINV( JJ+I-1 ) )
00120    10       CONTINUE
00121             JJ = JJ + J
00122    20    CONTINUE
00123          JJ = ( ( N-1 )*N ) / 2 + 1
00124          DO 30 I = 1, N - 1
00125             WORK( N, I+1 ) = CONJG( AINV( JJ+I-1 ) )
00126    30    CONTINUE
00127 *
00128 *        Multiply by A
00129 *
00130          DO 40 J = 1, N - 1
00131             CALL CHPMV( 'Upper', N, -CONE, A, WORK( 1, J+1 ), 1, CZERO,
00132      $                  WORK( 1, J ), 1 )
00133    40    CONTINUE
00134          CALL CHPMV( 'Upper', N, -CONE, A, AINV( JJ ), 1, CZERO,
00135      $               WORK( 1, N ), 1 )
00136 *
00137 *     UPLO = 'L':
00138 *     Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1)
00139 *     and multiply by A, moving each column to the right.
00140 *
00141       ELSE
00142 *
00143 *        Copy AINV
00144 *
00145          DO 50 I = 1, N - 1
00146             WORK( 1, I ) = CONJG( AINV( I+1 ) )
00147    50    CONTINUE
00148          JJ = N + 1
00149          DO 70 J = 2, N
00150             CALL CCOPY( N-J+1, AINV( JJ ), 1, WORK( J, J-1 ), 1 )
00151             DO 60 I = 1, N - J
00152                WORK( J, J+I-1 ) = CONJG( AINV( JJ+I ) )
00153    60       CONTINUE
00154             JJ = JJ + N - J + 1
00155    70    CONTINUE
00156 *
00157 *        Multiply by A
00158 *
00159          DO 80 J = N, 2, -1
00160             CALL CHPMV( 'Lower', N, -CONE, A, WORK( 1, J-1 ), 1, CZERO,
00161      $                  WORK( 1, J ), 1 )
00162    80    CONTINUE
00163          CALL CHPMV( 'Lower', N, -CONE, A, AINV( 1 ), 1, CZERO,
00164      $               WORK( 1, 1 ), 1 )
00165 *
00166       END IF
00167 *
00168 *     Add the identity matrix to WORK .
00169 *
00170       DO 90 I = 1, N
00171          WORK( I, I ) = WORK( I, I ) + CONE
00172    90 CONTINUE
00173 *
00174 *     Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
00175 *
00176       RESID = CLANGE( '1', N, N, WORK, LDWORK, RWORK )
00177 *
00178       RESID = ( ( RESID*RCOND )/EPS ) / REAL( N )
00179 *
00180       RETURN
00181 *
00182 *     End of CPPT03
00183 *
00184       END