LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
zdrvrf3.f
Go to the documentation of this file.
00001 *> \brief \b ZDRVRF3
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 ZDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
00012 *      +                    D_WORK_ZLANGE, Z_WORK_ZGEQRF, TAU )
00013 * 
00014 *       .. Scalar Arguments ..
00015 *       INTEGER            LDA, NN, NOUT
00016 *       DOUBLE PRECISION   THRESH
00017 *       ..
00018 *       .. Array Arguments ..
00019 *       INTEGER            NVAL( NN )
00020 *       DOUBLE PRECISION   D_WORK_ZLANGE( * )
00021 *       COMPLEX*16         A( LDA, * ), ARF( * ), B1( LDA, * ),
00022 *      +                   B2( LDA, * )
00023 *       COMPLEX*16         Z_WORK_ZGEQRF( * ), TAU( * )
00024 *       ..
00025 *  
00026 *
00027 *> \par Purpose:
00028 *  =============
00029 *>
00030 *> \verbatim
00031 *>
00032 *> ZDRVRF3 tests the LAPACK RFP routines:
00033 *>     ZTFSM
00034 *> \endverbatim
00035 *
00036 *  Arguments:
00037 *  ==========
00038 *
00039 *> \param[in] NOUT
00040 *> \verbatim
00041 *>          NOUT is INTEGER
00042 *>                The unit number for output.
00043 *> \endverbatim
00044 *>
00045 *> \param[in] NN
00046 *> \verbatim
00047 *>          NN is INTEGER
00048 *>                The number of values of N contained in the vector NVAL.
00049 *> \endverbatim
00050 *>
00051 *> \param[in] NVAL
00052 *> \verbatim
00053 *>          NVAL is INTEGER array, dimension (NN)
00054 *>                The values of the matrix dimension N.
00055 *> \endverbatim
00056 *>
00057 *> \param[in] THRESH
00058 *> \verbatim
00059 *>          THRESH is DOUBLE PRECISION
00060 *>                The threshold value for the test ratios.  A result is
00061 *>                included in the output file if RESULT >= THRESH.  To have
00062 *>                every test ratio printed, use THRESH = 0.
00063 *> \endverbatim
00064 *>
00065 *> \param[out] A
00066 *> \verbatim
00067 *>          A is COMPLEX*16 array, dimension (LDA,NMAX)
00068 *> \endverbatim
00069 *>
00070 *> \param[in] LDA
00071 *> \verbatim
00072 *>          LDA is INTEGER
00073 *>                The leading dimension of the array A.  LDA >= max(1,NMAX).
00074 *> \endverbatim
00075 *>
00076 *> \param[out] ARF
00077 *> \verbatim
00078 *>          ARF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
00079 *> \endverbatim
00080 *>
00081 *> \param[out] B1
00082 *> \verbatim
00083 *>          B1 is COMPLEX*16 array, dimension (LDA,NMAX)
00084 *> \endverbatim
00085 *>
00086 *> \param[out] B2
00087 *> \verbatim
00088 *>          B2 is COMPLEX*16 array, dimension (LDA,NMAX)
00089 *> \endverbatim
00090 *>
00091 *> \param[out] D_WORK_ZLANGE
00092 *> \verbatim
00093 *>          D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX)
00094 *> \endverbatim
00095 *>
00096 *> \param[out] Z_WORK_ZGEQRF
00097 *> \verbatim
00098 *>          Z_WORK_ZGEQRF is COMPLEX*16 array, dimension (NMAX)
00099 *> \endverbatim
00100 *>
00101 *> \param[out] TAU
00102 *> \verbatim
00103 *>          TAU is COMPLEX*16 array, dimension (NMAX)
00104 *> \endverbatim
00105 *
00106 *  Authors:
00107 *  ========
00108 *
00109 *> \author Univ. of Tennessee 
00110 *> \author Univ. of California Berkeley 
00111 *> \author Univ. of Colorado Denver 
00112 *> \author NAG Ltd. 
00113 *
00114 *> \date November 2011
00115 *
00116 *> \ingroup complex16_lin
00117 *
00118 *  =====================================================================
00119       SUBROUTINE ZDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
00120      +                    D_WORK_ZLANGE, Z_WORK_ZGEQRF, TAU )
00121 *
00122 *  -- LAPACK test routine (version 3.4.0) --
00123 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00124 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00125 *     November 2011
00126 *
00127 *     .. Scalar Arguments ..
00128       INTEGER            LDA, NN, NOUT
00129       DOUBLE PRECISION   THRESH
00130 *     ..
00131 *     .. Array Arguments ..
00132       INTEGER            NVAL( NN )
00133       DOUBLE PRECISION   D_WORK_ZLANGE( * )
00134       COMPLEX*16         A( LDA, * ), ARF( * ), B1( LDA, * ),
00135      +                   B2( LDA, * )
00136       COMPLEX*16         Z_WORK_ZGEQRF( * ), TAU( * )
00137 *     ..
00138 *
00139 *  =====================================================================
00140 *     ..
00141 *     .. Parameters ..
00142       COMPLEX*16         ZERO, ONE
00143       PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) ,
00144      +                     ONE  = ( 1.0D+0, 0.0D+0 ) )
00145       INTEGER            NTESTS
00146       PARAMETER          ( NTESTS = 1 )
00147 *     ..
00148 *     .. Local Scalars ..
00149       CHARACTER          UPLO, CFORM, DIAG, TRANS, SIDE
00150       INTEGER            I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
00151      +                   NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS
00152       COMPLEX*16         ALPHA
00153       DOUBLE PRECISION   EPS
00154 *     ..
00155 *     .. Local Arrays ..
00156       CHARACTER          UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
00157      +                   DIAGS( 2 ), SIDES( 2 )
00158       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00159       DOUBLE PRECISION   RESULT( NTESTS )
00160 *     ..
00161 *     .. External Functions ..
00162       DOUBLE PRECISION   DLAMCH, ZLANGE
00163       COMPLEX*16         ZLARND
00164       EXTERNAL           DLAMCH, ZLARND, ZLANGE
00165 *     ..
00166 *     .. External Subroutines ..
00167       EXTERNAL           ZTRTTF, ZGEQRF, ZGEQLF, ZTFSM, ZTRSM
00168 *     ..
00169 *     .. Intrinsic Functions ..
00170       INTRINSIC          MAX, SQRT
00171 *     ..
00172 *     .. Scalars in Common ..
00173       CHARACTER*32       SRNAMT
00174 *     ..
00175 *     .. Common blocks ..
00176       COMMON             / SRNAMC / SRNAMT
00177 *     ..
00178 *     .. Data statements ..
00179       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00180       DATA               UPLOS  / 'U', 'L' /
00181       DATA               FORMS  / 'N', 'C' /
00182       DATA               SIDES  / 'L', 'R' /
00183       DATA               TRANSS / 'N', 'C' /
00184       DATA               DIAGS  / 'N', 'U' /
00185 *     ..
00186 *     .. Executable Statements ..
00187 *
00188 *     Initialize constants and the random number seed.
00189 *
00190       NRUN = 0
00191       NFAIL = 0
00192       INFO = 0
00193       DO 10 I = 1, 4
00194          ISEED( I ) = ISEEDY( I )
00195    10 CONTINUE
00196       EPS = DLAMCH( 'Precision' )
00197 *
00198       DO 170 IIM = 1, NN
00199 *
00200          M = NVAL( IIM )
00201 *
00202          DO 160 IIN = 1, NN
00203 *
00204             N = NVAL( IIN )
00205 *
00206             DO 150 IFORM = 1, 2
00207 *
00208                CFORM = FORMS( IFORM )
00209 *
00210                DO 140 IUPLO = 1, 2
00211 *
00212                   UPLO = UPLOS( IUPLO )
00213 *
00214                   DO 130 ISIDE = 1, 2
00215 *
00216                      SIDE = SIDES( ISIDE )
00217 *
00218                      DO 120 ITRANS = 1, 2
00219 *
00220                         TRANS = TRANSS( ITRANS )
00221 *
00222                         DO 110 IDIAG = 1, 2
00223 *
00224                            DIAG = DIAGS( IDIAG )
00225 *
00226                            DO 100 IALPHA = 1, 3
00227 *
00228                               IF ( IALPHA.EQ. 1) THEN
00229                                  ALPHA = ZERO
00230                               ELSE IF ( IALPHA.EQ. 1) THEN
00231                                  ALPHA = ONE
00232                               ELSE
00233                                  ALPHA = ZLARND( 4, ISEED )
00234                               END IF
00235 *
00236 *                             All the parameters are set:
00237 *                                CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
00238 *                                and ALPHA
00239 *                             READY TO TEST!
00240 *
00241                               NRUN = NRUN + 1
00242 *
00243                               IF ( ISIDE.EQ.1 ) THEN
00244 *
00245 *                                The case ISIDE.EQ.1 is when SIDE.EQ.'L'
00246 *                                -> A is M-by-M ( B is M-by-N )
00247 *
00248                                  NA = M
00249 *
00250                               ELSE
00251 *
00252 *                                The case ISIDE.EQ.2 is when SIDE.EQ.'R'
00253 *                                -> A is N-by-N ( B is M-by-N )
00254 *
00255                                  NA = N
00256 *
00257                               END IF
00258 *
00259 *                             Generate A our NA--by--NA triangular
00260 *                             matrix. 
00261 *                             Our test is based on forward error so we
00262 *                             do want A to be well conditionned! To get
00263 *                             a well-conditionned triangular matrix, we
00264 *                             take the R factor of the QR/LQ factorization
00265 *                             of a random matrix. 
00266 *
00267                               DO J = 1, NA
00268                                  DO I = 1, NA
00269                                     A( I, J) = ZLARND( 4, ISEED )
00270                                  END DO
00271                               END DO
00272 *
00273                               IF ( IUPLO.EQ.1 ) THEN
00274 *
00275 *                                The case IUPLO.EQ.1 is when SIDE.EQ.'U'
00276 *                                -> QR factorization.
00277 *
00278                                  SRNAMT = 'ZGEQRF'
00279                                  CALL ZGEQRF( NA, NA, A, LDA, TAU,
00280      +                                        Z_WORK_ZGEQRF, LDA,
00281      +                                        INFO )
00282                               ELSE
00283 *
00284 *                                The case IUPLO.EQ.2 is when SIDE.EQ.'L'
00285 *                                -> QL factorization.
00286 *
00287                                  SRNAMT = 'ZGELQF'
00288                                  CALL ZGELQF( NA, NA, A, LDA, TAU,
00289      +                                        Z_WORK_ZGEQRF, LDA,
00290      +                                        INFO )
00291                               END IF
00292 *
00293 *                             After the QR factorization, the diagonal
00294 *                             of A is made of real numbers, we multiply
00295 *                             by a random complex number of absolute 
00296 *                             value 1.0E+00.
00297 *
00298                               DO J = 1, NA
00299                                  A( J, J) = A(J,J) * ZLARND( 5, ISEED )
00300                               END DO
00301 *
00302 *                             Store a copy of A in RFP format (in ARF).
00303 *
00304                               SRNAMT = 'ZTRTTF'
00305                               CALL ZTRTTF( CFORM, UPLO, NA, A, LDA, ARF,
00306      +                                     INFO )
00307 *
00308 *                             Generate B1 our M--by--N right-hand side
00309 *                             and store a copy in B2.
00310 *
00311                               DO J = 1, N
00312                                  DO I = 1, M
00313                                     B1( I, J) = ZLARND( 4, ISEED )
00314                                     B2( I, J) = B1( I, J)
00315                                  END DO
00316                               END DO
00317 *
00318 *                             Solve op( A ) X = B or X op( A ) = B
00319 *                             with ZTRSM
00320 *
00321                               SRNAMT = 'ZTRSM'
00322                               CALL ZTRSM( SIDE, UPLO, TRANS, DIAG, M, N,
00323      +                               ALPHA, A, LDA, B1, LDA )
00324 *
00325 *                             Solve op( A ) X = B or X op( A ) = B
00326 *                             with ZTFSM
00327 *
00328                               SRNAMT = 'ZTFSM'
00329                               CALL ZTFSM( CFORM, SIDE, UPLO, TRANS,
00330      +                                    DIAG, M, N, ALPHA, ARF, B2,
00331      +                                    LDA )
00332 *
00333 *                             Check that the result agrees.
00334 *
00335                               DO J = 1, N
00336                                  DO I = 1, M
00337                                     B1( I, J) = B2( I, J ) - B1( I, J )
00338                                  END DO
00339                               END DO
00340 *
00341                               RESULT(1) = ZLANGE( 'I', M, N, B1, LDA,
00342      +                                            D_WORK_ZLANGE )
00343 *
00344                               RESULT(1) = RESULT(1) / SQRT( EPS )
00345      +                                    / MAX ( MAX( M, N), 1 )
00346 *
00347                               IF( RESULT(1).GE.THRESH ) THEN
00348                                  IF( NFAIL.EQ.0 ) THEN
00349                                     WRITE( NOUT, * )
00350                                     WRITE( NOUT, FMT = 9999 )
00351                                  END IF
00352                                  WRITE( NOUT, FMT = 9997 ) 'ZTFSM', 
00353      +                              CFORM, SIDE, UPLO, TRANS, DIAG, M,
00354      +                              N, RESULT(1)
00355                                  NFAIL = NFAIL + 1
00356                               END IF
00357 *
00358   100                      CONTINUE
00359   110                   CONTINUE
00360   120                CONTINUE
00361   130             CONTINUE
00362   140          CONTINUE
00363   150       CONTINUE
00364   160    CONTINUE
00365   170 CONTINUE
00366 *
00367 *     Print a summary of the results.
00368 *
00369       IF ( NFAIL.EQ.0 ) THEN
00370          WRITE( NOUT, FMT = 9996 ) 'ZTFSM', NRUN
00371       ELSE
00372          WRITE( NOUT, FMT = 9995 ) 'ZTFSM', NFAIL, NRUN
00373       END IF
00374 *
00375  9999 FORMAT( 1X, 
00376 ' *** Error(s) or Failure(s) while testing ZTFSM      +         ***')
00377  9997 FORMAT( 1X, '     Failure in ',A5,', CFORM=''',A1,''',',
00378      + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',',
00379      + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5)
00380  9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ',
00381      +        'threshold ( ',I5,' tests run)')
00382  9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5,
00383      +        ' tests failed to pass the threshold')
00384 *
00385       RETURN
00386 *
00387 *     End of ZDRVRF3
00388 *
00389       END
 All Files Functions