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