sdrvrf2()

subroutine sdrvrf2	(	integer	NOUT,
		integer	NN,
		integer, dimension( nn )	NVAL,
		real, dimension( lda, * )	A,
		integer	LDA,
		real, dimension( * )	ARF,
		real, dimension(*)	AP,
		real, dimension( lda, * )	ASAV
	)

SDRVRF2

Purpose:

 SDRVRF2 tests the LAPACK RFP conversion routines.

Parameters

[in]	NOUT	NOUT is INTEGER The unit number for output.
[in]	NN	NN is INTEGER The number of values of N contained in the vector NVAL.
[in]	NVAL	NVAL is INTEGER array, dimension (NN) The values of the matrix dimension N.
[out]	A	A is REAL array, dimension (LDA,NMAX)
[in]	LDA	LDA is INTEGER The leading dimension of the array A. LDA >= max(1,NMAX).
[out]	ARF	ARF is REAL array, dimension ((NMAX*(NMAX+1))/2).
[out]	AP	AP is REAL array, dimension ((NMAX*(NMAX+1))/2).
[out]	ASAV	ASAV is REAL array, dimension (LDA,NMAX)

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Date

December 2016

Definition at line 91 of file sdrvrf2.f.

*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            LDA, NN, NOUT
*     ..
*     .. Array Arguments ..
      INTEGER            NVAL( NN )
      REAL               A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * )
*     ..
*
*  =====================================================================
*     ..
*     .. Local Scalars ..
      LOGICAL            LOWER, OK1, OK2
      CHARACTER          UPLO, CFORM
      INTEGER            I, IFORM, IIN, INFO, IUPLO, J, N,
     +                   NERRS, NRUN
*     ..
*     .. Local Arrays ..
      CHARACTER          UPLOS( 2 ), FORMS( 2 )
      INTEGER            ISEED( 4 ), ISEEDY( 4 )
*     ..
*     .. External Functions ..
      REAL               SLARND
      EXTERNAL           slarnd
*     ..
*     .. External Subroutines ..
      EXTERNAL           stfttr, stfttp, strttf, strttp, stpttr, stpttf
*     ..
*     .. Scalars in Common ..
      CHARACTER*32       SRNAMT
*     ..
*     .. Common blocks ..
      COMMON             / srnamc / srnamt
*     ..
*     .. Data statements ..
      DATA               iseedy / 1988, 1989, 1990, 1991 /
      DATA               uplos / 'U', 'L' /
      DATA               forms / 'N', 'T' /
*     ..
*     .. Executable Statements ..
*
*     Initialize constants and the random number seed.
*
      nrun = 0
      nerrs = 0
      info = 0
      DO 10 i = 1, 4
         iseed( i ) = iseedy( i )
   10 CONTINUE
*
      DO 120 iin = 1, nn
*
         n = nval( iin )
*
*        Do first for UPLO = 'U', then for UPLO = 'L'
*
         DO 110 iuplo = 1, 2
*
            uplo = uplos( iuplo )
            lower = .true.
            IF ( iuplo.EQ.1 ) lower = .false.
*
*           Do first for CFORM = 'N', then for CFORM = 'T'
*
            DO 100 iform = 1, 2
*
               cform = forms( iform )
*
               nrun = nrun + 1
*
               DO j = 1, n
                  DO i = 1, n
                     a( i, j) = slarnd( 2, iseed )
                  END DO
               END DO
*
               srnamt = 'DTRTTF'
               CALL strttf( cform, uplo, n, a, lda, arf, info )
*
               srnamt = 'DTFTTP'
               CALL stfttp( cform, uplo, n, arf, ap, info )
*
               srnamt = 'DTPTTR'
               CALL stpttr( uplo, n, ap, asav, lda, info )
*
               ok1 = .true.
               IF ( lower ) THEN
                  DO j = 1, n
                     DO i = j, n
                        IF ( a(i,j).NE.asav(i,j) ) THEN
                           ok1 = .false.
                        END IF
                     END DO
                  END DO
               ELSE
                  DO j = 1, n
                     DO i = 1, j
                        IF ( a(i,j).NE.asav(i,j) ) THEN
                           ok1 = .false.
                        END IF
                     END DO
                  END DO
               END IF
*
               nrun = nrun + 1
*
               srnamt = 'DTRTTP'
               CALL strttp( uplo, n, a, lda, ap, info )
*
               srnamt = 'DTPTTF'
               CALL stpttf( cform, uplo, n, ap, arf, info )
*
               srnamt = 'DTFTTR'
               CALL stfttr( cform, uplo, n, arf, asav, lda, info )
*
               ok2 = .true.
               IF ( lower ) THEN
                  DO j = 1, n
                     DO i = j, n
                        IF ( a(i,j).NE.asav(i,j) ) THEN
                           ok2 = .false.
                        END IF
                     END DO
                  END DO
               ELSE
                  DO j = 1, n
                     DO i = 1, j
                        IF ( a(i,j).NE.asav(i,j) ) THEN
                           ok2 = .false.
                        END IF
                     END DO
                  END DO
               END IF
*
               IF (( .NOT.ok1 ).OR.( .NOT.ok2 )) THEN
                  IF( nerrs.EQ.0 ) THEN
                     WRITE( nout, * )
                     WRITE( nout, fmt = 9999 )
                  END IF
                  WRITE( nout, fmt = 9998 ) n, uplo, cform
                  nerrs = nerrs + 1
               END IF
*
  100       CONTINUE
  110    CONTINUE
  120 CONTINUE
*
*     Print a summary of the results.
*
      IF ( nerrs.EQ.0 ) THEN
         WRITE( nout, fmt = 9997 ) nrun
      ELSE
         WRITE( nout, fmt = 9996 ) nerrs, nrun
      END IF
*
 9999 FORMAT( 1x, ' *** Error(s) while testing the RFP conversion',
     +         ' routines ***')
 9998 FORMAT( 1x, '     Error in RFP,conversion routines N=',i5,
     +        ' UPLO=''', a1, ''', FORM =''',a1,'''')
 9997 FORMAT( 1x, 'All tests for the RFP conversion routines passed ( ',
     +        i5,' tests run)')
 9996 FORMAT( 1x, 'RFP conversion routines: ',i5,' out of ',i5,
     +        ' error message recorded')
*
      RETURN
*
*     End of SDRVRF2
*

Here is the call graph for this function:

Here is the caller graph for this function: