cget35.f

Go to the documentation of this file.

*> \brief \b CGET35
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CGET35( RMAX, LMAX, NINFO, KNT, NIN )
*
*       .. Scalar Arguments ..
*       INTEGER            KNT, LMAX, NIN, NINFO
*       REAL               RMAX
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CGET35 tests CTRSYL, a routine for solving the Sylvester matrix
*> equation
*>
*>    op(A)*X + ISGN*X*op(B) = scale*C,
*>
*> A and B are assumed to be in Schur canonical form, op() represents an
*> optional transpose, and ISGN can be -1 or +1.  Scale is an output
*> less than or equal to 1, chosen to avoid overflow in X.
*>
*> The test code verifies that the following residual is order 1:
*>
*>    norm(op(A)*X + ISGN*X*op(B) - scale*C) /
*>        (EPS*max(norm(A),norm(B))*norm(X))
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[out] RMAX
*> \verbatim
*>          RMAX is REAL
*>          Value of the largest test ratio.
*> \endverbatim
*>
*> \param[out] LMAX
*> \verbatim
*>          LMAX is INTEGER
*>          Example number where largest test ratio achieved.
*> \endverbatim
*>
*> \param[out] NINFO
*> \verbatim
*>          NINFO is INTEGER
*>          Number of examples where INFO is nonzero.
*> \endverbatim
*>
*> \param[out] KNT
*> \verbatim
*>          KNT is INTEGER
*>          Total number of examples tested.
*> \endverbatim
*>
*> \param[in] NIN
*> \verbatim
*>          NIN is INTEGER
*>          Input logical unit number.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex_eig
*
*  =====================================================================
      SUBROUTINE cget35( RMAX, LMAX, NINFO, KNT, NIN )
*
*  -- 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            KNT, LMAX, NIN, NINFO
      REAL               RMAX
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            LDT
      parameter( ldt = 10 )
      REAL               ZERO, ONE, TWO
      parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
      REAL               LARGE
      parameter( large = 1.0e6 )
      COMPLEX            CONE
      parameter( cone = 1.0e0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          TRANA, TRANB
      INTEGER            I, IMLA, IMLAD, IMLB, IMLC, INFO, ISGN, ITRANA,
     $                   ITRANB, J, M, N
      REAL               BIGNUM, EPS, RES, RES1, SCALE, SMLNUM, TNRM,
     $                   XNRM
      COMPLEX            RMUL
*     ..
*     .. Local Arrays ..
      REAL               DUM( 1 ), VM1( 3 ), VM2( 3 )
      COMPLEX            A( LDT, LDT ), ATMP( LDT, LDT ), B( LDT, LDT ),
     $                   BTMP( LDT, LDT ), C( LDT, LDT ),
     $                   CSAV( LDT, LDT ), CTMP( LDT, LDT )
*     ..
*     .. External Functions ..
      REAL               CLANGE, SLAMCH
      EXTERNAL           clange, slamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           cgemm, ctrsyl
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, real, sqrt
*     ..
*     .. Executable Statements ..
*
*     Get machine parameters
*
      eps = slamch( 'P' )
      smlnum = slamch( 'S' ) / eps
      bignum = one / smlnum
      CALL slabad( smlnum, bignum )
*
*     Set up test case parameters
*
      vm1( 1 ) = sqrt( smlnum )
      vm1( 2 ) = one
      vm1( 3 ) = large
      vm2( 1 ) = one
      vm2( 2 ) = one + two*eps
      vm2( 3 ) = two
*
      knt = 0
      ninfo = 0
      lmax = 0
      rmax = zero
*
*     Begin test loop
*
   10 CONTINUE
      READ( nin, fmt = * )m, n
      IF( n.EQ.0 )
     $   RETURN
      DO 20 i = 1, m
         READ( nin, fmt = * )( atmp( i, j ), j = 1, m )
   20 CONTINUE
      DO 30 i = 1, n
         READ( nin, fmt = * )( btmp( i, j ), j = 1, n )
   30 CONTINUE
      DO 40 i = 1, m
         READ( nin, fmt = * )( ctmp( i, j ), j = 1, n )
   40 CONTINUE
      DO 170 imla = 1, 3
         DO 160 imlad = 1, 3
            DO 150 imlb = 1, 3
               DO 140 imlc = 1, 3
                  DO 130 itrana = 1, 2
                     DO 120 itranb = 1, 2
                        DO 110 isgn = -1, 1, 2
                           IF( itrana.EQ.1 )
     $                        trana = 'N'
                           IF( itrana.EQ.2 )
     $                        trana = 'C'
                           IF( itranb.EQ.1 )
     $                        tranb = 'N'
                           IF( itranb.EQ.2 )
     $                        tranb = 'C'
                           tnrm = zero
                           DO 60 i = 1, m
                              DO 50 j = 1, m
                                 a( i, j ) = atmp( i, j )*vm1( imla )
                                 tnrm = max( tnrm, abs( a( i, j ) ) )
   50                         CONTINUE
                              a( i, i ) = a( i, i )*vm2( imlad )
                              tnrm = max( tnrm, abs( a( i, i ) ) )
   60                      CONTINUE
                           DO 80 i = 1, n
                              DO 70 j = 1, n
                                 b( i, j ) = btmp( i, j )*vm1( imlb )
                                 tnrm = max( tnrm, abs( b( i, j ) ) )
   70                         CONTINUE
   80                      CONTINUE
                           IF( tnrm.EQ.zero )
     $                        tnrm = one
                           DO 100 i = 1, m
                              DO 90 j = 1, n
                                 c( i, j ) = ctmp( i, j )*vm1( imlc )
                                 csav( i, j ) = c( i, j )
   90                         CONTINUE
  100                      CONTINUE
                           knt = knt + 1
                           CALL ctrsyl( trana, tranb, isgn, m, n, a,
     $                                  ldt, b, ldt, c, ldt, scale,
     $                                  info )
                           IF( info.NE.0 )
     $                        ninfo = ninfo + 1
                           xnrm = clange( 'M', m, n, c, ldt, dum )
                           rmul = cone
                           IF( xnrm.GT.one .AND. tnrm.GT.one ) THEN
                              IF( xnrm.GT.bignum / tnrm ) THEN
                                 rmul = max( xnrm, tnrm )
                                 rmul = cone / rmul
                              END IF
                           END IF
                           CALL cgemm( trana, 'N', m, n, m, rmul, a,
     $                                 ldt, c, ldt, -scale*rmul, csav,
     $                                 ldt )
                           CALL cgemm( 'N', tranb, m, n, n,
     $                                 real( isgn )*rmul, c, ldt, b,
     $                                 ldt, cone, csav, ldt )
                           res1 = clange( 'M', m, n, csav, ldt, dum )
                           res = res1 / max( smlnum, smlnum*xnrm,
     $                           ( ( abs( rmul )*tnrm )*eps )*xnrm )
                           IF( res.GT.rmax ) THEN
                              lmax = knt
                              rmax = res
                           END IF
  110                   CONTINUE
  120                CONTINUE
  130             CONTINUE
  140          CONTINUE
  150       CONTINUE
  160    CONTINUE
  170 CONTINUE
      GO TO 10
*
*     End of CGET35
*
      END