TESTING/EIG/xerbla.f

   1 *> \brief \b XERBLA
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *  Definition:
   9 *  ===========
  10 *
  11 *       SUBROUTINE XERBLA( SRNAME, INFO )
  12 *
  13 *       .. Scalar Arguments ..
  14 *       CHARACTER*(*)      SRNAME
  15 *       INTEGER            INFO
  16 *       ..
  17 *
  18 *
  19 *> \par Purpose:
  20 *  =============
  21 *>
  22 *> \verbatim
  23 *>
  24 *> This is a special version of XERBLA to be used only as part of
  25 *> the test program for testing error exits from the LAPACK routines.
  26 *> Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRNAMT,
  27 *> where INFOT and SRNAMT are values stored in COMMON.
  28 *> \endverbatim
  29 *
  30 *  Arguments:
  31 *  ==========
  32 *
  33 *> \param[in] SRNAME
  34 *> \verbatim
  35 *>          SRNAME is CHARACTER*(*)
  36 *>          The name of the subroutine calling XERBLA.  This name should
  37 *>          match the COMMON variable SRNAMT.
  38 *> \endverbatim
  39 *>
  40 *> \param[in] INFO
  41 *> \verbatim
  42 *>          INFO is INTEGER
  43 *>          The error return code from the calling subroutine.  INFO
  44 *>          should equal the COMMON variable INFOT.
  45 *> \endverbatim
  46 *
  47 *  Authors:
  48 *  ========
  49 *
  50 *> \author Univ. of Tennessee
  51 *> \author Univ. of California Berkeley
  52 *> \author Univ. of Colorado Denver
  53 *> \author NAG Ltd.
  54 *
  55 *> \date November 2011
  56 *
  57 *> \ingroup aux_eig
  58 *
  59 *> \par Further Details:
  60 *  =====================
  61 *>
  62 *> \verbatim
  63 *>
  64 *>  The following variables are passed via the common blocks INFOC and
  65 *>  SRNAMC:
  66 *>
  67 *>  INFOT   INTEGER      Expected integer return code
  68 *>  NOUT    INTEGER      Unit number for printing error messages
  69 *>  OK      LOGICAL      Set to .TRUE. if INFO = INFOT and
  70 *>                       SRNAME = SRNAMT, otherwise set to .FALSE.
  71 *>  LERR    LOGICAL      Set to .TRUE., indicating that XERBLA was called
  72 *>  SRNAMT  CHARACTER*(*) Expected name of calling subroutine
  73 *> \endverbatim
  74 *>
  75 *  =====================================================================
  76       SUBROUTINE XERBLA( SRNAME, INFO )
  77 *
  78 *  -- LAPACK test routine (version 3.4.0) --
  79 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
  80 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  81 *     November 2011
  82 *
  83 *     .. Scalar Arguments ..
  84       CHARACTER*(*)      SRNAME
  85       INTEGER            INFO
  86 *     ..
  87 *
  88 *  =====================================================================
  89 *
  90 *     .. Scalars in Common ..
  91       LOGICAL            LERR, OK
  92       CHARACTER*32       SRNAMT
  93       INTEGER            INFOT, NOUT
  94 *     ..
  95 *     .. Intrinsic Functions ..
  96       INTRINSIC          LEN_TRIM
  97 *     ..
  98 *     .. Common blocks ..
  99       COMMON             / INFOC / INFOT, NOUT, OK, LERR
 100       COMMON             / SRNAMC / SRNAMT
 101 *     ..
 102 *     .. Executable Statements ..
 103 *
 104       LERR = .TRUE.
 105       IF( INFO.NE.INFOT ) THEN
 106          IF( INFOT.NE.0 ) THEN
 107             WRITE( NOUT, FMT = 9999 )
 108      $     SRNAMT( 1:LEN_TRIM( SRNAMT ) ), INFO, INFOT
 109          ELSE
 110             WRITE( NOUT, FMT = 9997 )
 111      $     SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
 112          END IF
 113          OK = .FALSE.
 114       END IF
 115       IF( SRNAME.NE.SRNAMT ) THEN
 116          WRITE( NOUT, FMT = 9998 )
 117      $     SRNAME( 1:LEN_TRIM( SRNAME ) ),
 118      $     SRNAMT( 1:LEN_TRIM( SRNAMT ) )
 119          OK = .FALSE.
 120       END IF
 121       RETURN
 122 *
 123  9999 FORMAT( ' *** XERBLA was called from ', A, ' with INFO = ', I6,
 124      $      ' instead of ', I2, ' ***' )
 125  9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A,
 126      $      ' instead of ', A6, ' ***' )
 127  9997 FORMAT( ' *** On entry to ', A, ' parameter number ', I6,
 128      $      ' had an illegal value ***' )
 129 *
 130 *     End of XERBLA
 131 *
 132       END