ddrvrf3.f

Go to the documentation of this file.

*> \brief \b DDRVRF3
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
*      +                    D_WORK_DLANGE, D_WORK_DGEQRF, TAU )
*
*       .. Scalar Arguments ..
*       INTEGER            LDA, NN, NOUT
*       DOUBLE PRECISION   THRESH
*       ..
*       .. Array Arguments ..
*       INTEGER            NVAL( NN )
*       DOUBLE PRECISION   A( LDA, * ), ARF( * ), B1( LDA, * ),
*      +                   B2( LDA, * ), D_WORK_DGEQRF( * ),
*      +                   D_WORK_DLANGE( * ), TAU( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DDRVRF3 tests the LAPACK RFP routines:
*>     DTFSM
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] NOUT
*> \verbatim
*>          NOUT is INTEGER
*>                The unit number for output.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*>          NN is INTEGER
*>                The number of values of N contained in the vector NVAL.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*>          NVAL is INTEGER array, dimension (NN)
*>                The values of the matrix dimension N.
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is DOUBLE PRECISION
*>                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.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,NMAX)
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>                The leading dimension of the array A.  LDA >= max(1,NMAX).
*> \endverbatim
*>
*> \param[out] ARF
*> \verbatim
*>          ARF is DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2).
*> \endverbatim
*>
*> \param[out] B1
*> \verbatim
*>          B1 is DOUBLE PRECISION array, dimension (LDA,NMAX)
*> \endverbatim
*>
*> \param[out] B2
*> \verbatim
*>          B2 is DOUBLE PRECISION array, dimension (LDA,NMAX)
*> \endverbatim
*>
*> \param[out] D_WORK_DLANGE
*> \verbatim
*>          D_WORK_DLANGE is DOUBLE PRECISION array, dimension (NMAX)
*> \endverbatim
*>
*> \param[out] D_WORK_DGEQRF
*> \verbatim
*>          D_WORK_DGEQRF is DOUBLE PRECISION array, dimension (NMAX)
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*>          TAU is DOUBLE PRECISION array, dimension (NMAX)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup double_lin
*
*  =====================================================================
      SUBROUTINE ddrvrf3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
     +                    D_WORK_DLANGE, D_WORK_DGEQRF, TAU )
*
*  -- 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, NN, NOUT
      DOUBLE PRECISION   THRESH
*     ..
*     .. Array Arguments ..
      INTEGER            NVAL( NN )
      DOUBLE PRECISION   A( LDA, * ), ARF( * ), B1( LDA, * ),
     +                   b2( lda, * ), d_work_dgeqrf( * ),
     +                   d_work_dlange( * ), tau( * )
*     ..
*
*  =====================================================================
*     ..
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      parameter( zero = ( 0.0d+0, 0.0d+0 ) ,
     +                     one  = ( 1.0d+0, 0.0d+0 ) )
      INTEGER            NTESTS
      parameter( ntests = 1 )
*     ..
*     .. Local Scalars ..
      CHARACTER          UPLO, CFORM, DIAG, TRANS, SIDE
      INTEGER            I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
     +                   nfail, nrun, iside, idiag, ialpha, itrans
      DOUBLE PRECISION   EPS, ALPHA
*     ..
*     .. Local Arrays ..
      CHARACTER          UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
     +                   diags( 2 ), sides( 2 )
      INTEGER            ISEED( 4 ), ISEEDY( 4 )
      DOUBLE PRECISION   RESULT( NTESTS )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE, DLARND
      EXTERNAL           dlamch, dlange, dlarnd, lsame
*     ..
*     .. External Subroutines ..
      EXTERNAL           dtrttf, dgeqrf, dgeqlf, dtfsm, dtrsm
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max, sqrt
*     ..
*     .. 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               sides  / 'L', 'R' /
      DATA               transs / 'N', 'T' /
      DATA               diags  / 'N', 'U' /
*     ..
*     .. 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 = dlamch( 'Precision' )
*
      DO 170 iim = 1, nn
*
         m = nval( iim )
*
         DO 160 iin = 1, nn
*
            n = nval( iin )
*
            DO 150 iform = 1, 2
*
               cform = forms( iform )
*
               DO 140 iuplo = 1, 2
*
                  uplo = uplos( iuplo )
*
                  DO 130 iside = 1, 2
*
                     side = sides( iside )
*
                     DO 120 itrans = 1, 2
*
                        trans = transs( itrans )
*
                        DO 110 idiag = 1, 2
*
                           diag = diags( idiag )
*
                           DO 100 ialpha = 1, 3
*
                              IF ( ialpha.EQ.1 ) THEN
                                 alpha = zero
                              ELSE IF ( ialpha.EQ.2 ) THEN
                                 alpha = one
                              ELSE
                                 alpha = dlarnd( 2, iseed )
                              END IF
*
*                             All the parameters are set:
*                                CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
*                                and ALPHA
*                             READY TO TEST!
*
                              nrun = nrun + 1
*
                              IF ( iside.EQ.1 ) THEN
*
*                                The case ISIDE.EQ.1 is when SIDE.EQ.'L'
*                                -> A is M-by-M ( B is M-by-N )
*
                                 na = m
*
                              ELSE
*
*                                The case ISIDE.EQ.2 is when SIDE.EQ.'R'
*                                -> A is N-by-N ( B is M-by-N )
*
                                 na = n
*
                              END IF
*
*                             Generate A our NA--by--NA triangular
*                             matrix.
*                             Our test is based on forward error so we
*                             do want A to be well conditioned! To get
*                             a well-conditioned triangular matrix, we
*                             take the R factor of the QR/LQ factorization
*                             of a random matrix.
*
                              DO j = 1, na
                                 DO i = 1, na
                                    a( i, j ) = dlarnd( 2, iseed )
                                 END DO
                              END DO
*
                              IF ( iuplo.EQ.1 ) THEN
*
*                                The case IUPLO.EQ.1 is when SIDE.EQ.'U'
*                                -> QR factorization.
*
                                 srnamt = 'DGEQRF'
                                 CALL dgeqrf( na, na, a, lda, tau,
     +                                        d_work_dgeqrf, lda,
     +                                        info )
*
*                                Forcing main diagonal of test matrix to
*                                be unit makes it ill-conditioned for
*                                some test cases
*
                                 IF ( lsame( diag, 'U' ) ) THEN
                                    DO j = 1, na
                                       DO i = 1, j
                                          a( i, j ) = a( i, j ) /
     +                                            ( 2.0 * a( j, j ) )
                                       END DO
                                    END DO
                                 END IF
*
                              ELSE
*
*                                The case IUPLO.EQ.2 is when SIDE.EQ.'L'
*                                -> QL factorization.
*
                                 srnamt = 'DGELQF'
                                 CALL dgelqf( na, na, a, lda, tau,
     +                                        d_work_dgeqrf, lda,
     +                                        info )
*
*                                Forcing main diagonal of test matrix to
*                                be unit makes it ill-conditioned for
*                                some test cases
*
                                 IF ( lsame( diag, 'U' ) ) THEN
                                    DO i = 1, na
                                       DO j = 1, i
                                          a( i, j ) = a( i, j ) /
     +                                            ( 2.0 * a( i, i ) )
                                       END DO
                                    END DO
                                 END IF
*
                              END IF
*
*                             Store a copy of A in RFP format (in ARF).
*
                              srnamt = 'DTRTTF'
                              CALL dtrttf( cform, uplo, na, a, lda, arf,
     +                                     info )
*
*                             Generate B1 our M--by--N right-hand side
*                             and store a copy in B2.
*
                              DO j = 1, n
                                 DO i = 1, m
                                    b1( i, j ) = dlarnd( 2, iseed )
                                    b2( i, j ) = b1( i, j )
                                 END DO
                              END DO
*
*                             Solve op( A ) X = B or X op( A ) = B
*                             with DTRSM
*
                              srnamt = 'DTRSM'
                              CALL dtrsm( side, uplo, trans, diag, m, n,
     +                               alpha, a, lda, b1, lda )
*
*                             Solve op( A ) X = B or X op( A ) = B
*                             with DTFSM
*
                              srnamt = 'DTFSM'
                              CALL dtfsm( cform, side, uplo, trans,
     +                                    diag, m, n, alpha, arf, b2,
     +                                    lda )
*
*                             Check that the result agrees.
*
                              DO j = 1, n
                                 DO i = 1, m
                                    b1( i, j ) = b2( i, j ) - b1( i, j )
                                 END DO
                              END DO
*
                              result( 1 ) = dlange( 'I', m, n, b1, lda,
     +                                            d_work_dlange )
*
                              result( 1 ) = result( 1 ) / sqrt( eps )
     +                                    / max( max( m, n ), 1 )
*
                              IF( result( 1 ).GE.thresh ) THEN
                                 IF( nfail.EQ.0 ) THEN
                                    WRITE( nout, * )
                                    WRITE( nout, fmt = 9999 )
                                 END IF
                                 WRITE( nout, fmt = 9997 ) 'DTFSM',
     +                              cform, side, uplo, trans, diag, m,
     +                              n, result( 1 )
                                 nfail = nfail + 1
                              END IF
*
  100                      CONTINUE
  110                   CONTINUE
  120                CONTINUE
  130             CONTINUE
  140          CONTINUE
  150       CONTINUE
  160    CONTINUE
  170 CONTINUE
*
*     Print a summary of the results.
*
      IF ( nfail.EQ.0 ) THEN
         WRITE( nout, fmt = 9996 ) 'DTFSM', nrun
      ELSE
         WRITE( nout, fmt = 9995 ) 'DTFSM', nfail, nrun
      END IF
*
 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing DTFSM
     +         ***')
 9997 FORMAT( 1x, '     Failure in ',a5,', CFORM=''',a1,''',',
     + ' SIDE=''',a1,''',',' UPLO=''',a1,''',',' TRANS=''',a1,''',',
     + ' DIAG=''',a1,''',',' M=',i3,', N =', 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 DDRVRF3
*
      END