LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
zspt01.f
Go to the documentation of this file.
00001 *> \brief \b ZSPT01
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *  Definition:
00009 *  ===========
00010 *
00011 *       SUBROUTINE ZSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID )
00012 * 
00013 *       .. Scalar Arguments ..
00014 *       CHARACTER          UPLO
00015 *       INTEGER            LDC, N
00016 *       DOUBLE PRECISION   RESID
00017 *       ..
00018 *       .. Array Arguments ..
00019 *       INTEGER            IPIV( * )
00020 *       DOUBLE PRECISION   RWORK( * )
00021 *       COMPLEX*16         A( * ), AFAC( * ), C( LDC, * )
00022 *       ..
00023 *  
00024 *
00025 *> \par Purpose:
00026 *  =============
00027 *>
00028 *> \verbatim
00029 *>
00030 *> ZSPT01 reconstructs a symmetric indefinite packed matrix A from its
00031 *> diagonal pivoting factorization A = U*D*U' or A = L*D*L' and computes
00032 *> the residual
00033 *>    norm( C - A ) / ( N * norm(A) * EPS ),
00034 *> where C is the reconstructed matrix and EPS is the machine epsilon.
00035 *> \endverbatim
00036 *
00037 *  Arguments:
00038 *  ==========
00039 *
00040 *> \param[in] UPLO
00041 *> \verbatim
00042 *>          UPLO is CHARACTER*1
00043 *>          Specifies whether the upper or lower triangular part of the
00044 *>          Hermitian matrix A is stored:
00045 *>          = 'U':  Upper triangular
00046 *>          = 'L':  Lower triangular
00047 *> \endverbatim
00048 *>
00049 *> \param[in] N
00050 *> \verbatim
00051 *>          N is INTEGER
00052 *>          The order of the matrix A.  N >= 0.
00053 *> \endverbatim
00054 *>
00055 *> \param[in] A
00056 *> \verbatim
00057 *>          A is COMPLEX*16 array, dimension (N*(N+1)/2)
00058 *>          The original symmetric matrix A, stored as a packed
00059 *>          triangular matrix.
00060 *> \endverbatim
00061 *>
00062 *> \param[in] AFAC
00063 *> \verbatim
00064 *>          AFAC is COMPLEX*16 array, dimension (N*(N+1)/2)
00065 *>          The factored form of the matrix A, stored as a packed
00066 *>          triangular matrix.  AFAC contains the block diagonal matrix D
00067 *>          and the multipliers used to obtain the factor L or U from the
00068 *>          L*D*L' or U*D*U' factorization as computed by ZSPTRF.
00069 *> \endverbatim
00070 *>
00071 *> \param[in] IPIV
00072 *> \verbatim
00073 *>          IPIV is INTEGER array, dimension (N)
00074 *>          The pivot indices from ZSPTRF.
00075 *> \endverbatim
00076 *>
00077 *> \param[out] C
00078 *> \verbatim
00079 *>          C is COMPLEX*16 array, dimension (LDC,N)
00080 *> \endverbatim
00081 *>
00082 *> \param[in] LDC
00083 *> \verbatim
00084 *>          LDC is INTEGER
00085 *>          The leading dimension of the array C.  LDC >= max(1,N).
00086 *> \endverbatim
00087 *>
00088 *> \param[out] RWORK
00089 *> \verbatim
00090 *>          RWORK is DOUBLE PRECISION array, dimension (N)
00091 *> \endverbatim
00092 *>
00093 *> \param[out] RESID
00094 *> \verbatim
00095 *>          RESID is DOUBLE PRECISION
00096 *>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
00097 *>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
00098 *> \endverbatim
00099 *
00100 *  Authors:
00101 *  ========
00102 *
00103 *> \author Univ. of Tennessee 
00104 *> \author Univ. of California Berkeley 
00105 *> \author Univ. of Colorado Denver 
00106 *> \author NAG Ltd. 
00107 *
00108 *> \date November 2011
00109 *
00110 *> \ingroup complex16_lin
00111 *
00112 *  =====================================================================
00113       SUBROUTINE ZSPT01( UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID )
00114 *
00115 *  -- LAPACK test routine (version 3.4.0) --
00116 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00117 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00118 *     November 2011
00119 *
00120 *     .. Scalar Arguments ..
00121       CHARACTER          UPLO
00122       INTEGER            LDC, N
00123       DOUBLE PRECISION   RESID
00124 *     ..
00125 *     .. Array Arguments ..
00126       INTEGER            IPIV( * )
00127       DOUBLE PRECISION   RWORK( * )
00128       COMPLEX*16         A( * ), AFAC( * ), C( LDC, * )
00129 *     ..
00130 *
00131 *  =====================================================================
00132 *
00133 *     .. Parameters ..
00134       DOUBLE PRECISION   ZERO, ONE
00135       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
00136       COMPLEX*16         CZERO, CONE
00137       PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
00138      $                   CONE = ( 1.0D+0, 0.0D+0 ) )
00139 *     ..
00140 *     .. Local Scalars ..
00141       INTEGER            I, INFO, J, JC
00142       DOUBLE PRECISION   ANORM, EPS
00143 *     ..
00144 *     .. External Functions ..
00145       LOGICAL            LSAME
00146       DOUBLE PRECISION   DLAMCH, ZLANSP, ZLANSY
00147       EXTERNAL           LSAME, DLAMCH, ZLANSP, ZLANSY
00148 *     ..
00149 *     .. External Subroutines ..
00150       EXTERNAL           ZLASET, ZLAVSP
00151 *     ..
00152 *     .. Intrinsic Functions ..
00153       INTRINSIC          DBLE
00154 *     ..
00155 *     .. Executable Statements ..
00156 *
00157 *     Quick exit if N = 0.
00158 *
00159       IF( N.LE.0 ) THEN
00160          RESID = ZERO
00161          RETURN
00162       END IF
00163 *
00164 *     Determine EPS and the norm of A.
00165 *
00166       EPS = DLAMCH( 'Epsilon' )
00167       ANORM = ZLANSP( '1', UPLO, N, A, RWORK )
00168 *
00169 *     Initialize C to the identity matrix.
00170 *
00171       CALL ZLASET( 'Full', N, N, CZERO, CONE, C, LDC )
00172 *
00173 *     Call ZLAVSP to form the product D * U' (or D * L' ).
00174 *
00175       CALL ZLAVSP( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, IPIV, C,
00176      $             LDC, INFO )
00177 *
00178 *     Call ZLAVSP again to multiply by U ( or L ).
00179 *
00180       CALL ZLAVSP( UPLO, 'No transpose', 'Unit', N, N, AFAC, IPIV, C,
00181      $             LDC, INFO )
00182 *
00183 *     Compute the difference  C - A .
00184 *
00185       IF( LSAME( UPLO, 'U' ) ) THEN
00186          JC = 0
00187          DO 20 J = 1, N
00188             DO 10 I = 1, J
00189                C( I, J ) = C( I, J ) - A( JC+I )
00190    10       CONTINUE
00191             JC = JC + J
00192    20    CONTINUE
00193       ELSE
00194          JC = 1
00195          DO 40 J = 1, N
00196             DO 30 I = J, N
00197                C( I, J ) = C( I, J ) - A( JC+I-J )
00198    30       CONTINUE
00199             JC = JC + N - J + 1
00200    40    CONTINUE
00201       END IF
00202 *
00203 *     Compute norm( C - A ) / ( N * norm(A) * EPS )
00204 *
00205       RESID = ZLANSY( '1', UPLO, N, C, LDC, RWORK )
00206 *
00207       IF( ANORM.LE.ZERO ) THEN
00208          IF( RESID.NE.ZERO )
00209      $      RESID = ONE / EPS
00210       ELSE
00211          RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
00212       END IF
00213 *
00214       RETURN
00215 *
00216 *     End of ZSPT01
00217 *
00218       END
 All Files Functions