sdrvrf4()

subroutine sdrvrf4	(	integer	nout,
		integer	nn,
		integer, dimension( nn )	nval,
		real	thresh,
		real, dimension( ldc, * )	c1,
		real, dimension( ldc, *)	c2,
		integer	ldc,
		real, dimension( * )	crf,
		real, dimension( lda, * )	a,
		integer	lda,
		real, dimension( * )	s_work_slange
	)

SDRVRF4

Purpose:

 SDRVRF4 tests the LAPACK RFP routines:
     SSFRK

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.
[in]	THRESH	THRESH is REAL The threshold value for the test ratios. A result is included in the output file if RESULT >= THRESH. To have every test ratio printed, use THRESH = 0.
[out]	C1	C1 is REAL array, dimension (LDC,NMAX)
[out]	C2	C2 is REAL array, dimension (LDC,NMAX)
[in]	LDC	LDC is INTEGER The leading dimension of the array A. LDA >= max(1,NMAX).
[out]	CRF	CRF is REAL array, dimension ((NMAX*(NMAX+1))/2).
[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]	S_WORK_SLANGE	S_WORK_SLANGE is REAL array, dimension (NMAX)

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 116 of file sdrvrf4.f.

*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LDC, NN, NOUT
      REAL               THRESH
*     ..
*     .. Array Arguments ..
      INTEGER            NVAL( NN )
      REAL               A( LDA, * ), C1( LDC, * ), C2( LDC, *),
     +                   CRF( * ), S_WORK_SLANGE( * )
*     ..
*
*  =====================================================================
*     ..
*     .. Parameters ..
      REAL               ZERO, ONE
      parameter( zero = 0.0e+0, one  = 1.0e+0 )
      INTEGER            NTESTS
      parameter( ntests = 1 )
*     ..
*     .. Local Scalars ..
      CHARACTER          UPLO, CFORM, TRANS
      INTEGER            I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
     +                   NFAIL, NRUN, IALPHA, ITRANS
      REAL               ALPHA, BETA, EPS, NORMA, NORMC
*     ..
*     .. Local Arrays ..
      CHARACTER          UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
      INTEGER            ISEED( 4 ), ISEEDY( 4 )
      REAL               RESULT( NTESTS )
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLARND, SLANGE
      EXTERNAL           slamch, slarnd, slange
*     ..
*     .. External Subroutines ..
      EXTERNAL           ssyrk, ssfrk, stfttr, strttf
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. 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' /
      DATA               transs / 'N', 'T' /
*     ..
*     .. Executable Statements ..
*
*     Initialize constants and the random number seed.
*
      nrun = 0
      nfail = 0
      info = 0
      DO 10 i = 1, 4
         iseed( i ) = iseedy( i )
   10 CONTINUE
      eps = slamch( 'Precision' )
*
      DO 150 iin = 1, nn
*
         n = nval( iin )
*
         DO 140 iik = 1, nn
*
            k = nval( iin )
*
            DO 130 iform = 1, 2
*
               cform = forms( iform )
*
               DO 120 iuplo = 1, 2
*
                  uplo = uplos( iuplo )
*
                  DO 110 itrans = 1, 2
*
                     trans = transs( itrans )
*
                     DO 100 ialpha = 1, 4
*
                        IF ( ialpha.EQ. 1) THEN
                           alpha = zero
                           beta = zero
                        ELSE IF ( ialpha.EQ. 2) THEN
                           alpha = one
                           beta = zero
                        ELSE IF ( ialpha.EQ. 3) THEN
                           alpha = zero
                           beta = one
                        ELSE
                           alpha = slarnd( 2, iseed )
                           beta = slarnd( 2, iseed )
                        END IF
*
*                       All the parameters are set:
*                          CFORM, UPLO, TRANS, M, N,
*                          ALPHA, and BETA
*                       READY TO TEST!
*
                        nrun = nrun + 1
*
                        IF ( itrans.EQ.1 ) THEN
*
*                          In this case we are NOTRANS, so A is N-by-K
*
                           DO j = 1, k
                              DO i = 1, n
                                 a( i, j) = slarnd( 2, iseed )
                              END DO
                           END DO
*
                           norma = slange( 'I', n, k, a, lda,
     +                                      s_work_slange )
*
 
                        ELSE
*
*                          In this case we are TRANS, so A is K-by-N
*
                           DO j = 1,n
                              DO i = 1, k
                                 a( i, j) = slarnd( 2, iseed )
                              END DO
                           END DO
*
                           norma = slange( 'I', k, n, a, lda,
     +                                      s_work_slange )
*
                        END IF
*
*                       Generate C1 our N--by--N symmetric matrix.
*                       Make sure C2 has the same upper/lower part,
*                       (the one that we do not touch), so
*                       copy the initial C1 in C2 in it.
*
                        DO j = 1, n
                           DO i = 1, n
                              c1( i, j) = slarnd( 2, iseed )
                              c2(i,j) = c1(i,j)
                           END DO
                        END DO
*
*                       (See comment later on for why we use SLANGE and
*                       not SLANSY for C1.)
*
                        normc = slange( 'I', n, n, c1, ldc,
     +                                      s_work_slange )
*
                        srnamt = 'STRTTF'
                        CALL strttf( cform, uplo, n, c1, ldc, crf,
     +                               info )
*
*                       call ssyrk the BLAS routine -> gives C1
*
                        srnamt = 'SSYRK '
                        CALL ssyrk( uplo, trans, n, k, alpha, a, lda,
     +                              beta, c1, ldc )
*
*                       call ssfrk the RFP routine -> gives CRF
*
                        srnamt = 'SSFRK '
                        CALL ssfrk( cform, uplo, trans, n, k, alpha, a,
     +                              lda, beta, crf )
*
*                       convert CRF in full format -> gives C2
*
                        srnamt = 'STFTTR'
                        CALL stfttr( cform, uplo, n, crf, c2, ldc,
     +                               info )
*
*                       compare C1 and C2
*
                        DO j = 1, n
                           DO i = 1, n
                              c1(i,j) = c1(i,j)-c2(i,j)
                           END DO
                        END DO
*
*                       Yes, C1 is symmetric so we could call SLANSY,
*                       but we want to check the upper part that is
*                       supposed to be unchanged and the diagonal that
*                       is supposed to be real -> SLANGE
*
                        result(1) = slange( 'I', n, n, c1, ldc,
     +                                      s_work_slange )
                        result(1) = result(1)
     +                              / max( abs( alpha ) * norma
     +                                   + abs( beta ) , one )
     +                              / max( n , 1 ) / eps
*
                        IF( result(1).GE.thresh ) THEN
                           IF( nfail.EQ.0 ) THEN
                              WRITE( nout, * )
                              WRITE( nout, fmt = 9999 )
                           END IF
                           WRITE( nout, fmt = 9997 ) 'SSFRK',
     +                        cform, uplo, trans, n, k, result(1)
                           nfail = nfail + 1
                        END IF
*
  100                CONTINUE
  110             CONTINUE
  120          CONTINUE
  130       CONTINUE
  140    CONTINUE
  150 CONTINUE
*
*     Print a summary of the results.
*
      IF ( nfail.EQ.0 ) THEN
         WRITE( nout, fmt = 9996 ) 'SSFRK', nrun
      ELSE
         WRITE( nout, fmt = 9995 ) 'SSFRK', nfail, nrun
      END IF
*
 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing SSFRK
     +         ***')
 9997 FORMAT( 1x, '     Failure in ',a5,', CFORM=''',a1,''',',
     + ' UPLO=''',a1,''',',' TRANS=''',a1,''',', ' N=',i3,', K =', i3,
     + ', test=',g12.5)
 9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
     +        'threshold ( ',i5,' tests run)')
 9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
     +        ' tests failed to pass the threshold')
*
      RETURN
*
*     End of SDRVRF4
*

Here is the call graph for this function:

Here is the caller graph for this function: