LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
ddrvrf4.f
Go to the documentation of this file.
00001 *> \brief \b DDRVRF4
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 DDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
00012 *      +                    LDA, D_WORK_DLANGE )
00013 * 
00014 *       .. Scalar Arguments ..
00015 *       INTEGER            LDA, LDC, NN, NOUT
00016 *       DOUBLE PRECISION   THRESH
00017 *       ..
00018 *       .. Array Arguments ..
00019 *       INTEGER            NVAL( NN )
00020 *       DOUBLE PRECISION   A( LDA, * ), C1( LDC, * ), C2( LDC, *),
00021 *      +                   CRF( * ), D_WORK_DLANGE( * )
00022 *       ..
00023 *  
00024 *
00025 *> \par Purpose:
00026 *  =============
00027 *>
00028 *> \verbatim
00029 *>
00030 *> DDRVRF4 tests the LAPACK RFP routines:
00031 *>     DSFRK
00032 *> \endverbatim
00033 *
00034 *  Arguments:
00035 *  ==========
00036 *
00037 *> \param[in] NOUT
00038 *> \verbatim
00039 *>          NOUT is INTEGER
00040 *>                The unit number for output.
00041 *> \endverbatim
00042 *>
00043 *> \param[in] NN
00044 *> \verbatim
00045 *>          NN is INTEGER
00046 *>                The number of values of N contained in the vector NVAL.
00047 *> \endverbatim
00048 *>
00049 *> \param[in] NVAL
00050 *> \verbatim
00051 *>          NVAL is INTEGER array, dimension (NN)
00052 *>                The values of the matrix dimension N.
00053 *> \endverbatim
00054 *>
00055 *> \param[in] THRESH
00056 *> \verbatim
00057 *>          THRESH is DOUBLE PRECISION
00058 *>                The threshold value for the test ratios.  A result is
00059 *>                included in the output file if RESULT >= THRESH.  To
00060 *>                have every test ratio printed, use THRESH = 0.
00061 *> \endverbatim
00062 *>
00063 *> \param[out] C1
00064 *> \verbatim
00065 *>          C1 is DOUBLE PRECISION array,
00066 *>                dimension (LDC,NMAX)
00067 *> \endverbatim
00068 *>
00069 *> \param[out] C2
00070 *> \verbatim
00071 *>          C2 is DOUBLE PRECISION array,
00072 *>                dimension (LDC,NMAX)
00073 *> \endverbatim
00074 *>
00075 *> \param[in] LDC
00076 *> \verbatim
00077 *>          LDC is INTEGER
00078 *>                The leading dimension of the array A.
00079 *>                LDA >= max(1,NMAX).
00080 *> \endverbatim
00081 *>
00082 *> \param[out] CRF
00083 *> \verbatim
00084 *>          CRF is DOUBLE PRECISION array,
00085 *>                dimension ((NMAX*(NMAX+1))/2).
00086 *> \endverbatim
00087 *>
00088 *> \param[out] A
00089 *> \verbatim
00090 *>          A is DOUBLE PRECISION array,
00091 *>                dimension (LDA,NMAX)
00092 *> \endverbatim
00093 *>
00094 *> \param[in] LDA
00095 *> \verbatim
00096 *>          LDA is INTEGER
00097 *>                The leading dimension of the array A.  LDA >= max(1,NMAX).
00098 *> \endverbatim
00099 *>
00100 *> \param[out] D_WORK_DLANGE
00101 *> \verbatim
00102 *>          D_WORK_DLANGE 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 DDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
00119      +                    LDA, D_WORK_DLANGE )
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, LDC, NN, NOUT
00128       DOUBLE PRECISION   THRESH
00129 *     ..
00130 *     .. Array Arguments ..
00131       INTEGER            NVAL( NN )
00132       DOUBLE PRECISION   A( LDA, * ), C1( LDC, * ), C2( LDC, *),
00133      +                   CRF( * ), D_WORK_DLANGE( * )
00134 *     ..
00135 *
00136 *  =====================================================================
00137 *     ..
00138 *     .. Parameters ..
00139       DOUBLE PRECISION   ZERO, ONE
00140       PARAMETER          ( ZERO = 0.0D+0, ONE  = 1.0D+0 )
00141       INTEGER            NTESTS
00142       PARAMETER          ( NTESTS = 1 )
00143 *     ..
00144 *     .. Local Scalars ..
00145       CHARACTER          UPLO, CFORM, TRANS
00146       INTEGER            I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
00147      +                   NFAIL, NRUN, IALPHA, ITRANS
00148       DOUBLE PRECISION   ALPHA, BETA, EPS, NORMA, NORMC
00149 *     ..
00150 *     .. Local Arrays ..
00151       CHARACTER          UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
00152       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00153       DOUBLE PRECISION   RESULT( NTESTS )
00154 *     ..
00155 *     .. External Functions ..
00156       DOUBLE PRECISION   DLAMCH, DLARND, DLANGE
00157       EXTERNAL           DLAMCH, DLARND, DLANGE
00158 *     ..
00159 *     .. External Subroutines ..
00160       EXTERNAL           DSYRK, DSFRK, DTFTTR, DTRTTF
00161 *     ..
00162 *     .. Intrinsic Functions ..
00163       INTRINSIC          ABS, MAX
00164 *     ..
00165 *     .. Scalars in Common ..
00166       CHARACTER*32       SRNAMT
00167 *     ..
00168 *     .. Common blocks ..
00169       COMMON             / SRNAMC / SRNAMT
00170 *     ..
00171 *     .. Data statements ..
00172       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00173       DATA               UPLOS  / 'U', 'L' /
00174       DATA               FORMS  / 'N', 'T' /
00175       DATA               TRANSS / 'N', 'T' /
00176 *     ..
00177 *     .. Executable Statements ..
00178 *
00179 *     Initialize constants and the random number seed.
00180 *
00181       NRUN = 0
00182       NFAIL = 0
00183       INFO = 0
00184       DO 10 I = 1, 4
00185          ISEED( I ) = ISEEDY( I )
00186    10 CONTINUE
00187       EPS = DLAMCH( 'Precision' )
00188 *
00189       DO 150 IIN = 1, NN
00190 *
00191          N = NVAL( IIN )
00192 *
00193          DO 140 IIK = 1, NN
00194 *
00195             K = NVAL( IIN )
00196 *
00197             DO 130 IFORM = 1, 2
00198 *
00199                CFORM = FORMS( IFORM )
00200 *
00201                DO 120 IUPLO = 1, 2
00202 *
00203                   UPLO = UPLOS( IUPLO )
00204 *
00205                   DO 110 ITRANS = 1, 2
00206 *
00207                      TRANS = TRANSS( ITRANS )
00208 *
00209                      DO 100 IALPHA = 1, 4
00210 *
00211                         IF ( IALPHA.EQ. 1) THEN
00212                            ALPHA = ZERO
00213                            BETA = ZERO
00214                         ELSE IF ( IALPHA.EQ. 2) THEN
00215                            ALPHA = ONE
00216                            BETA = ZERO
00217                         ELSE IF ( IALPHA.EQ. 3) THEN
00218                            ALPHA = ZERO
00219                            BETA = ONE
00220                         ELSE
00221                            ALPHA = DLARND( 2, ISEED )
00222                            BETA = DLARND( 2, ISEED )
00223                         END IF
00224 *
00225 *                       All the parameters are set:
00226 *                          CFORM, UPLO, TRANS, M, N,
00227 *                          ALPHA, and BETA
00228 *                       READY TO TEST!
00229 *
00230                         NRUN = NRUN + 1
00231 *
00232                         IF ( ITRANS.EQ.1 ) THEN
00233 *
00234 *                          In this case we are NOTRANS, so A is N-by-K
00235 *
00236                            DO J = 1, K
00237                               DO I = 1, N
00238                                  A( I, J) = DLARND( 2, ISEED )
00239                               END DO
00240                            END DO
00241 *
00242                            NORMA = DLANGE( 'I', N, K, A, LDA,
00243      +                                      D_WORK_DLANGE )
00244 *
00245  
00246                         ELSE
00247 *
00248 *                          In this case we are TRANS, so A is K-by-N
00249 *
00250                            DO J = 1,N 
00251                               DO I = 1, K
00252                                  A( I, J) = DLARND( 2, ISEED )
00253                               END DO
00254                            END DO
00255 *
00256                            NORMA = DLANGE( 'I', K, N, A, LDA,
00257      +                                      D_WORK_DLANGE )
00258 *
00259                         END IF
00260 *
00261 *                       Generate C1 our N--by--N symmetric matrix. 
00262 *                       Make sure C2 has the same upper/lower part,
00263 *                       (the one that we do not touch), so
00264 *                       copy the initial C1 in C2 in it.
00265 *
00266                         DO J = 1, N
00267                            DO I = 1, N
00268                               C1( I, J) = DLARND( 2, ISEED )
00269                               C2(I,J) = C1(I,J)
00270                            END DO
00271                         END DO
00272 *
00273 *                       (See comment later on for why we use DLANGE and
00274 *                       not DLANSY for C1.)
00275 *
00276                         NORMC = DLANGE( 'I', N, N, C1, LDC,
00277      +                                      D_WORK_DLANGE )
00278 *
00279                         SRNAMT = 'DTRTTF'
00280                         CALL DTRTTF( CFORM, UPLO, N, C1, LDC, CRF,
00281      +                               INFO )
00282 *
00283 *                       call dsyrk the BLAS routine -> gives C1
00284 *
00285                         SRNAMT = 'DSYRK '
00286                         CALL DSYRK( UPLO, TRANS, N, K, ALPHA, A, LDA,
00287      +                              BETA, C1, LDC )
00288 *
00289 *                       call dsfrk the RFP routine -> gives CRF
00290 *
00291                         SRNAMT = 'DSFRK '
00292                         CALL DSFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A,
00293      +                              LDA, BETA, CRF )
00294 *
00295 *                       convert CRF in full format -> gives C2
00296 *
00297                         SRNAMT = 'DTFTTR'
00298                         CALL DTFTTR( CFORM, UPLO, N, CRF, C2, LDC,
00299      +                               INFO )
00300 *
00301 *                       compare C1 and C2
00302 *
00303                         DO J = 1, N
00304                            DO I = 1, N
00305                               C1(I,J) = C1(I,J)-C2(I,J)
00306                            END DO
00307                         END DO
00308 *
00309 *                       Yes, C1 is symmetric so we could call DLANSY,
00310 *                       but we want to check the upper part that is
00311 *                       supposed to be unchanged and the diagonal that
00312 *                       is supposed to be real -> DLANGE
00313 *
00314                         RESULT(1) = DLANGE( 'I', N, N, C1, LDC,
00315      +                                      D_WORK_DLANGE )
00316                         RESULT(1) = RESULT(1) 
00317      +                              / MAX( ABS( ALPHA ) * NORMA
00318      +                                   + ABS( BETA ) , ONE )
00319      +                              / MAX( N , 1 ) / EPS
00320 *
00321                         IF( RESULT(1).GE.THRESH ) THEN
00322                            IF( NFAIL.EQ.0 ) THEN
00323                               WRITE( NOUT, * )
00324                               WRITE( NOUT, FMT = 9999 )
00325                            END IF
00326                            WRITE( NOUT, FMT = 9997 ) 'DSFRK', 
00327      +                        CFORM, UPLO, TRANS, N, K, RESULT(1)
00328                            NFAIL = NFAIL + 1
00329                         END IF
00330 *
00331   100                CONTINUE
00332   110             CONTINUE
00333   120          CONTINUE
00334   130       CONTINUE
00335   140    CONTINUE
00336   150 CONTINUE
00337 *
00338 *     Print a summary of the results.
00339 *
00340       IF ( NFAIL.EQ.0 ) THEN
00341          WRITE( NOUT, FMT = 9996 ) 'DSFRK', NRUN
00342       ELSE
00343          WRITE( NOUT, FMT = 9995 ) 'DSFRK', NFAIL, NRUN
00344       END IF
00345 *
00346  9999 FORMAT( 1X, 
00347 ' *** Error(s) or Failure(s) while testing DSFRK      +         ***')
00348  9997 FORMAT( 1X, '     Failure in ',A5,', CFORM=''',A1,''',',
00349      + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3,
00350      + ', test=',G12.5)
00351  9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ',
00352      +        'threshold ( ',I5,' tests run)')
00353  9995 FORMAT( 1X, A6, ' auxiliary routine: ',I5,' out of ',I5,
00354      +        ' tests failed to pass the threshold')
00355 *
00356       RETURN
00357 *
00358 *     End of DDRVRF4
00359 *
00360       END
 All Files Functions