d3/d30/TESTING_2LIN_2xerbla_8f_source.html

00001       SUBROUTINE XERBLA( SRNAME, INFO )
00002 *
00003 *  -- LAPACK auxiliary routine (version 3.1) --
00004 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00005 *     November 2006
00006 *
00007 *     .. Scalar Arguments ..
00008       CHARACTER*(*)      SRNAME
00009       INTEGER            INFO
00010 *     ..
00011 *
00012 *  Purpose
00013 *  =======
00014 *
00015 *  This is a special version of XERBLA to be used only as part of
00016 *  the test program for testing error exits from the LAPACK routines.
00017 *  Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRMANT,
00018 *  where INFOT and SRNAMT are values stored in COMMON.
00019 *
00020 *  Arguments
00021 *  =========
00022 *
00023 *  SRNAME  (input) CHARACTER*(*)
00024 *          The name of the subroutine calling XERBLA.  This name should
00025 *          match the COMMON variable SRNAMT.
00026 *
00027 *  INFO    (input) INTEGER
00028 *          The error return code from the calling subroutine.  INFO
00029 *          should equal the COMMON variable INFOT.
00030 *
00031 *  Further Details
00032 *  ======= =======
00033 *
00034 *  The following variables are passed via the common blocks INFOC and
00035 *  SRNAMC:
00036 *
00037 *  INFOT   INTEGER      Expected integer return code
00038 *  NOUT    INTEGER      Unit number for printing error messages
00039 *  OK      LOGICAL      Set to .TRUE. if INFO = INFOT and
00040 *                       SRNAME = SRNAMT, otherwise set to .FALSE.
00041 *  LERR    LOGICAL      Set to .TRUE., indicating that XERBLA was called
00042 *  SRNAMT  CHARACTER*(*) Expected name of calling subroutine
00043 *
00044 *
00045 *     .. Scalars in Common ..
00046       LOGICAL            LERR, OK
00047       CHARACTER*32       SRNAMT
00048       INTEGER            INFOT, NOUT
00049 *     ..
00050 *     .. Intrinsic Functions ..
00051       INTRINSIC          LEN_TRIM
00052 *     ..
00053 *     .. Common blocks ..
00054       COMMON             / INFOC / INFOT, NOUT, OK, LERR
00055       COMMON             / SRNAMC / SRNAMT
00056 *     ..
00057 *     .. Executable Statements ..
00058 *
00059       LERR = .TRUE.
00060       IF( INFO.NE.INFOT ) THEN
00061          IF( INFOT.NE.0 ) THEN
00062             WRITE( NOUT, FMT = 9999 )
00063      $     SRNAMT( 1:LEN_TRIM( SRNAMT ) ), INFO, INFOT
00064          ELSE
00065             WRITE( NOUT, FMT = 9997 )
00066      $     SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
00067          END IF
00068          OK = .FALSE.
00069       END IF
00070       IF( SRNAME.NE.SRNAMT ) THEN
00071          WRITE( NOUT, FMT = 9998 )
00072      $     SRNAME( 1:LEN_TRIM( SRNAME ) ),
00073      $     SRNAMT( 1:LEN_TRIM( SRNAMT ) )
00074          OK = .FALSE.
00075       END IF
00076       RETURN
00077 *
00078  9999 FORMAT( ' *** XERBLA was called from ', A, ' with INFO = ', I6,
00079      $      ' instead of ', I2, ' ***' )
00080  9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A,
00081      $      ' instead of ', A6, ' ***' )
00082  9997 FORMAT( ' *** On entry to ', A, ' parameter number ', I6,
00083      $      ' had an illegal value ***' )
00084 *
00085 *     End of XERBLA
00086 *
00087       END