xerbla.f

Go to the documentation of this file.

      SUBROUTINE xerbla( SRNAME, INFO )
*     
*     -- LAPACK auxiliary routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*     
*     .. Scalar Arguments ..
      CHARACTER*(*)      srname
      INTEGER            info
*     ..
*     
*     Purpose
*     =======
*     
*     This is a special version of XERBLA to be used only as part of
*     the test program for testing error exits from the LAPACK routines.
*     Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRMANT,
*     where INFOT and SRNAMT are values stored in COMMON.
*     
*     Arguments
*     =========
*     
*     SRNAME  (input) CHARACTER*(*)
*     The name of the subroutine calling XERBLA.  This name should
*     match the COMMON variable SRNAMT.
*     
*     INFO    (input) INTEGER
*     The error return code from the calling subroutine.  INFO
*     should equal the COMMON variable INFOT.
*     
*     Further Details
*     ======= =======
*     
*     The following variables are passed via the common blocks INFOC and
*     SRNAMC:
*     
*     INFOT   INTEGER      Expected integer return code
*     NOUT    INTEGER      Unit number for printing error messages
*     OK      LOGICAL      Set to .TRUE. if INFO = INFOT and
*     SRNAME = SRNAMT, otherwise set to .FALSE.
*     LERR    LOGICAL      Set to .TRUE., indicating that XERBLA was called
*     SRNAMT  CHARACTER*(*) Expected name of calling subroutine
*     
*     
*     .. Scalars in Common ..
      LOGICAL            lerr, ok
      CHARACTER*32       srnamt
      INTEGER            infot, nout
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          len_trim
*     ..
*     .. Common blocks ..
      common             / infoc / infot, nout, ok, lerr
      common             / srnamc / srnamt
*     ..
*     .. Executable Statements ..
*     
      lerr = .true.
      IF( info.NE.infot ) THEN
         IF( infot.NE.0 ) THEN
            WRITE( nout, fmt = 9999 )
     $           srnamt( 1:len_trim( srnamt ) ), info, infot
         ELSE
            WRITE( nout, fmt = 9997 )
     $           srname( 1:len_trim( srname ) ), info
         END IF
         ok = .false.
      END IF
      IF( srname.NE.srnamt ) THEN
         WRITE( nout, fmt = 9998 )
     $        srname( 1:len_trim( srname ) ),
     $        srnamt( 1:len_trim( srnamt ) )
         ok = .false.
      END IF
      return
*     
 9999 format( ' *** XERBLA was called from ', a, ' with INFO = ', i6,
     $     ' instead of ', i2, ' ***' )
 9998 format( ' *** XERBLA was called with SRNAME = ', a,
     $     ' instead of ', a6, ' ***' )
 9997 format( ' *** On entry to ', a, ' parameter number ', i6,
     $     ' had an illegal value ***' )
*     
*     End of XERBLA
*     
      END