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