SRC/zla_gercond_c.f

   1 *> \brief \b ZLA_GERCOND_C
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download ZLA_GERCOND_C + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zla_gercond_c.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zla_gercond_c.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zla_gercond_c.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition
  19 *  ==========
  20 *
  21 *       DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF,
  22 *                                                LDAF, IPIV, C, CAPPLY,
  23 *                                                INFO, WORK, RWORK )
  24 *
  25 *       .. Scalar Aguments ..
  26 *       CHARACTER          TRANS
  27 *       LOGICAL            CAPPLY
  28 *       INTEGER            N, LDA, LDAF, INFO
  29 *       ..
  30 *       .. Array Arguments ..
  31 *       INTEGER            IPIV( * )
  32 *       COMPLEX*16         A( LDA, * ), AF( LDAF, * ), WORK( * )
  33 *       DOUBLE PRECISION   C( * ), RWORK( * )
  34 *       ..
  35 *
  36 *  Purpose
  37 *  =======
  38 *
  39 *>\details \b Purpose:
  40 *>\verbatim
  41 *>
  42 *>    ZLA_GERCOND_C computes the infinity norm condition number of
  43 *>    op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.
  44 *>
  45 *>\endverbatim
  46 *
  47 *  Arguments
  48 *  =========
  49 *
  50 *> \param[in] TRANS
  51 *> \verbatim
  52 *>          TRANS is CHARACTER*1
  53 *>     Specifies the form of the system of equations:
  54 *>       = 'N':  A * X = B     (No transpose)
  55 *>       = 'T':  A**T * X = B  (Transpose)
  56 *>       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)
  57 *> \endverbatim
  58 *>
  59 *> \param[in] N
  60 *> \verbatim
  61 *>          N is INTEGER
  62 *>     The number of linear equations, i.e., the order of the
  63 *>     matrix A.  N >= 0.
  64 *> \endverbatim
  65 *>
  66 *> \param[in] A
  67 *> \verbatim
  68 *>          A is COMPLEX*16 array, dimension (LDA,N)
  69 *>     On entry, the N-by-N matrix A
  70 *> \endverbatim
  71 *>
  72 *> \param[in] LDA
  73 *> \verbatim
  74 *>          LDA is INTEGER
  75 *>     The leading dimension of the array A.  LDA >= max(1,N).
  76 *> \endverbatim
  77 *>
  78 *> \param[in] AF
  79 *> \verbatim
  80 *>          AF is COMPLEX*16 array, dimension (LDAF,N)
  81 *>     The factors L and U from the factorization
  82 *>     A = P*L*U as computed by ZGETRF.
  83 *> \endverbatim
  84 *>
  85 *> \param[in] LDAF
  86 *> \verbatim
  87 *>          LDAF is INTEGER
  88 *>     The leading dimension of the array AF.  LDAF >= max(1,N).
  89 *> \endverbatim
  90 *>
  91 *> \param[in] IPIV
  92 *> \verbatim
  93 *>          IPIV is INTEGER array, dimension (N)
  94 *>     The pivot indices from the factorization A = P*L*U
  95 *>     as computed by ZGETRF; row i of the matrix was interchanged
  96 *>     with row IPIV(i).
  97 *> \endverbatim
  98 *>
  99 *> \param[in] C
 100 *> \verbatim
 101 *>          C is DOUBLE PRECISION array, dimension (N)
 102 *>     The vector C in the formula op(A) * inv(diag(C)).
 103 *> \endverbatim
 104 *>
 105 *> \param[in] CAPPLY
 106 *> \verbatim
 107 *>          CAPPLY is LOGICAL
 108 *>     If .TRUE. then access the vector C in the formula above.
 109 *> \endverbatim
 110 *>
 111 *> \param[out] INFO
 112 *> \verbatim
 113 *>          INFO is INTEGER
 114 *>       = 0:  Successful exit.
 115 *>     i > 0:  The ith argument is invalid.
 116 *> \endverbatim
 117 *>
 118 *> \param[in] WORK
 119 *> \verbatim
 120 *>          WORK is COMPLEX*16 array, dimension (2*N).
 121 *>     Workspace.
 122 *> \endverbatim
 123 *>
 124 *> \param[in] RWORK
 125 *> \verbatim
 126 *>          RWORK is DOUBLE PRECISION array, dimension (N).
 127 *>     Workspace.
 128 *> \endverbatim
 129 *>
 130 *
 131 *  Authors
 132 *  =======
 133 *
 134 *> \author Univ. of Tennessee
 135 *> \author Univ. of California Berkeley
 136 *> \author Univ. of Colorado Denver
 137 *> \author NAG Ltd.
 138 *
 139 *> \date November 2011
 140 *
 141 *> \ingroup complex16GEcomputational
 142 *
 143 *  =====================================================================
 144       DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF,
 145      $                                         LDAF, IPIV, C, CAPPLY,
 146      $                                         INFO, WORK, RWORK )
 147 *
 148 *  -- LAPACK computational routine (version 3.2.1) --
 149 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 150 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 151 *     November 2011
 152 *
 153 *     .. Scalar Aguments ..
 154       CHARACTER          TRANS
 155       LOGICAL            CAPPLY
 156       INTEGER            N, LDA, LDAF, INFO
 157 *     ..
 158 *     .. Array Arguments ..
 159       INTEGER            IPIV( * )
 160       COMPLEX*16         A( LDA, * ), AF( LDAF, * ), WORK( * )
 161       DOUBLE PRECISION   C( * ), RWORK( * )
 162 *     ..
 163 *
 164 *  =====================================================================
 165 *
 166 *     .. Local Scalars ..
 167       LOGICAL            NOTRANS
 168       INTEGER            KASE, I, J
 169       DOUBLE PRECISION   AINVNM, ANORM, TMP
 170       COMPLEX*16         ZDUM
 171 *     ..
 172 *     .. Local Arrays ..
 173       INTEGER            ISAVE( 3 )
 174 *     ..
 175 *     .. External Functions ..
 176       LOGICAL            LSAME
 177       EXTERNAL           LSAME
 178 *     ..
 179 *     .. External Subroutines ..
 180       EXTERNAL           ZLACN2, ZGETRS, XERBLA
 181 *     ..
 182 *     .. Intrinsic Functions ..
 183       INTRINSIC          ABS, MAX, REAL, DIMAG
 184 *     ..
 185 *     .. Statement Functions ..
 186       DOUBLE PRECISION   CABS1
 187 *     ..
 188 *     .. Statement Function Definitions ..
 189       CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
 190 *     ..
 191 *     .. Executable Statements ..
 192       ZLA_GERCOND_C = 0.0D+0
 193 *
 194       INFO = 0
 195       NOTRANS = LSAME( TRANS, 'N' )
 196       IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT.
 197      $     LSAME( TRANS, 'C' ) ) THEN
 198       ELSE IF( N.LT.0 ) THEN
 199          INFO = -2
 200       END IF
 201       IF( INFO.NE.0 ) THEN
 202          CALL XERBLA( 'ZLA_GERCOND_C', -INFO )
 203          RETURN
 204       END IF
 205 *
 206 *     Compute norm of op(A)*op2(C).
 207 *
 208       ANORM = 0.0D+0
 209       IF ( NOTRANS ) THEN
 210          DO I = 1, N
 211             TMP = 0.0D+0
 212             IF ( CAPPLY ) THEN
 213                DO J = 1, N
 214                   TMP = TMP + CABS1( A( I, J ) ) / C( J )
 215                END DO
 216             ELSE
 217                DO J = 1, N
 218                   TMP = TMP + CABS1( A( I, J ) )
 219                END DO
 220             END IF
 221             RWORK( I ) = TMP
 222             ANORM = MAX( ANORM, TMP )
 223          END DO
 224       ELSE
 225          DO I = 1, N
 226             TMP = 0.0D+0
 227             IF ( CAPPLY ) THEN
 228                DO J = 1, N
 229                   TMP = TMP + CABS1( A( J, I ) ) / C( J )
 230                END DO
 231             ELSE
 232                DO J = 1, N
 233                   TMP = TMP + CABS1( A( J, I ) )
 234                END DO
 235             END IF
 236             RWORK( I ) = TMP
 237             ANORM = MAX( ANORM, TMP )
 238          END DO
 239       END IF
 240 *
 241 *     Quick return if possible.
 242 *
 243       IF( N.EQ.0 ) THEN
 244          ZLA_GERCOND_C = 1.0D+0
 245          RETURN
 246       ELSE IF( ANORM .EQ. 0.0D+0 ) THEN
 247          RETURN
 248       END IF
 249 *
 250 *     Estimate the norm of inv(op(A)).
 251 *
 252       AINVNM = 0.0D+0
 253 *
 254       KASE = 0
 255    10 CONTINUE
 256       CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
 257       IF( KASE.NE.0 ) THEN
 258          IF( KASE.EQ.2 ) THEN
 259 *
 260 *           Multiply by R.
 261 *
 262             DO I = 1, N
 263                WORK( I ) = WORK( I ) * RWORK( I )
 264             END DO
 265 *
 266             IF (NOTRANS) THEN
 267                CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV,
 268      $            WORK, N, INFO )
 269             ELSE
 270                CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV,
 271      $            WORK, N, INFO )
 272             ENDIF
 273 *
 274 *           Multiply by inv(C).
 275 *
 276             IF ( CAPPLY ) THEN
 277                DO I = 1, N
 278                   WORK( I ) = WORK( I ) * C( I )
 279                END DO
 280             END IF
 281          ELSE
 282 *
 283 *           Multiply by inv(C**H).
 284 *
 285             IF ( CAPPLY ) THEN
 286                DO I = 1, N
 287                   WORK( I ) = WORK( I ) * C( I )
 288                END DO
 289             END IF
 290 *
 291             IF ( NOTRANS ) THEN
 292                CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV,
 293      $            WORK, N, INFO )
 294             ELSE
 295                CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV,
 296      $            WORK, N, INFO )
 297             END IF
 298 *
 299 *           Multiply by R.
 300 *
 301             DO I = 1, N
 302                WORK( I ) = WORK( I ) * RWORK( I )
 303             END DO
 304          END IF
 305          GO TO 10
 306       END IF
 307 *
 308 *     Compute the estimate of the reciprocal condition number.
 309 *
 310       IF( AINVNM .NE. 0.0D+0 )
 311      $   ZLA_GERCOND_C = 1.0D+0 / AINVNM
 312 *
 313       RETURN
 314 *
 315       END