LAPACK: TESTING/LIN/cdrvrf4.f Source File

Go to the documentation of this file.
00001       SUBROUTINE CDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
00002      +                    LDA, S_WORK_CLANGE )
00003 *
00004 *  -- LAPACK test routine (version 3.2.0) --
00005 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00006 *     November 2008
00007 *
00008 *     .. Scalar Arguments ..
00009       INTEGER            LDA, LDC, NN, NOUT
00010       REAL               THRESH
00011 *     ..
00012 *     .. Array Arguments ..
00013       INTEGER            NVAL( NN )
00014       REAL               S_WORK_CLANGE( * )
00015       COMPLEX            A( LDA, * ), C1( LDC, * ), C2( LDC, *),
00016      +                   CRF( * )
00017 *     ..
00018 *
00019 *  Purpose
00020 *  =======
00021 *
00022 *  CDRVRF4 tests the LAPACK RFP routines:
00023 *      CHFRK
00024 *
00025 *  Arguments
00026 *  =========
00027 *
00028 *  NOUT          (input) INTEGER
00029 *                The unit number for output.
00030 *
00031 *  NN            (input) INTEGER
00032 *                The number of values of N contained in the vector NVAL.
00033 *
00034 *  NVAL          (input) INTEGER array, dimension (NN)
00035 *                The values of the matrix dimension N.
00036 *
00037 *  THRESH        (input) REAL
00038 *                The threshold value for the test ratios.  A result is
00039 *                included in the output file if RESULT >= THRESH.  To have
00040 *                every test ratio printed, use THRESH = 0.
00041 *
00042 *  C1            (workspace) COMPLEX array, dimension (LDC,NMAX)
00043 *
00044 *  C2            (workspace) COMPLEX array, dimension (LDC,NMAX)
00045 *
00046 *  LDC           (input) INTEGER
00047 *                The leading dimension of the array A.  LDA >= max(1,NMAX).
00048 *
00049 *  CRF           (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2).
00050 *
00051 *  A             (workspace) COMPLEX array, dimension (LDA,NMAX)
00052 *
00053 *  LDA           (input) INTEGER
00054 *                The leading dimension of the array A.  LDA >= max(1,NMAX).
00055 *
00056 *  S_WORK_CLANGE (workspace) REAL array, dimension (NMAX)
00057 *
00058 *  =====================================================================
00059 *     ..
00060 *     .. Parameters ..
00061       REAL               ZERO, ONE
00062       PARAMETER          ( ZERO = 0.0E+0, ONE  = 1.0E+0 )
00063       INTEGER            NTESTS
00064       PARAMETER          ( NTESTS = 1 )
00065 *     ..
00066 *     .. Local Scalars ..
00067       CHARACTER          UPLO, CFORM, TRANS
00068       INTEGER            I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
00069      +                   NFAIL, NRUN, IALPHA, ITRANS
00070       REAL               ALPHA, BETA, EPS, NORMA, NORMC
00071 *     ..
00072 *     .. Local Arrays ..
00073       CHARACTER          UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
00074       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00075       REAL               RESULT( NTESTS )
00076 *     ..
00077 *     .. External Functions ..
00078       REAL               SLAMCH, SLARND, CLANGE
00079       COMPLEX            CLARND
00080       EXTERNAL           SLAMCH, SLARND, CLANGE, CLARND
00081 *     ..
00082 *     .. External Subroutines ..
00083       EXTERNAL           CHERK, CHFRK, CTFTTR, CTRTTF
00084 *     ..
00085 *     .. Intrinsic Functions ..
00086       INTRINSIC          ABS, MAX
00087 *     ..
00088 *     .. Scalars in Common ..
00089       CHARACTER*32       SRNAMT
00090 *     ..
00091 *     .. Common blocks ..
00092       COMMON             / SRNAMC / SRNAMT
00093 *     ..
00094 *     .. Data statements ..
00095       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00096       DATA               UPLOS  / 'U', 'L' /
00097       DATA               FORMS  / 'N', 'C' /
00098       DATA               TRANSS / 'N', 'C' /
00099 *     ..
00100 *     .. Executable Statements ..
00101 *
00102 *     Initialize constants and the random number seed.
00103 *
00104       NRUN = 0
00105       NFAIL = 0
00106       INFO = 0
00107       DO 10 I = 1, 4
00108          ISEED( I ) = ISEEDY( I )
00109    10 CONTINUE
00110       EPS = SLAMCH( 'Precision' )
00111 *
00112       DO 150 IIN = 1, NN
00113 *
00114          N = NVAL( IIN )
00115 *
00116          DO 140 IIK = 1, NN
00117 *
00118             K = NVAL( IIN )
00119 *
00120             DO 130 IFORM = 1, 2
00121 *
00122                CFORM = FORMS( IFORM )
00123 *
00124                DO 120 IUPLO = 1, 2
00125 *
00126                   UPLO = UPLOS( IUPLO )
00127 *
00128                   DO 110 ITRANS = 1, 2
00129 *
00130                      TRANS = TRANSS( ITRANS )
00131 *
00132                      DO 100 IALPHA = 1, 4
00133 *
00134                         IF ( IALPHA.EQ. 1) THEN
00135                            ALPHA = ZERO
00136                            BETA = ZERO
00137                         ELSE IF ( IALPHA.EQ. 1) THEN
00138                            ALPHA = ONE
00139                            BETA = ZERO
00140                         ELSE IF ( IALPHA.EQ. 1) THEN
00141                            ALPHA = ZERO
00142                            BETA = ONE
00143                         ELSE
00144                            ALPHA = SLARND( 2, ISEED )
00145                            BETA = SLARND( 2, ISEED )
00146                         END IF
00147 *
00148 *                       All the parameters are set:
00149 *                          CFORM, UPLO, TRANS, M, N,
00150 *                          ALPHA, and BETA
00151 *                       READY TO TEST!
00152 *
00153                         NRUN = NRUN + 1
00154 *
00155                         IF ( ITRANS.EQ.1 ) THEN
00156 *
00157 *                          In this case we are NOTRANS, so A is N-by-K
00158 *
00159                            DO J = 1, K
00160                               DO I = 1, N
00161                                  A( I, J) = CLARND( 4, ISEED )
00162                               END DO
00163                            END DO
00164 *
00165                            NORMA = CLANGE( 'I', N, K, A, LDA,
00166      +                                      S_WORK_CLANGE )
00167 *
00168                         ELSE
00169 *
00170 *                          In this case we are TRANS, so A is K-by-N
00171 *
00172                            DO J = 1,N 
00173                               DO I = 1, K
00174                                  A( I, J) = CLARND( 4, ISEED )
00175                               END DO
00176                            END DO
00177 *
00178                            NORMA = CLANGE( 'I', K, N, A, LDA,
00179      +                                      S_WORK_CLANGE )
00180 *
00181                         END IF
00182 *
00183 *
00184 *                       Generate C1 our N--by--N Hermitian matrix. 
00185 *                       Make sure C2 has the same upper/lower part,
00186 *                       (the one that we do not touch), so
00187 *                       copy the initial C1 in C2 in it.
00188 *
00189                         DO J = 1, N
00190                            DO I = 1, N
00191                               C1( I, J) = CLARND( 4, ISEED )
00192                               C2(I,J) = C1(I,J)
00193                            END DO
00194                         END DO
00195 *
00196 *                       (See comment later on for why we use CLANGE and
00197 *                       not CLANHE for C1.)
00198 *
00199                         NORMC = CLANGE( 'I', N, N, C1, LDC,
00200      +                                      S_WORK_CLANGE )
00201 *
00202                         SRNAMT = 'CTRTTF'
00203                         CALL CTRTTF( CFORM, UPLO, N, C1, LDC, CRF,
00204      +                               INFO )
00205 *
00206 *                       call zherk the BLAS routine -> gives C1
00207 *
00208                         SRNAMT = 'CHERK '
00209                         CALL CHERK( UPLO, TRANS, N, K, ALPHA, A, LDA,
00210      +                              BETA, C1, LDC )
00211 *
00212 *                       call zhfrk the RFP routine -> gives CRF
00213 *
00214                         SRNAMT = 'CHFRK '
00215                         CALL CHFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A,
00216      +                              LDA, BETA, CRF )
00217 *
00218 *                       convert CRF in full format -> gives C2
00219 *
00220                         SRNAMT = 'CTFTTR'
00221                         CALL CTFTTR( CFORM, UPLO, N, CRF, C2, LDC,
00222      +                               INFO )
00223 *
00224 *                       compare C1 and C2
00225 *
00226                         DO J = 1, N
00227                            DO I = 1, N
00228                               C1(I,J) = C1(I,J)-C2(I,J)
00229                            END DO
00230                         END DO
00231 *
00232 *                       Yes, C1 is Hermitian so we could call CLANHE,
00233 *                       but we want to check the upper part that is
00234 *                       supposed to be unchanged and the diagonal that
00235 *                       is supposed to be real -> CLANGE
00236 *
00237                         RESULT(1) = CLANGE( 'I', N, N, C1, LDC,
00238      +                                      S_WORK_CLANGE )
00239                         RESULT(1) = RESULT(1) 
00240      +                              / MAX( ABS( ALPHA ) * NORMA * NORMA
00241      +                                   + ABS( BETA ) * NORMC, ONE )
00242      +                              / MAX( N , 1 ) / EPS
00243 *
00244                         IF( RESULT(1).GE.THRESH ) THEN
00245                            IF( NFAIL.EQ.0 ) THEN
00246                               WRITE( NOUT, * )
00247                               WRITE( NOUT, FMT = 9999 )
00248                            END IF
00249                            WRITE( NOUT, FMT = 9997 ) 'CHFRK', 
00250      +                        CFORM, UPLO, TRANS, N, K, RESULT(1)
00251                            NFAIL = NFAIL + 1
00252                         END IF
00253 *
00254   100                CONTINUE
00255   110             CONTINUE
00256   120          CONTINUE
00257   130       CONTINUE
00258   140    CONTINUE
00259   150 CONTINUE
00260 *
00261 *     Print a summary of the results.
00262 *
00263       IF ( NFAIL.EQ.0 ) THEN
00264          WRITE( NOUT, FMT = 9996 ) 'CHFRK', NRUN
00265       ELSE
00266          WRITE( NOUT, FMT = 9995 ) 'CHFRK', NFAIL, NRUN
00267       END IF
00268 *
00269  9999 FORMAT( 1X, 
00270 ' *** Error(s) or Failure(s) while testing CHFRK      +         ***')
00271  9997 FORMAT( 1X, '     Failure in ',A5,', CFORM=''',A1,''',',
00272      + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3,
00273      + ', test=',G12.5)
00274  9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ',
00275      +        'threshold (',I5,' tests run)')
00276  9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5,
00277      +        ' tests failed to pass the threshold')
00278 *
00279       RETURN
00280 *
00281 *     End of CDRVRF4
00282 *
00283       END