xerbla.c
Go to the documentation of this file.
00001 /* xerbla.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 #include "string.h"
00016 
00017 /* Common Block Declarations */
00018 
00019 struct {
00020     integer infot, nout;
00021     logical ok, lerr;
00022 } infoc_;
00023 
00024 #define infoc_1 infoc_
00025 
00026 struct {
00027     char srnamt[32];
00028 } srnamc_;
00029 
00030 #define srnamc_1 srnamc_
00031 
00032 /* Table of constant values */
00033 
00034 static integer c__1 = 1;
00035 
00036 /* Subroutine */ int xerbla_(char *srname, integer *info)
00037 {
00038     /* Format strings */
00039     static char fmt_9999[] = "(\002 *** XERBLA was called from \002,a,\002 w"
00040             "ith INFO = \002,i6,\002 instead of \002,i2,\002 ***\002)";
00041     static char fmt_9997[] = "(\002 *** On entry to \002,a,\002 parameter nu"
00042             "mber \002,i6,\002 had an illegal value ***\002)";
00043     static char fmt_9998[] = "(\002 *** XERBLA was called with SRNAME = \002"
00044             ",a,\002 instead of \002,a6,\002 ***\002)";
00045 
00046     /* Builtin functions */
00047     integer s_wsfe(cilist *), i_len_trim(char *, ftnlen), do_fio(integer *, 
00048             char *, ftnlen), e_wsfe(void), s_cmp(char *, char *, ftnlen, 
00049             ftnlen);
00050 
00051     /* Fortran I/O blocks */
00052     static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
00053     static cilist io___2 = { 0, 0, 0, fmt_9997, 0 };
00054     static cilist io___3 = { 0, 0, 0, fmt_9998, 0 };
00055 
00056         int srname_len;
00057 
00058         srname_len = strlen (srname);
00059 
00060 
00061 /*  -- LAPACK auxiliary routine (version 3.1) -- */
00062 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00063 /*     November 2006 */
00064 
00065 /*     .. Scalar Arguments .. */
00066 /*     .. */
00067 
00068 /*  Purpose */
00069 /*  ======= */
00070 
00071 /*  This is a special version of XERBLA to be used only as part of */
00072 /*  the test program for testing error exits from the LAPACK routines. */
00073 /*  Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRMANT, */
00074 /*  where INFOT and SRNAMT are values stored in COMMON. */
00075 
00076 /*  Arguments */
00077 /*  ========= */
00078 
00079 /*  SRNAME  (input) CHARACTER*(*) */
00080 /*          The name of the subroutine calling XERBLA.  This name should */
00081 /*          match the COMMON variable SRNAMT. */
00082 
00083 /*  INFO    (input) INTEGER */
00084 /*          The error return code from the calling subroutine.  INFO */
00085 /*          should equal the COMMON variable INFOT. */
00086 
00087 /*  Further Details */
00088 /*  ======= ======= */
00089 
00090 /*  The following variables are passed via the common blocks INFOC and */
00091 /*  SRNAMC: */
00092 
00093 /*  INFOT   INTEGER      Expected integer return code */
00094 /*  NOUT    INTEGER      Unit number for printing error messages */
00095 /*  OK      LOGICAL      Set to .TRUE. if INFO = INFOT and */
00096 /*                       SRNAME = SRNAMT, otherwise set to .FALSE. */
00097 /*  LERR    LOGICAL      Set to .TRUE., indicating that XERBLA was called */
00098 /*  SRNAMT  CHARACTER*(*) Expected name of calling subroutine */
00099 
00100 
00101 /*     .. Scalars in Common .. */
00102 /*     .. */
00103 /*     .. Intrinsic Functions .. */
00104 /*     .. */
00105 /*     .. Common blocks .. */
00106 /*     .. */
00107 /*     .. Executable Statements .. */
00108 
00109     infoc_1.lerr = TRUE_;
00110     if (*info != infoc_1.infot) {
00111         if (infoc_1.infot != 0) {
00112             io___1.ciunit = infoc_1.nout;
00113             s_wsfe(&io___1);
00114             do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
00115                     ftnlen)32));
00116             do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
00117             do_fio(&c__1, (char *)&infoc_1.infot, (ftnlen)sizeof(integer));
00118             e_wsfe();
00119         } else {
00120             io___2.ciunit = infoc_1.nout;
00121             s_wsfe(&io___2);
00122             do_fio(&c__1, srname, i_len_trim(srname, srname_len));
00123             do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
00124             e_wsfe();
00125         }
00126         infoc_1.ok = FALSE_;
00127     }
00128     if (s_cmp(srname, srnamc_1.srnamt, srname_len, (ftnlen)32) != 0) {
00129         io___3.ciunit = infoc_1.nout;
00130         s_wsfe(&io___3);
00131         do_fio(&c__1, srname, i_len_trim(srname, srname_len));
00132         do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (ftnlen)32)
00133                 );
00134         e_wsfe();
00135         infoc_1.ok = FALSE_;
00136     }
00137     return 0;
00138 
00139 
00140 /*     End of XERBLA */
00141 
00142 } /* xerbla_ */


swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:56:16