cerrec.f

Go to the documentation of this file.

*> \brief \b CERREC
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CERREC( PATH, NUNIT )
*
*       .. Scalar Arguments ..
*       CHARACTER*3        PATH
*       INTEGER            NUNIT
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CERREC tests the error exits for the routines for eigen- condition
*> estimation for REAL matrices:
*>    CTRSYL, CTRSYL3, CTREXC, CTRSNA and CTRSEN.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] PATH
*> \verbatim
*>          PATH is CHARACTER*3
*>          The LAPACK path name for the routines to be tested.
*> \endverbatim
*>
*> \param[in] NUNIT
*> \verbatim
*>          NUNIT is INTEGER
*>          The unit number for output.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex_eig
*
*  =====================================================================
      SUBROUTINE cerrec( PATH, NUNIT )
*
*  -- 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 ..
      CHARACTER*3        PATH
      INTEGER            NUNIT
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NMAX, LW
      parameter( nmax = 4, lw = nmax*( nmax+2 ) )
      REAL               ONE, ZERO
      parameter( one = 1.0e0, zero = 0.0e0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IFST, ILST, INFO, J, M, NT
      REAL               SCALE
*     ..
*     .. Local Arrays ..
      LOGICAL            SEL( NMAX )
      REAL               RW( LW ), S( NMAX ), SEP( NMAX ), SWORK( NMAX )
      COMPLEX            A( NMAX, NMAX ), B( NMAX, NMAX ),
     $                   C( NMAX, NMAX ), WORK( LW ), X( NMAX )
*     ..
*     .. External Subroutines ..
      EXTERNAL           chkxer, ctrexc, ctrsen, ctrsna, ctrsyl, ctrsyl3
*     ..
*     .. Scalars in Common ..
      LOGICAL            LERR, OK
      CHARACTER*32       SRNAMT
      INTEGER            INFOT, NOUT
*     ..
*     .. Common blocks ..
      COMMON             / infoc / infot, nout, ok, lerr
      COMMON             / srnamc / srnamt
*     ..
*     .. Executable Statements ..
*
      nout = nunit
      ok = .true.
      nt = 0
*
*     Initialize A, B and SEL
*
      DO 20 j = 1, nmax
         DO 10 i = 1, nmax
            a( i, j ) = zero
            b( i, j ) = zero
   10    CONTINUE
   20 CONTINUE
      DO 30 i = 1, nmax
         a( i, i ) = one
         sel( i ) = .true.
   30 CONTINUE
*
*     Test CTRSYL
*
      srnamt = 'CTRSYL'
      infot = 1
      CALL ctrsyl( 'X', 'N', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
      CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
      infot = 2
      CALL ctrsyl( 'N', 'X', 1, 0, 0, a, 1, b, 1, c, 1, scale, info )
      CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
      infot = 3
      CALL ctrsyl( 'N', 'N', 0, 0, 0, a, 1, b, 1, c, 1, scale, info )
      CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
      infot = 4
      CALL ctrsyl( 'N', 'N', 1, -1, 0, a, 1, b, 1, c, 1, scale, info )
      CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
      infot = 5
      CALL ctrsyl( 'N', 'N', 1, 0, -1, a, 1, b, 1, c, 1, scale, info )
      CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
      infot = 7
      CALL ctrsyl( 'N', 'N', 1, 2, 0, a, 1, b, 1, c, 2, scale, info )
      CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
      infot = 9
      CALL ctrsyl( 'N', 'N', 1, 0, 2, a, 1, b, 1, c, 1, scale, info )
      CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
      infot = 11
      CALL ctrsyl( 'N', 'N', 1, 2, 0, a, 2, b, 1, c, 1, scale, info )
      CALL chkxer( 'CTRSYL', infot, nout, lerr, ok )
      nt = nt + 8
*
*     Test CTRSYL3
*
      srnamt = 'CTRSYL3'
      infot = 1
      CALL ctrsyl3( 'X', 'N', 1, 0, 0, a, 1, b, 1, c, 1, scale,
     $              swork, nmax, info )
      CALL chkxer( 'CTRSYL3', infot, nout, lerr, ok )
      infot = 2
      CALL ctrsyl3( 'N', 'X', 1, 0, 0, a, 1, b, 1, c, 1, scale,
     $              swork, nmax, info )
      CALL chkxer( 'CTRSYL3', infot, nout, lerr, ok )
      infot = 3
      CALL ctrsyl3( 'N', 'N', 0, 0, 0, a, 1, b, 1, c, 1, scale,
     $              swork, nmax, info )
      CALL chkxer( 'CTRSYL3', infot, nout, lerr, ok )
      infot = 4
      CALL ctrsyl3( 'N', 'N', 1, -1, 0, a, 1, b, 1, c, 1, scale,
     $              swork, nmax, info )
      CALL chkxer( 'CTRSYL3', infot, nout, lerr, ok )
      infot = 5
      CALL ctrsyl3( 'N', 'N', 1, 0, -1, a, 1, b, 1, c, 1, scale,
     $              swork, nmax, info )
      CALL chkxer( 'CTRSYL3', infot, nout, lerr, ok )
      infot = 7
      CALL ctrsyl3( 'N', 'N', 1, 2, 0, a, 1, b, 1, c, 2, scale,
     $              swork, nmax, info )
      CALL chkxer( 'CTRSYL3', infot, nout, lerr, ok )
      infot = 9
      CALL ctrsyl3( 'N', 'N', 1, 0, 2, a, 1, b, 1, c, 1, scale,
     $              swork, nmax, info )
      CALL chkxer( 'CTRSYL3', infot, nout, lerr, ok )
      infot = 11
      CALL ctrsyl3( 'N', 'N', 1, 2, 0, a, 2, b, 1, c, 1, scale,
     $              swork, nmax, info )
      CALL chkxer( 'CTRSYL3', infot, nout, lerr, ok )
      nt = nt + 8
*
*     Test CTREXC
*
      srnamt = 'CTREXC'
      ifst = 1
      ilst = 1
      infot = 1
      CALL ctrexc( 'X', 1, a, 1, b, 1, ifst, ilst, info )
      CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
      infot = 2
      CALL ctrexc( 'N', -1, a, 1, b, 1, ifst, ilst, info )
      CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
      infot = 4
      ilst = 2
      CALL ctrexc( 'N', 2, a, 1, b, 1, ifst, ilst, info )
      CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
      infot = 6
      CALL ctrexc( 'V', 2, a, 2, b, 1, ifst, ilst, info )
      CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
      infot = 7
      ifst = 0
      ilst = 1
      CALL ctrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
      CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
      infot = 7
      ifst = 2
      CALL ctrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
      CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
      infot = 8
      ifst = 1
      ilst = 0
      CALL ctrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
      CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
      infot = 8
      ilst = 2
      CALL ctrexc( 'V', 1, a, 1, b, 1, ifst, ilst, info )
      CALL chkxer( 'CTREXC', infot, nout, lerr, ok )
      nt = nt + 8
*
*     Test CTRSNA
*
      srnamt = 'CTRSNA'
      infot = 1
      CALL ctrsna( 'X', 'A', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
     $             work, 1, rw, info )
      CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
      infot = 2
      CALL ctrsna( 'B', 'X', sel, 0, a, 1, b, 1, c, 1, s, sep, 1, m,
     $             work, 1, rw, info )
      CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
      infot = 4
      CALL ctrsna( 'B', 'A', sel, -1, a, 1, b, 1, c, 1, s, sep, 1, m,
     $             work, 1, rw, info )
      CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
      infot = 6
      CALL ctrsna( 'V', 'A', sel, 2, a, 1, b, 1, c, 1, s, sep, 2, m,
     $             work, 2, rw, info )
      CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
      infot = 8
      CALL ctrsna( 'B', 'A', sel, 2, a, 2, b, 1, c, 2, s, sep, 2, m,
     $             work, 2, rw, info )
      CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
      infot = 10
      CALL ctrsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 1, s, sep, 2, m,
     $             work, 2, rw, info )
      CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
      infot = 13
      CALL ctrsna( 'B', 'A', sel, 1, a, 1, b, 1, c, 1, s, sep, 0, m,
     $             work, 1, rw, info )
      CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
      infot = 13
      CALL ctrsna( 'B', 'S', sel, 2, a, 2, b, 2, c, 2, s, sep, 1, m,
     $             work, 1, rw, info )
      CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
      infot = 16
      CALL ctrsna( 'B', 'A', sel, 2, a, 2, b, 2, c, 2, s, sep, 2, m,
     $             work, 1, rw, info )
      CALL chkxer( 'CTRSNA', infot, nout, lerr, ok )
      nt = nt + 9
*
*     Test CTRSEN
*
      sel( 1 ) = .false.
      srnamt = 'CTRSEN'
      infot = 1
      CALL ctrsen( 'X', 'N', sel, 0, a, 1, b, 1, x, m, s( 1 ), sep( 1 ),
     $             work, 1, info )
      CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
      infot = 2
      CALL ctrsen( 'N', 'X', sel, 0, a, 1, b, 1, x, m, s( 1 ), sep( 1 ),
     $             work, 1, info )
      CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
      infot = 4
      CALL ctrsen( 'N', 'N', sel, -1, a, 1, b, 1, x, m, s( 1 ),
     $             sep( 1 ), work, 1, info )
      CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
      infot = 6
      CALL ctrsen( 'N', 'N', sel, 2, a, 1, b, 1, x, m, s( 1 ), sep( 1 ),
     $             work, 2, info )
      CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
      infot = 8
      CALL ctrsen( 'N', 'V', sel, 2, a, 2, b, 1, x, m, s( 1 ), sep( 1 ),
     $             work, 1, info )
      CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
      infot = 14
      CALL ctrsen( 'N', 'V', sel, 2, a, 2, b, 2, x, m, s( 1 ), sep( 1 ),
     $             work, 0, info )
      CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
      infot = 14
      CALL ctrsen( 'E', 'V', sel, 3, a, 3, b, 3, x, m, s( 1 ), sep( 1 ),
     $             work, 1, info )
      CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
      infot = 14
      CALL ctrsen( 'V', 'V', sel, 3, a, 3, b, 3, x, m, s( 1 ), sep( 1 ),
     $             work, 3, info )
      CALL chkxer( 'CTRSEN', infot, nout, lerr, ok )
      nt = nt + 8
*
*     Print a summary line.
*
      IF( ok ) THEN
         WRITE( nout, fmt = 9999 )path, nt
      ELSE
         WRITE( nout, fmt = 9998 )path
      END IF
*
 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits (',
     $      i3, ' tests done)' )
 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
     $      'exits ***' )
      RETURN
*
*     End of CERREC
*
      SUBROUTINE cerrec( PATH, NUNIT ) …
      END