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