LAPACK 3.3.0

sdrvrf2.f

Go to the documentation of this file.
00001       SUBROUTINE SDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV  )
00002 *
00003 *  -- LAPACK test routine (version 3.2.0) --
00004 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00005 *     November 2008
00006 *
00007 *     .. Scalar Arguments ..
00008       INTEGER            LDA, NN, NOUT
00009 *     ..
00010 *     .. Array Arguments ..
00011       INTEGER            NVAL( NN )
00012       REAL               A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * )
00013 *     ..
00014 *
00015 *  Purpose
00016 *  =======
00017 *
00018 *  SDRVRF2 tests the LAPACK RFP convertion routines.
00019 *
00020 *  Arguments
00021 *  =========
00022 *
00023 *  NOUT          (input) INTEGER
00024 *                The unit number for output.
00025 *
00026 *  NN            (input) INTEGER
00027 *                The number of values of N contained in the vector NVAL.
00028 *
00029 *  NVAL          (input) INTEGER array, dimension (NN)
00030 *                The values of the matrix dimension N.
00031 *
00032 *  A             (workspace) REAL array, dimension (LDA,NMAX)
00033 *
00034 *  LDA           (input) INTEGER
00035 *                The leading dimension of the array A.  LDA >= max(1,NMAX).
00036 *
00037 *  ARF           (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2).
00038 *
00039 *  AP            (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2).
00040 *
00041 *  A2            (workspace) REAL array, dimension (LDA,NMAX)
00042 *
00043 *  =====================================================================
00044 *     ..
00045 *     .. Local Scalars ..
00046       LOGICAL            LOWER, OK1, OK2
00047       CHARACTER          UPLO, CFORM
00048       INTEGER            I, IFORM, IIN, INFO, IUPLO, J, N,
00049      +                   NERRS, NRUN
00050 *     ..
00051 *     .. Local Arrays ..
00052       CHARACTER          UPLOS( 2 ), FORMS( 2 )
00053       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00054 *     ..
00055 *     .. External Functions ..
00056       REAL               SLARND
00057       EXTERNAL           SLARND
00058 *     ..
00059 *     .. External Subroutines ..
00060       EXTERNAL           STFTTR, STFTTP, STRTTF, STRTTP, STPTTR, STPTTF
00061 *     ..
00062 *     .. Scalars in Common ..
00063       CHARACTER*32       SRNAMT
00064 *     ..
00065 *     .. Common blocks ..
00066       COMMON             / SRNAMC / SRNAMT
00067 *     ..
00068 *     .. Data statements ..
00069       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00070       DATA               UPLOS / 'U', 'L' /
00071       DATA               FORMS / 'N', 'T' /
00072 *     ..
00073 *     .. Executable Statements ..
00074 *
00075 *     Initialize constants and the random number seed.
00076 *
00077       NRUN = 0
00078       NERRS = 0
00079       INFO = 0
00080       DO 10 I = 1, 4
00081          ISEED( I ) = ISEEDY( I )
00082    10 CONTINUE
00083 *
00084       DO 120 IIN = 1, NN
00085 *
00086          N = NVAL( IIN )
00087 *
00088 *        Do first for UPLO = 'U', then for UPLO = 'L'
00089 *
00090          DO 110 IUPLO = 1, 2
00091 *
00092             UPLO = UPLOS( IUPLO )
00093             LOWER = .TRUE.
00094             IF ( IUPLO.EQ.1 ) LOWER = .FALSE.
00095 *
00096 *           Do first for CFORM = 'N', then for CFORM = 'T'
00097 *
00098             DO 100 IFORM = 1, 2
00099 *
00100                CFORM = FORMS( IFORM )
00101 *
00102                NRUN = NRUN + 1
00103 *
00104                DO J = 1, N
00105                   DO I = 1, N
00106                      A( I, J) = SLARND( 2, ISEED )
00107                   END DO
00108                END DO
00109 *
00110                SRNAMT = 'DTRTTF'
00111                CALL STRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO )
00112 *
00113                SRNAMT = 'DTFTTP'
00114                CALL STFTTP( CFORM, UPLO, N, ARF, AP, INFO )
00115 *
00116                SRNAMT = 'DTPTTR'
00117                CALL STPTTR( UPLO, N, AP, ASAV, LDA, INFO )
00118 *
00119                OK1 = .TRUE.
00120                IF ( LOWER ) THEN
00121                   DO J = 1, N
00122                      DO I = J, N
00123                         IF ( A(I,J).NE.ASAV(I,J) ) THEN
00124                            OK1 = .FALSE.
00125                         END IF
00126                      END DO
00127                   END DO
00128                ELSE
00129                   DO J = 1, N
00130                      DO I = 1, J
00131                         IF ( A(I,J).NE.ASAV(I,J) ) THEN
00132                            OK1 = .FALSE.
00133                         END IF
00134                      END DO
00135                   END DO
00136                END IF
00137 *
00138                NRUN = NRUN + 1
00139 *
00140                SRNAMT = 'DTRTTP'
00141                CALL STRTTP( UPLO, N, A, LDA, AP, INFO )
00142 *
00143                SRNAMT = 'DTPTTF'
00144                CALL STPTTF( CFORM, UPLO, N, AP, ARF, INFO )
00145 *
00146                SRNAMT = 'DTFTTR'
00147                CALL STFTTR( CFORM, UPLO, N, ARF, ASAV, LDA, INFO )
00148 *
00149                OK2 = .TRUE.
00150                IF ( LOWER ) THEN
00151                   DO J = 1, N
00152                      DO I = J, N
00153                         IF ( A(I,J).NE.ASAV(I,J) ) THEN
00154                            OK2 = .FALSE.
00155                         END IF
00156                      END DO
00157                   END DO
00158                ELSE
00159                   DO J = 1, N
00160                      DO I = 1, J
00161                         IF ( A(I,J).NE.ASAV(I,J) ) THEN
00162                            OK2 = .FALSE.
00163                         END IF
00164                      END DO
00165                   END DO
00166                END IF
00167 *
00168                IF (( .NOT.OK1 ).OR.( .NOT.OK2 )) THEN
00169                   IF( NERRS.EQ.0 ) THEN
00170                      WRITE( NOUT, * )
00171                      WRITE( NOUT, FMT = 9999 )
00172                   END IF
00173                   WRITE( NOUT, FMT = 9998 ) N, UPLO, CFORM
00174                   NERRS = NERRS + 1
00175                END IF
00176 *
00177   100       CONTINUE
00178   110    CONTINUE
00179   120 CONTINUE
00180 *
00181 *     Print a summary of the results.
00182 *
00183       IF ( NERRS.EQ.0 ) THEN
00184          WRITE( NOUT, FMT = 9997 ) NRUN
00185       ELSE
00186          WRITE( NOUT, FMT = 9996 ) NERRS, NRUN
00187       END IF
00188 *
00189  9999 FORMAT( 1X, ' *** Error(s) while testing the RFP convertion',
00190      +         ' routines ***')
00191  9998 FORMAT( 1X, '     Error in RFP,convertion routines N=',I5,
00192      +        ' UPLO=''', A1, ''', FORM =''',A1,'''')
00193  9997 FORMAT( 1X, 'All tests for the RFP convertion routines passed (', 
00194      +        I5,' tests run)')
00195  9996 FORMAT( 1X, 'RFP convertion routines:',I5,' out of ',I5,
00196      +        ' error message recorded') 
00197 *
00198       RETURN
00199 *
00200 *     End of SDRVRF2
00201 *
00202       END
 All Files Functions