d6/d5a/slatdf_8f_source.html

00001       SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
00002      $                   JPIV )
00003 *
00004 *  -- LAPACK auxiliary routine (version 3.2) --
00005 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00006 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00007 *     November 2006
00008 *
00009 *     .. Scalar Arguments ..
00010       INTEGER            IJOB, LDZ, N
00011       REAL               RDSCAL, RDSUM
00012 *     ..
00013 *     .. Array Arguments ..
00014       INTEGER            IPIV( * ), JPIV( * )
00015       REAL               RHS( * ), Z( LDZ, * )
00016 *     ..
00017 *
00018 *  Purpose
00019 *  =======
00020 *
00021 *  SLATDF uses the LU factorization of the n-by-n matrix Z computed by
00022 *  SGETC2 and computes a contribution to the reciprocal Dif-estimate
00023 *  by solving Z * x = b for x, and choosing the r.h.s. b such that
00024 *  the norm of x is as large as possible. On entry RHS = b holds the
00025 *  contribution from earlier solved sub-systems, and on return RHS = x.
00026 *
00027 *  The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q,
00028 *  where P and Q are permutation matrices. L is lower triangular with
00029 *  unit diagonal elements and U is upper triangular.
00030 *
00031 *  Arguments
00032 *  =========
00033 *
00034 *  IJOB    (input) INTEGER
00035 *          IJOB = 2: First compute an approximative null-vector e
00036 *              of Z using SGECON, e is normalized and solve for
00037 *              Zx = +-e - f with the sign giving the greater value
00038 *              of 2-norm(x). About 5 times as expensive as Default.
00039 *          IJOB .ne. 2: Local look ahead strategy where all entries of
00040 *              the r.h.s. b is choosen as either +1 or -1 (Default).
00041 *
00042 *  N       (input) INTEGER
00043 *          The number of columns of the matrix Z.
00044 *
00045 *  Z       (input) REAL array, dimension (LDZ, N)
00046 *          On entry, the LU part of the factorization of the n-by-n
00047 *          matrix Z computed by SGETC2:  Z = P * L * U * Q
00048 *
00049 *  LDZ     (input) INTEGER
00050 *          The leading dimension of the array Z.  LDA >= max(1, N).
00051 *
00052 *  RHS     (input/output) REAL array, dimension N.
00053 *          On entry, RHS contains contributions from other subsystems.
00054 *          On exit, RHS contains the solution of the subsystem with
00055 *          entries acoording to the value of IJOB (see above).
00056 *
00057 *  RDSUM   (input/output) REAL
00058 *          On entry, the sum of squares of computed contributions to
00059 *          the Dif-estimate under computation by STGSYL, where the
00060 *          scaling factor RDSCAL (see below) has been factored out.
00061 *          On exit, the corresponding sum of squares updated with the
00062 *          contributions from the current sub-system.
00063 *          If TRANS = 'T' RDSUM is not touched.
00064 *          NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.
00065 *
00066 *  RDSCAL  (input/output) REAL
00067 *          On entry, scaling factor used to prevent overflow in RDSUM.
00068 *          On exit, RDSCAL is updated w.r.t. the current contributions
00069 *          in RDSUM.
00070 *          If TRANS = 'T', RDSCAL is not touched.
00071 *          NOTE: RDSCAL only makes sense when STGSY2 is called by
00072 *                STGSYL.
00073 *
00074 *  IPIV    (input) INTEGER array, dimension (N).
00075 *          The pivot indices; for 1 <= i <= N, row i of the
00076 *          matrix has been interchanged with row IPIV(i).
00077 *
00078 *  JPIV    (input) INTEGER array, dimension (N).
00079 *          The pivot indices; for 1 <= j <= N, column j of the
00080 *          matrix has been interchanged with column JPIV(j).
00081 *
00082 *  Further Details
00083 *  ===============
00084 *
00085 *  Based on contributions by
00086 *     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
00087 *     Umea University, S-901 87 Umea, Sweden.
00088 *
00089 *  This routine is a further developed implementation of algorithm
00090 *  BSOLVE in [1] using complete pivoting in the LU factorization.
00091 *
00092 *  [1] Bo Kagstrom and Lars Westin,
00093 *      Generalized Schur Methods with Condition Estimators for
00094 *      Solving the Generalized Sylvester Equation, IEEE Transactions
00095 *      on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
00096 *
00097 *  [2] Peter Poromaa,
00098 *      On Efficient and Robust Estimators for the Separation
00099 *      between two Regular Matrix Pairs with Applications in
00100 *      Condition Estimation. Report IMINF-95.05, Departement of
00101 *      Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
00102 *
00103 *  =====================================================================
00104 *
00105 *     .. Parameters ..
00106       INTEGER            MAXDIM
00107       PARAMETER          ( MAXDIM = 8 )
00108       REAL               ZERO, ONE
00109       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
00110 *     ..
00111 *     .. Local Scalars ..
00112       INTEGER            I, INFO, J, K
00113       REAL               BM, BP, PMONE, SMINU, SPLUS, TEMP
00114 *     ..
00115 *     .. Local Arrays ..
00116       INTEGER            IWORK( MAXDIM )
00117       REAL               WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
00118 *     ..
00119 *     .. External Subroutines ..
00120       EXTERNAL           SAXPY, SCOPY, SGECON, SGESC2, SLASSQ, SLASWP,
00121      $                   SSCAL
00122 *     ..
00123 *     .. External Functions ..
00124       REAL               SASUM, SDOT
00125       EXTERNAL           SASUM, SDOT
00126 *     ..
00127 *     .. Intrinsic Functions ..
00128       INTRINSIC          ABS, SQRT
00129 *     ..
00130 *     .. Executable Statements ..
00131 *
00132       IF( IJOB.NE.2 ) THEN
00133 *
00134 *        Apply permutations IPIV to RHS
00135 *
00136          CALL SLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 )
00137 *
00138 *        Solve for L-part choosing RHS either to +1 or -1.
00139 *
00140          PMONE = -ONE
00141 *
00142          DO 10 J = 1, N - 1
00143             BP = RHS( J ) + ONE
00144             BM = RHS( J ) - ONE
00145             SPLUS = ONE
00146 *
00147 *           Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
00148 *           SMIN computed more efficiently than in BSOLVE [1].
00149 *
00150             SPLUS = SPLUS + SDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 )
00151             SMINU = SDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 )
00152             SPLUS = SPLUS*RHS( J )
00153             IF( SPLUS.GT.SMINU ) THEN
00154                RHS( J ) = BP
00155             ELSE IF( SMINU.GT.SPLUS ) THEN
00156                RHS( J ) = BM
00157             ELSE
00158 *
00159 *              In this case the updating sums are equal and we can
00160 *              choose RHS(J) +1 or -1. The first time this happens
00161 *              we choose -1, thereafter +1. This is a simple way to
00162 *              get good estimates of matrices like Byers well-known
00163 *              example (see [1]). (Not done in BSOLVE.)
00164 *
00165                RHS( J ) = RHS( J ) + PMONE
00166                PMONE = ONE
00167             END IF
00168 *
00169 *           Compute the remaining r.h.s.
00170 *
00171             TEMP = -RHS( J )
00172             CALL SAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 )
00173 *
00174    10    CONTINUE
00175 *
00176 *        Solve for U-part, look-ahead for RHS(N) = +-1. This is not done
00177 *        in BSOLVE and will hopefully give us a better estimate because
00178 *        any ill-conditioning of the original matrix is transfered to U
00179 *        and not to L. U(N, N) is an approximation to sigma_min(LU).
00180 *
00181          CALL SCOPY( N-1, RHS, 1, XP, 1 )
00182          XP( N ) = RHS( N ) + ONE
00183          RHS( N ) = RHS( N ) - ONE
00184          SPLUS = ZERO
00185          SMINU = ZERO
00186          DO 30 I = N, 1, -1
00187             TEMP = ONE / Z( I, I )
00188             XP( I ) = XP( I )*TEMP
00189             RHS( I ) = RHS( I )*TEMP
00190             DO 20 K = I + 1, N
00191                XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP )
00192                RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP )
00193    20       CONTINUE
00194             SPLUS = SPLUS + ABS( XP( I ) )
00195             SMINU = SMINU + ABS( RHS( I ) )
00196    30    CONTINUE
00197          IF( SPLUS.GT.SMINU )
00198      $      CALL SCOPY( N, XP, 1, RHS, 1 )
00199 *
00200 *        Apply the permutations JPIV to the computed solution (RHS)
00201 *
00202          CALL SLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
00203 *
00204 *        Compute the sum of squares
00205 *
00206          CALL SLASSQ( N, RHS, 1, RDSCAL, RDSUM )
00207 *
00208       ELSE
00209 *
00210 *        IJOB = 2, Compute approximate nullvector XM of Z
00211 *
00212          CALL SGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO )
00213          CALL SCOPY( N, WORK( N+1 ), 1, XM, 1 )
00214 *
00215 *        Compute RHS
00216 *
00217          CALL SLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
00218          TEMP = ONE / SQRT( SDOT( N, XM, 1, XM, 1 ) )
00219          CALL SSCAL( N, TEMP, XM, 1 )
00220          CALL SCOPY( N, XM, 1, XP, 1 )
00221          CALL SAXPY( N, ONE, RHS, 1, XP, 1 )
00222          CALL SAXPY( N, -ONE, XM, 1, RHS, 1 )
00223          CALL SGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP )
00224          CALL SGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP )
00225          IF( SASUM( N, XP, 1 ).GT.SASUM( N, RHS, 1 ) )
00226      $      CALL SCOPY( N, XP, 1, RHS, 1 )
00227 *
00228 *        Compute the sum of squares
00229 *
00230          CALL SLASSQ( N, RHS, 1, RDSCAL, RDSUM )
00231 *
00232       END IF
00233 *
00234       RETURN
00235 *
00236 *     End of SLATDF
00237 *
00238       END