TESTING/LIN/sdrvrf2.f

   1 *> \brief \b SDRVRF2
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *  Definition:
   9 *  ===========
  10 *
  11 *       SUBROUTINE SDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV  )
  12 *
  13 *       .. Scalar Arguments ..
  14 *       INTEGER            LDA, NN, NOUT
  15 *       ..
  16 *       .. Array Arguments ..
  17 *       INTEGER            NVAL( NN )
  18 *       REAL               A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * )
  19 *       ..
  20 *
  21 *
  22 *> \par Purpose:
  23 *  =============
  24 *>
  25 *> \verbatim
  26 *>
  27 *> SDRVRF2 tests the LAPACK RFP conversion routines.
  28 *> \endverbatim
  29 *
  30 *  Arguments:
  31 *  ==========
  32 *
  33 *> \param[in] NOUT
  34 *> \verbatim
  35 *>          NOUT is INTEGER
  36 *>                The unit number for output.
  37 *> \endverbatim
  38 *>
  39 *> \param[in] NN
  40 *> \verbatim
  41 *>          NN is INTEGER
  42 *>                The number of values of N contained in the vector NVAL.
  43 *> \endverbatim
  44 *>
  45 *> \param[in] NVAL
  46 *> \verbatim
  47 *>          NVAL is INTEGER array, dimension (NN)
  48 *>                The values of the matrix dimension N.
  49 *> \endverbatim
  50 *>
  51 *> \param[out] A
  52 *> \verbatim
  53 *>          A is REAL array, dimension (LDA,NMAX)
  54 *> \endverbatim
  55 *>
  56 *> \param[in] LDA
  57 *> \verbatim
  58 *>          LDA is INTEGER
  59 *>                The leading dimension of the array A.  LDA >= max(1,NMAX).
  60 *> \endverbatim
  61 *>
  62 *> \param[out] ARF
  63 *> \verbatim
  64 *>          ARF is REAL array, dimension ((NMAX*(NMAX+1))/2).
  65 *> \endverbatim
  66 *>
  67 *> \param[out] AP
  68 *> \verbatim
  69 *>          AP is REAL array, dimension ((NMAX*(NMAX+1))/2).
  70 *> \endverbatim
  71 *>
  72 *> \param[out] ASAV
  73 *> \verbatim
  74 *>          ASAV is REAL array, dimension (LDA,NMAX)
  75 *> \endverbatim
  76 *
  77 *  Authors:
  78 *  ========
  79 *
  80 *> \author Univ. of Tennessee
  81 *> \author Univ. of California Berkeley
  82 *> \author Univ. of Colorado Denver
  83 *> \author NAG Ltd.
  84 *
  85 *> \date November 2011
  86 *
  87 *> \ingroup single_lin
  88 *
  89 *  =====================================================================
  90       SUBROUTINE SDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV  )
  91 *
  92 *  -- LAPACK test routine (version 3.4.0) --
  93 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
  94 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  95 *     November 2011
  96 *
  97 *     .. Scalar Arguments ..
  98       INTEGER            LDA, NN, NOUT
  99 *     ..
 100 *     .. Array Arguments ..
 101       INTEGER            NVAL( NN )
 102       REAL               A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * )
 103 *     ..
 104 *
 105 *  =====================================================================
 106 *     ..
 107 *     .. Local Scalars ..
 108       LOGICAL            LOWER, OK1, OK2
 109       CHARACTER          UPLO, CFORM
 110       INTEGER            I, IFORM, IIN, INFO, IUPLO, J, N,
 111      +                   NERRS, NRUN
 112 *     ..
 113 *     .. Local Arrays ..
 114       CHARACTER          UPLOS( 2 ), FORMS( 2 )
 115       INTEGER            ISEED( 4 ), ISEEDY( 4 )
 116 *     ..
 117 *     .. External Functions ..
 118       REAL               SLARND
 119       EXTERNAL           SLARND
 120 *     ..
 121 *     .. External Subroutines ..
 122       EXTERNAL           STFTTR, STFTTP, STRTTF, STRTTP, STPTTR, STPTTF
 123 *     ..
 124 *     .. Scalars in Common ..
 125       CHARACTER*32       SRNAMT
 126 *     ..
 127 *     .. Common blocks ..
 128       COMMON             / SRNAMC / SRNAMT
 129 *     ..
 130 *     .. Data statements ..
 131       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
 132       DATA               UPLOS / 'U', 'L' /
 133       DATA               FORMS / 'N', 'T' /
 134 *     ..
 135 *     .. Executable Statements ..
 136 *
 137 *     Initialize constants and the random number seed.
 138 *
 139       NRUN = 0
 140       NERRS = 0
 141       INFO = 0
 142       DO 10 I = 1, 4
 143          ISEED( I ) = ISEEDY( I )
 144    10 CONTINUE
 145 *
 146       DO 120 IIN = 1, NN
 147 *
 148          N = NVAL( IIN )
 149 *
 150 *        Do first for UPLO = 'U', then for UPLO = 'L'
 151 *
 152          DO 110 IUPLO = 1, 2
 153 *
 154             UPLO = UPLOS( IUPLO )
 155             LOWER = .TRUE.
 156             IF ( IUPLO.EQ.1 ) LOWER = .FALSE.
 157 *
 158 *           Do first for CFORM = 'N', then for CFORM = 'T'
 159 *
 160             DO 100 IFORM = 1, 2
 161 *
 162                CFORM = FORMS( IFORM )
 163 *
 164                NRUN = NRUN + 1
 165 *
 166                DO J = 1, N
 167                   DO I = 1, N
 168                      A( I, J) = SLARND( 2, ISEED )
 169                   END DO
 170                END DO
 171 *
 172                SRNAMT = 'DTRTTF'
 173                CALL STRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO )
 174 *
 175                SRNAMT = 'DTFTTP'
 176                CALL STFTTP( CFORM, UPLO, N, ARF, AP, INFO )
 177 *
 178                SRNAMT = 'DTPTTR'
 179                CALL STPTTR( UPLO, N, AP, ASAV, LDA, INFO )
 180 *
 181                OK1 = .TRUE.
 182                IF ( LOWER ) THEN
 183                   DO J = 1, N
 184                      DO I = J, N
 185                         IF ( A(I,J).NE.ASAV(I,J) ) THEN
 186                            OK1 = .FALSE.
 187                         END IF
 188                      END DO
 189                   END DO
 190                ELSE
 191                   DO J = 1, N
 192                      DO I = 1, J
 193                         IF ( A(I,J).NE.ASAV(I,J) ) THEN
 194                            OK1 = .FALSE.
 195                         END IF
 196                      END DO
 197                   END DO
 198                END IF
 199 *
 200                NRUN = NRUN + 1
 201 *
 202                SRNAMT = 'DTRTTP'
 203                CALL STRTTP( UPLO, N, A, LDA, AP, INFO )
 204 *
 205                SRNAMT = 'DTPTTF'
 206                CALL STPTTF( CFORM, UPLO, N, AP, ARF, INFO )
 207 *
 208                SRNAMT = 'DTFTTR'
 209                CALL STFTTR( CFORM, UPLO, N, ARF, ASAV, LDA, INFO )
 210 *
 211                OK2 = .TRUE.
 212                IF ( LOWER ) THEN
 213                   DO J = 1, N
 214                      DO I = J, N
 215                         IF ( A(I,J).NE.ASAV(I,J) ) THEN
 216                            OK2 = .FALSE.
 217                         END IF
 218                      END DO
 219                   END DO
 220                ELSE
 221                   DO J = 1, N
 222                      DO I = 1, J
 223                         IF ( A(I,J).NE.ASAV(I,J) ) THEN
 224                            OK2 = .FALSE.
 225                         END IF
 226                      END DO
 227                   END DO
 228                END IF
 229 *
 230                IF (( .NOT.OK1 ).OR.( .NOT.OK2 )) THEN
 231                   IF( NERRS.EQ.0 ) THEN
 232                      WRITE( NOUT, * )
 233                      WRITE( NOUT, FMT = 9999 )
 234                   END IF
 235                   WRITE( NOUT, FMT = 9998 ) N, UPLO, CFORM
 236                   NERRS = NERRS + 1
 237                END IF
 238 *
 239   100       CONTINUE
 240   110    CONTINUE
 241   120 CONTINUE
 242 *
 243 *     Print a summary of the results.
 244 *
 245       IF ( NERRS.EQ.0 ) THEN
 246          WRITE( NOUT, FMT = 9997 ) NRUN
 247       ELSE
 248          WRITE( NOUT, FMT = 9996 ) NERRS, NRUN
 249       END IF
 250 *
 251  9999 FORMAT( 1X, ' *** Error(s) while testing the RFP conversion',
 252      +         ' routines ***')
 253  9998 FORMAT( 1X, '     Error in RFP,conversion routines N=',I5,
 254      +        ' UPLO=''', A1, ''', FORM =''',A1,'''')
 255  9997 FORMAT( 1X, 'All tests for the RFP conversion routines passed ( ',
 256      +        I5,' tests run)')
 257  9996 FORMAT( 1X, 'RFP conversion routines: ',I5,' out of ',I5,
 258      +        ' error message recorded')
 259 *
 260       RETURN
 261 *
 262 *     End of SDRVRF2
 263 *
 264       END