TESTING/EIG/sslect.f

   1 *> \brief \b SSLECT
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *  Definition:
   9 *  ===========
  10 *
  11 *       LOGICAL          FUNCTION SSLECT( ZR, ZI )
  12 *
  13 *       .. Scalar Arguments ..
  14 *       REAL               ZI, ZR
  15 *       ..
  16 *
  17 *
  18 *> \par Purpose:
  19 *  =============
  20 *>
  21 *> \verbatim
  22 *>
  23 *> SSLECT returns .TRUE. if the eigenvalue ZR+sqrt(-1)*ZI is to be
  24 *> selected, and otherwise it returns .FALSE.
  25 *> It is used by SCHK41 to test if SGEES successfully sorts eigenvalues,
  26 *> and by SCHK43 to test if SGEESX successfully sorts eigenvalues.
  27 *>
  28 *> The common block /SSLCT/ controls how eigenvalues are selected.
  29 *> If SELOPT = 0, then SSLECT return .TRUE. when ZR is less than zero,
  30 *> and .FALSE. otherwise.
  31 *> If SELOPT is at least 1, SSLECT returns SELVAL(SELOPT) and adds 1
  32 *> to SELOPT, cycling back to 1 at SELMAX.
  33 *> \endverbatim
  34 *
  35 *  Arguments:
  36 *  ==========
  37 *
  38 *> \param[in] ZR
  39 *> \verbatim
  40 *>          ZR is REAL
  41 *>          The real part of a complex eigenvalue ZR + i*ZI.
  42 *> \endverbatim
  43 *>
  44 *> \param[in] ZI
  45 *> \verbatim
  46 *>          ZI is REAL
  47 *>          The imaginary part of a complex eigenvalue ZR + i*ZI.
  48 *> \endverbatim
  49 *
  50 *  Authors:
  51 *  ========
  52 *
  53 *> \author Univ. of Tennessee
  54 *> \author Univ. of California Berkeley
  55 *> \author Univ. of Colorado Denver
  56 *> \author NAG Ltd.
  57 *
  58 *> \date June 2016
  59 *
  60 *> \ingroup single_eig
  61 *
  62 *  =====================================================================
  63       LOGICAL          FUNCTION SSLECT( ZR, ZI )
  64 *
  65 *  -- LAPACK test routine (version 3.6.1) --
  66 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
  67 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  68 *     June 2016
  69 *
  70 *     .. Scalar Arguments ..
  71       REAL               ZI, ZR
  72 *     ..
  73 *
  74 *  =====================================================================
  75 *
  76 *     .. Arrays in Common ..
  77       LOGICAL            SELVAL( 20 )
  78       REAL               SELWI( 20 ), SELWR( 20 )
  79 *     ..
  80 *     .. Scalars in Common ..
  81       INTEGER            SELDIM, SELOPT
  82 *     ..
  83 *     .. Common blocks ..
  84       COMMON             / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
  85 *     ..
  86 *     .. Local Scalars ..
  87       INTEGER            I
  88       REAL               RMIN, X
  89 *     ..
  90 *     .. Parameters ..
  91       REAL               ZERO
  92       PARAMETER          ( ZERO = 0.0E0 )
  93 *     ..
  94 *     .. External Functions ..
  95       REAL               SLAPY2
  96       EXTERNAL           SLAPY2
  97 *     ..
  98 *     .. Executable Statements ..
  99 *
 100       IF( SELOPT.EQ.0 ) THEN
 101          SSLECT = ( ZR.LT.ZERO )
 102       ELSE
 103          RMIN = SLAPY2( ZR-SELWR( 1 ), ZI-SELWI( 1 ) )
 104          SSLECT = SELVAL( 1 )
 105          DO 10 I = 2, SELDIM
 106             X = SLAPY2( ZR-SELWR( I ), ZI-SELWI( I ) )
 107             IF( X.LE.RMIN ) THEN
 108                RMIN = X
 109                SSLECT = SELVAL( I )
 110             END IF
 111    10    CONTINUE
 112       END IF
 113       RETURN
 114 *
 115 *     End of SSLECT
 116 *
 117       END