![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b XERBLA 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE XERBLA( SRNAME, INFO ) 00012 * 00013 * .. Scalar Arguments .. 00014 * CHARACTER*(*) SRNAME 00015 * INTEGER INFO 00016 * .. 00017 * 00018 * 00019 *> \par Purpose: 00020 * ============= 00021 *> 00022 *> \verbatim 00023 *> 00024 *> This is a special version of XERBLA to be used only as part of 00025 *> the test program for testing error exits from the LAPACK routines. 00026 *> Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRNAMT, 00027 *> where INFOT and SRNAMT are values stored in COMMON. 00028 *> \endverbatim 00029 * 00030 * Arguments: 00031 * ========== 00032 * 00033 *> \param[in] SRNAME 00034 *> \verbatim 00035 *> SRNAME is CHARACTER*(*) 00036 *> The name of the subroutine calling XERBLA. This name should 00037 *> match the COMMON variable SRNAMT. 00038 *> \endverbatim 00039 *> 00040 *> \param[in] INFO 00041 *> \verbatim 00042 *> INFO is INTEGER 00043 *> The error return code from the calling subroutine. INFO 00044 *> should equal the COMMON variable INFOT. 00045 *> \endverbatim 00046 * 00047 * Authors: 00048 * ======== 00049 * 00050 *> \author Univ. of Tennessee 00051 *> \author Univ. of California Berkeley 00052 *> \author Univ. of Colorado Denver 00053 *> \author NAG Ltd. 00054 * 00055 *> \date November 2011 00056 * 00057 *> \ingroup aux_eig 00058 * 00059 *> \par Further Details: 00060 * ===================== 00061 *> 00062 *> \verbatim 00063 *> 00064 *> The following variables are passed via the common blocks INFOC and 00065 *> SRNAMC: 00066 *> 00067 *> INFOT INTEGER Expected integer return code 00068 *> NOUT INTEGER Unit number for printing error messages 00069 *> OK LOGICAL Set to .TRUE. if INFO = INFOT and 00070 *> SRNAME = SRNAMT, otherwise set to .FALSE. 00071 *> LERR LOGICAL Set to .TRUE., indicating that XERBLA was called 00072 *> SRNAMT CHARACTER*(*) Expected name of calling subroutine 00073 *> \endverbatim 00074 *> 00075 * ===================================================================== 00076 SUBROUTINE XERBLA( SRNAME, INFO ) 00077 * 00078 * -- LAPACK test routine (version 3.4.0) -- 00079 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00080 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00081 * November 2011 00082 * 00083 * .. Scalar Arguments .. 00084 CHARACTER*(*) SRNAME 00085 INTEGER INFO 00086 * .. 00087 * 00088 * ===================================================================== 00089 * 00090 * .. Scalars in Common .. 00091 LOGICAL LERR, OK 00092 CHARACTER*32 SRNAMT 00093 INTEGER INFOT, NOUT 00094 * .. 00095 * .. Intrinsic Functions .. 00096 INTRINSIC LEN_TRIM 00097 * .. 00098 * .. Common blocks .. 00099 COMMON / INFOC / INFOT, NOUT, OK, LERR 00100 COMMON / SRNAMC / SRNAMT 00101 * .. 00102 * .. Executable Statements .. 00103 * 00104 LERR = .TRUE. 00105 IF( INFO.NE.INFOT ) THEN 00106 IF( INFOT.NE.0 ) THEN 00107 WRITE( NOUT, FMT = 9999 ) 00108 $ SRNAMT( 1:LEN_TRIM( SRNAMT ) ), INFO, INFOT 00109 ELSE 00110 WRITE( NOUT, FMT = 9997 ) 00111 $ SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO 00112 END IF 00113 OK = .FALSE. 00114 END IF 00115 IF( SRNAME.NE.SRNAMT ) THEN 00116 WRITE( NOUT, FMT = 9998 ) 00117 $ SRNAME( 1:LEN_TRIM( SRNAME ) ), 00118 $ SRNAMT( 1:LEN_TRIM( SRNAMT ) ) 00119 OK = .FALSE. 00120 END IF 00121 RETURN 00122 * 00123 9999 FORMAT( ' *** XERBLA was called from ', A, ' with INFO = ', I6, 00124 $ ' instead of ', I2, ' ***' ) 00125 9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A, 00126 $ ' instead of ', A6, ' ***' ) 00127 9997 FORMAT( ' *** On entry to ', A, ' parameter number ', I6, 00128 $ ' had an illegal value ***' ) 00129 * 00130 * End of XERBLA 00131 * 00132 END