/*< SUBROUTINE XSETUN(IUNIT) >*/ /* Subroutine */ int xsetun_(integer *iunit) { integer junk; extern integer j4save_(integer *, integer *, logical *); /* ABSTRACT */ /* XSETUN SETS THE OUTPUT FILE TO WHICH ERROR MESSAGES ARE TO */ /* BE SENT. ONLY ONE FILE WILL BE USED. SEE XSETUA FOR */ /* HOW TO DECLARE MORE THAN ONE FILE. */ /* DESCRIPTION OF PARAMETER */ /* --INPUT-- */ /* IUNIT - AN INPUT PARAMETER GIVING THE LOGICAL UNIT NUMBER */ /* TO WHICH ERROR MESSAGES ARE TO BE SENT. */ /* WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE */ /* END OF ABSTRACT */ /* LATEST REVISION --- 7 JUNE 1978 */ /*< JUNK = J4SAVE(3,IUNIT,.TRUE.) >*/ #line 17 "../fortran/xsetun.f" junk = j4save_(&c__3, iunit, &c_true); /*< JUNK = J4SAVE(5,1,.TRUE.) >*/ #line 18 "../fortran/xsetun.f" junk = j4save_(&c__5, &c__1, &c_true); /*< RETURN >*/ #line 19 "../fortran/xsetun.f" return 0; /*< END >*/ } /* xsetun_ */
/*< SUBROUTINE XERMAX(MAX) >*/ /* Subroutine */ int xermax_(integer *max__) { integer junk; extern integer j4save_(integer *, integer *, logical *); /* ABSTRACT */ /* XERMAX SETS THE MAXIMUM NUMBER OF TIMES ANY MESSAGE */ /* IS TO BE PRINTED. THAT IS, NON-FATAL MESSAGES ARE */ /* NOT TO BE PRINTED AFTER THEY HAVE OCCURED MAX TIMES. */ /* SUCH NON-FATAL MESSAGES MAY BE PRINTED LESS THAN */ /* MAX TIMES EVEN IF THEY OCCUR MAX TIMES, IF ERROR */ /* SUPPRESSION MODE (KONTRL=0) IS EVER IN EFFECT. */ /* THE DEFAULT VALUE FOR MAX IS 10. */ /* DESCRIPTION OF PARAMETER */ /* --INPUT-- */ /* MAX - THE MAXIMUM NUMBER OF TIMES ANY ONE MESSAGE */ /* IS TO BE PRINTED. */ /* WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE */ /* END OF ABSTRACT */ /* LATEST REVISION --- 7 JUNE 1978 */ /*< JUNK = J4SAVE(4,MAX,.TRUE.) >*/ #line 22 "../fortran/xermax.f" junk = j4save_(&c__4, max__, &c_true); /*< RETURN >*/ #line 23 "../fortran/xermax.f" return 0; /*< END >*/ } /* xermax_ */
/*< FUNCTION NUMXER(NERR) >*/ integer numxer_(integer *nerr) { /* System generated locals */ integer ret_val; /* Local variables */ extern integer j4save_(integer *, integer *, logical *); /* ABSTRACT */ /* NUMXER RETURNS THE MOST RECENT ERROR NUMBER, */ /* IN BOTH NUMXER AND THE PARAMETER NERR. */ /* WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE */ /* END OF ABSTRACT */ /* LATEST REVISION --- 7 JUNE 1978 */ /*< NERR = J4SAVE(1,0,.FALSE.) >*/ #line 73 "../fortran/slatec.f" *nerr = j4save_(&c__1, &c__0, &c_false); /*< NUMXER = NERR >*/ #line 74 "../fortran/slatec.f" ret_val = *nerr; /*< RETURN >*/ #line 75 "../fortran/slatec.f" return ret_val; /*< END >*/ } /* numxer_ */
/* DECK XGETUN */ /* Subroutine */ int xgetun_(integer *iunit) { extern integer j4save_(integer *, integer *, logical *); /* ***BEGIN PROLOGUE XGETUN */ /* ***PURPOSE Return the (first) output file to which error messages */ /* are being sent. */ /* ***LIBRARY SLATEC (XERROR) */ /* ***CATEGORY R3C */ /* ***TYPE ALL (XGETUN-A) */ /* ***KEYWORDS ERROR, XERROR */ /* ***AUTHOR Jones, R. E., (SNLA) */ /* ***DESCRIPTION */ /* Abstract */ /* XGETUN gets the (first) output file to which error messages */ /* are being sent. To find out if more than one file is being */ /* used, one must use the XGETUA routine. */ /* Description of Parameter */ /* --Output-- */ /* IUNIT - the logical unit number of the (first) unit to */ /* which error messages are being sent. */ /* A value of zero means that the default file, as */ /* defined by the I1MACH routine, is being used. */ /* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ /* Error-handling Package, SAND82-0800, Sandia */ /* Laboratories, 1982. */ /* ***ROUTINES CALLED J4SAVE */ /* ***REVISION HISTORY (YYMMDD) */ /* 790801 DATE WRITTEN */ /* 861211 REVISION DATE from Version 3.2 */ /* 891214 Prologue converted to Version 4.0 format. (BAB) */ /* 920501 Reformatted the REFERENCES section. (WRB) */ /* ***END PROLOGUE XGETUN */ /* ***FIRST EXECUTABLE STATEMENT XGETUN */ *iunit = j4save_(&c__3, &c__0, &c_false); return 0; } /* xgetun_ */
/* Subroutine */ int xgetun_(integer *iunit) { extern integer j4save_(integer *, integer *, logical *); /* ABSTRACT */ /* XGETUN GETS THE (FIRST) OUTPUT FILE TO WHICH ERROR MESSAGES */ /* ARE BEING SENT. TO FIND OUT IF MORE THAN ONE FILE IS BEING */ /* USED, ONE MUST USE THE XGETUA ROUTINE. */ /* DESCRIPTION OF PARAMETER */ /* --OUTPUT-- */ /* IUNIT - THE LOGICAL UNIT NUMBER OF THE (FIRST) UNIT TO */ /* WHICH ERROR MESSAGES ARE BEING SENT. */ /* A VALUE OF ZERO MEANS THAT THE DEFAULT FILE, AS */ /* DEFINED BY THE I1MACH ROUTINE, IS BEING USED. */ /* WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE */ /* END OF ABSTRACT */ /* LATEST REVISION --- 23 MAY 1979 */ *iunit = j4save_(&c__3, &c__0, &c_false); return 0; } /* xgetun_ */
/* DECK XSETF */ /* Subroutine */ int xsetf_(integer *kontrl) { /* System generated locals */ address a__1[2]; integer i__1[2]; char ch__1[27]; /* Builtin functions */ integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void) ; /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); /* Local variables */ static integer junk; static char xern1[8]; extern integer j4save_(integer *, integer *, logical *); extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *, integer *, ftnlen, ftnlen, ftnlen); /* Fortran I/O blocks */ static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 }; /* ***BEGIN PROLOGUE XSETF */ /* ***PURPOSE Set the error control flag. */ /* ***LIBRARY SLATEC (XERROR) */ /* ***CATEGORY R3A */ /* ***TYPE ALL (XSETF-A) */ /* ***KEYWORDS ERROR, XERROR */ /* ***AUTHOR Jones, R. E., (SNLA) */ /* ***DESCRIPTION */ /* Abstract */ /* XSETF sets the error control flag value to KONTRL. */ /* (KONTRL is an input parameter only.) */ /* The following table shows how each message is treated, */ /* depending on the values of KONTRL and LEVEL. (See XERMSG */ /* for description of LEVEL.) */ /* If KONTRL is zero or negative, no information other than the */ /* message itself (including numeric values, if any) will be */ /* printed. If KONTRL is positive, introductory messages, */ /* trace-backs, etc., will be printed in addition to the message. */ /* ABS(KONTRL) */ /* LEVEL 0 1 2 */ /* value */ /* 2 fatal fatal fatal */ /* 1 not printed printed fatal */ /* 0 not printed printed printed */ /* -1 not printed printed printed */ /* only only */ /* once once */ /* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ /* Error-handling Package, SAND82-0800, Sandia */ /* Laboratories, 1982. */ /* ***ROUTINES CALLED J4SAVE, XERMSG */ /* ***REVISION HISTORY (YYMMDD) */ /* 790801 DATE WRITTEN */ /* 890531 Changed all specific intrinsics to generic. (WRB) */ /* 890531 REVISION DATE from Version 3.2 */ /* 891214 Prologue converted to Version 4.0 format. (BAB) */ /* 900510 Change call to XERRWV to XERMSG. (RWC) */ /* 920501 Reformatted the REFERENCES section. (WRB) */ /* ***END PROLOGUE XSETF */ /* ***FIRST EXECUTABLE STATEMENT XSETF */ if (abs(*kontrl) > 2) { s_wsfi(&io___2); do_fio(&c__1, (char *)&(*kontrl), (ftnlen)sizeof(integer)); e_wsfi(); /* Writing concatenation */ i__1[0] = 19, a__1[0] = "INVALID ARGUMENT = "; i__1[1] = 8, a__1[1] = xern1; s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)27); xermsg_("SLATEC", "XSETF", ch__1, &c__1, &c__2, (ftnlen)6, (ftnlen)5, (ftnlen)27); return 0; } junk = j4save_(&c__2, kontrl, &c_true); return 0; } /* xsetf_ */
/*< SUBROUTINE XGETUA(IUNIT,N) >*/ /* Subroutine */ int xgetua_(integer *iunit, integer *n) { /* System generated locals */ integer i__1; /* Local variables */ integer i__, index; extern integer j4save_(integer *, integer *, logical *); /* ABSTRACT */ /* XGETUA MAY BE CALLED TO DETERMINE THE UNIT NUMBER OR NUMBERS */ /* TO WHICH ERROR MESSAGES ARE BEING SENT. */ /* THESE UNIT NUMBERS MAY HAVE BEEN SET BY A CALL TO XSETUN, */ /* OR A CALL TO XSETUA, OR MAY BE A DEFAULT VALUE. */ /* DESCRIPTION OF PARAMETERS */ /* --OUTPUT-- */ /* IUNIT - AN ARRAY OF ONE TO FIVE UNIT NUMBERS, DEPENDING */ /* ON THE VALUE OF N. A VALUE OF ZERO REFERS TO THE */ /* DEFAULT UNIT, AS DEFINED BY THE I1MACH MACHINE */ /* CONSTANT ROUTINE. ONLY IUNIT(1),...,IUNIT(N) ARE */ /* DEFINED BY XGETUA. THE VALUES OF IUNIT(N+1),..., */ /* IUNIT(5) ARE NOT DEFINED (FOR N.LT.5) OR ALTERED */ /* IN ANY WAY BY XGETUA. */ /* N - THE NUMBER OF UNITS TO WHICH COPIES OF THE */ /* ERROR MESSAGES ARE BEING SENT. N WILL BE IN THE */ /* RANGE FROM 1 TO 5. */ /* WRITTEN BY RON JONES, WITH SLATEC COMMON MATH LIBRARY SUBCOMMITTEE */ /* END OF ABSTRACT */ /*< DIMENSION IUNIT(5) >*/ /*< N = J4SAVE(5,0,.FALSE.) >*/ #line 26 "../fortran/xgetua.f" /* Parameter adjustments */ #line 26 "../fortran/xgetua.f" --iunit; #line 26 "../fortran/xgetua.f" #line 26 "../fortran/xgetua.f" /* Function Body */ #line 26 "../fortran/xgetua.f" *n = j4save_(&c__5, &c__0, &c_false); /*< DO 30 I=1,N >*/ #line 27 "../fortran/xgetua.f" i__1 = *n; #line 27 "../fortran/xgetua.f" for (i__ = 1; i__ <= i__1; ++i__) { /*< INDEX = I+4 >*/ #line 28 "../fortran/xgetua.f" index = i__ + 4; /*< IF (I.EQ.1) INDEX = 3 >*/ #line 29 "../fortran/xgetua.f" if (i__ == 1) { #line 29 "../fortran/xgetua.f" index = 3; #line 29 "../fortran/xgetua.f" } /*< IUNIT(I) = J4SAVE(INDEX,0,.FALSE.) >*/ #line 30 "../fortran/xgetua.f" iunit[i__] = j4save_(&index, &c__0, &c_false); /*< 30 CONTINUE >*/ #line 31 "../fortran/xgetua.f" /* L30: */ #line 31 "../fortran/xgetua.f" } /*< RETURN >*/ #line 32 "../fortran/xgetua.f" return 0; /*< END >*/ } /* xgetua_ */
/* DECK XERMSG */ /* Subroutine */ int xermsg_(char *librar, char *subrou, char *messg, integer *nerr, integer *level, ftnlen librar_len, ftnlen subrou_len, ftnlen messg_len) { /* System generated locals */ address a__1[2]; integer i__1, i__2, i__3[2]; char ch__1[87]; icilist ici__1; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer i_len(char *, ftnlen), s_wsfi(icilist *), do_fio(integer *, char * , ftnlen), e_wsfi(void); /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); /* Local variables */ integer i__, lerr; char temp[72]; extern /* Subroutine */ int fdump_(void); char xlibr[8]; integer ltemp, kount; char xsubr[8]; extern integer j4save_(integer *, integer *, logical *); integer llevel, maxmes; char lfirst[20]; extern /* Subroutine */ int xercnt_(char *, char *, char *, integer *, integer *, integer *, ftnlen, ftnlen, ftnlen); integer lkntrl, kdummy; extern /* Subroutine */ int xerhlt_(char *, ftnlen); integer mkntrl; extern /* Subroutine */ int xersve_(char *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen, ftnlen), xerprn_( char *, integer *, char *, integer *, ftnlen, ftnlen); /* ***BEGIN PROLOGUE XERMSG */ /* ***PURPOSE Process error messages for SLATEC and other libraries. */ /* ***LIBRARY SLATEC (XERROR) */ /* ***CATEGORY R3C */ /* ***TYPE ALL (XERMSG-A) */ /* ***KEYWORDS ERROR MESSAGE, XERROR */ /* ***AUTHOR Fong, Kirby, (NMFECC at LLNL) */ /* ***DESCRIPTION */ /* XERMSG processes a diagnostic message in a manner determined by the */ /* value of LEVEL and the current value of the library error control */ /* flag, KONTRL. See subroutine XSETF for details. */ /* LIBRAR A character constant (or character variable) with the name */ /* of the library. This will be 'SLATEC' for the SLATEC */ /* Common Math Library. The error handling package is */ /* general enough to be used by many libraries */ /* simultaneously, so it is desirable for the routine that */ /* detects and reports an error to identify the library name */ /* as well as the routine name. */ /* SUBROU A character constant (or character variable) with the name */ /* of the routine that detected the error. Usually it is the */ /* name of the routine that is calling XERMSG. There are */ /* some instances where a user callable library routine calls */ /* lower level subsidiary routines where the error is */ /* detected. In such cases it may be more informative to */ /* supply the name of the routine the user called rather than */ /* the name of the subsidiary routine that detected the */ /* error. */ /* MESSG A character constant (or character variable) with the text */ /* of the error or warning message. In the example below, */ /* the message is a character constant that contains a */ /* generic message. */ /* CALL XERMSG ('SLATEC', 'MMPY', */ /* *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', */ /* *3, 1) */ /* It is possible (and is sometimes desirable) to generate a */ /* specific message--e.g., one that contains actual numeric */ /* values. Specific numeric values can be converted into */ /* character strings using formatted WRITE statements into */ /* character variables. This is called standard Fortran */ /* internal file I/O and is exemplified in the first three */ /* lines of the following example. You can also catenate */ /* substrings of characters to construct the error message. */ /* Here is an example showing the use of both writing to */ /* an internal file and catenating character strings. */ /* CHARACTER*5 CHARN, CHARL */ /* WRITE (CHARN,10) N */ /* WRITE (CHARL,10) LDA */ /* 10 FORMAT(I5) */ /* CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// */ /* * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// */ /* * CHARL, 3, 1) */ /* There are two subtleties worth mentioning. One is that */ /* the // for character catenation is used to construct the */ /* error message so that no single character constant is */ /* continued to the next line. This avoids confusion as to */ /* whether there are trailing blanks at the end of the line. */ /* The second is that by catenating the parts of the message */ /* as an actual argument rather than encoding the entire */ /* message into one large character variable, we avoid */ /* having to know how long the message will be in order to */ /* declare an adequate length for that large character */ /* variable. XERMSG calls XERPRN to print the message using */ /* multiple lines if necessary. If the message is very long, */ /* XERPRN will break it into pieces of 72 characters (as */ /* requested by XERMSG) for printing on multiple lines. */ /* Also, XERMSG asks XERPRN to prefix each line with ' * ' */ /* so that the total line length could be 76 characters. */ /* Note also that XERPRN scans the error message backwards */ /* to ignore trailing blanks. Another feature is that */ /* the substring '$$' is treated as a new line sentinel */ /* by XERPRN. If you want to construct a multiline */ /* message without having to count out multiples of 72 */ /* characters, just use '$$' as a separator. '$$' */ /* obviously must occur within 72 characters of the */ /* start of each line to have its intended effect since */ /* XERPRN is asked to wrap around at 72 characters in */ /* addition to looking for '$$'. */ /* NERR An integer value that is chosen by the library routine's */ /* author. It must be in the range -99 to 999 (three */ /* printable digits). Each distinct error should have its */ /* own error number. These error numbers should be described */ /* in the machine readable documentation for the routine. */ /* The error numbers need be unique only within each routine, */ /* so it is reasonable for each routine to start enumerating */ /* errors from 1 and proceeding to the next integer. */ /* LEVEL An integer value in the range 0 to 2 that indicates the */ /* level (severity) of the error. Their meanings are */ /* -1 A warning message. This is used if it is not clear */ /* that there really is an error, but the user's attention */ /* may be needed. An attempt is made to only print this */ /* message once. */ /* 0 A warning message. This is used if it is not clear */ /* that there really is an error, but the user's attention */ /* may be needed. */ /* 1 A recoverable error. This is used even if the error is */ /* so serious that the routine cannot return any useful */ /* answer. If the user has told the error package to */ /* return after recoverable errors, then XERMSG will */ /* return to the Library routine which can then return to */ /* the user's routine. The user may also permit the error */ /* package to terminate the program upon encountering a */ /* recoverable error. */ /* 2 A fatal error. XERMSG will not return to its caller */ /* after it receives a fatal error. This level should */ /* hardly ever be used; it is much better to allow the */ /* user a chance to recover. An example of one of the few */ /* cases in which it is permissible to declare a level 2 */ /* error is a reverse communication Library routine that */ /* is likely to be called repeatedly until it integrates */ /* across some interval. If there is a serious error in */ /* the input such that another step cannot be taken and */ /* the Library routine is called again without the input */ /* error having been corrected by the caller, the Library */ /* routine will probably be called forever with improper */ /* input. In this case, it is reasonable to declare the */ /* error to be fatal. */ /* Each of the arguments to XERMSG is input; none will be modified by */ /* XERMSG. A routine may make multiple calls to XERMSG with warning */ /* level messages; however, after a call to XERMSG with a recoverable */ /* error, the routine should return to the user. Do not try to call */ /* XERMSG with a second recoverable error after the first recoverable */ /* error because the error package saves the error number. The user */ /* can retrieve this error number by calling another entry point in */ /* the error handling package and then clear the error number when */ /* recovering from the error. Calling XERMSG in succession causes the */ /* old error number to be overwritten by the latest error number. */ /* This is considered harmless for error numbers associated with */ /* warning messages but must not be done for error numbers of serious */ /* errors. After a call to XERMSG with a recoverable error, the user */ /* must be given a chance to call NUMXER or XERCLR to retrieve or */ /* clear the error number. */ /* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ /* Error-handling Package, SAND82-0800, Sandia */ /* Laboratories, 1982. */ /* ***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE */ /* ***REVISION HISTORY (YYMMDD) */ /* 880101 DATE WRITTEN */ /* 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. */ /* THERE ARE TWO BASIC CHANGES. */ /* 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO */ /* PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES */ /* INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS */ /* ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE */ /* ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER */ /* ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY */ /* 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE */ /* LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. */ /* 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE */ /* FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE */ /* OF LOWER CASE. */ /* 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. */ /* THE PRINCIPAL CHANGES ARE */ /* 1. CLARIFY COMMENTS IN THE PROLOGUES */ /* 2. RENAME XRPRNT TO XERPRN */ /* 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES */ /* SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / */ /* CHARACTER FOR NEW RECORDS. */ /* 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO */ /* CLEAN UP THE CODING. */ /* 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN */ /* PREFIX. */ /* 891013 REVISED TO CORRECT COMMENTS. */ /* 891214 Prologue converted to Version 4.0 format. (WRB) */ /* 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but */ /* NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added */ /* LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and */ /* XERCTL to XERCNT. (RWC) */ /* 920501 Reformatted the REFERENCES section. (WRB) */ /* ***END PROLOGUE XERMSG */ /* ***FIRST EXECUTABLE STATEMENT XERMSG */ lkntrl = j4save_(&c__2, &c__0, &c_false); maxmes = j4save_(&c__4, &c__0, &c_false); /* LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. */ /* MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE */ /* SHOULD BE PRINTED. */ /* WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN */ /* CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, */ /* AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. */ if (*nerr < -9999999 || *nerr > 99999999 || *nerr == 0 || *level < -1 || * level > 2) { xerprn_(" ***", &c_n1, "FATAL ERROR IN...$$ XERMSG -- INVALID ERROR " "NUMBER OR LEVEL$$ JOB ABORT DUE TO FATAL ERROR.", &c__72, ( ftnlen)4, (ftnlen)91); xersve_(" ", " ", " ", &c__0, &c__0, &c__0, &kdummy, (ftnlen)1, ( ftnlen)1, (ftnlen)1); xerhlt_(" ***XERMSG -- INVALID INPUT", (ftnlen)27); return 0; } /* RECORD THE MESSAGE. */ i__ = j4save_(&c__1, nerr, &c_true); xersve_(librar, subrou, messg, &c__1, nerr, level, &kount, librar_len, subrou_len, messg_len); /* HANDLE PRINT-ONCE WARNING MESSAGES. */ if (*level == -1 && kount > 1) { return 0; } /* ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. */ s_copy(xlibr, librar, (ftnlen)8, librar_len); s_copy(xsubr, subrou, (ftnlen)8, subrou_len); s_copy(lfirst, messg, (ftnlen)20, messg_len); lerr = *nerr; llevel = *level; xercnt_(xlibr, xsubr, lfirst, &lerr, &llevel, &lkntrl, (ftnlen)8, (ftnlen) 8, (ftnlen)20); /* Computing MAX */ i__1 = -2, i__2 = min(2,lkntrl); lkntrl = max(i__1,i__2); mkntrl = abs(lkntrl); /* SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS */ /* ZERO AND THE ERROR IS NOT FATAL. */ if (*level < 2 && lkntrl == 0) { goto L30; } if (*level == 0 && kount > maxmes) { goto L30; } if (*level == 1 && kount > maxmes && mkntrl == 1) { goto L30; } if (*level == 2 && kount > max(1,maxmes)) { goto L30; } /* ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A */ /* MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) */ /* AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG */ /* IS NOT ZERO. */ if (lkntrl != 0) { s_copy(temp, "MESSAGE FROM ROUTINE ", (ftnlen)21, (ftnlen)21); /* Computing MIN */ i__1 = i_len(subrou, subrou_len); i__ = min(i__1,16); s_copy(temp + 21, subrou, i__, i__); i__1 = i__ + 21; s_copy(temp + i__1, " IN LIBRARY ", i__ + 33 - i__1, (ftnlen)12); ltemp = i__ + 33; /* Computing MIN */ i__1 = i_len(librar, librar_len); i__ = min(i__1,16); i__1 = ltemp; s_copy(temp + i__1, librar, ltemp + i__ - i__1, i__); i__1 = ltemp + i__; s_copy(temp + i__1, ".", ltemp + i__ + 1 - i__1, (ftnlen)1); ltemp = ltemp + i__ + 1; xerprn_(" ***", &c_n1, temp, &c__72, (ftnlen)4, ltemp); } /* IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE */ /* PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE */ /* FROM EACH OF THE FOLLOWING THREE OPTIONS. */ /* 1. LEVEL OF THE MESSAGE */ /* 'INFORMATIVE MESSAGE' */ /* 'POTENTIALLY RECOVERABLE ERROR' */ /* 'FATAL ERROR' */ /* 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE */ /* 'PROG CONTINUES' */ /* 'PROG ABORTED' */ /* 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK */ /* MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS */ /* WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) */ /* 'TRACEBACK REQUESTED' */ /* 'TRACEBACK NOT REQUESTED' */ /* NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT */ /* EXCEED 74 CHARACTERS. */ /* WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. */ if (lkntrl > 0) { /* THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. */ if (*level <= 0) { s_copy(temp, "INFORMATIVE MESSAGE,", (ftnlen)20, (ftnlen)20); ltemp = 20; } else if (*level == 1) { s_copy(temp, "POTENTIALLY RECOVERABLE ERROR,", (ftnlen)30, ( ftnlen)30); ltemp = 30; } else { s_copy(temp, "FATAL ERROR,", (ftnlen)12, (ftnlen)12); ltemp = 12; } /* THEN WHETHER THE PROGRAM WILL CONTINUE. */ if ((mkntrl == 2 && *level >= 1) || (mkntrl == 1 && *level == 2)) { i__1 = ltemp; s_copy(temp + i__1, " PROG ABORTED,", ltemp + 14 - i__1, (ftnlen) 14); ltemp += 14; } else { i__1 = ltemp; s_copy(temp + i__1, " PROG CONTINUES,", ltemp + 16 - i__1, ( ftnlen)16); ltemp += 16; } /* FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. */ if (lkntrl > 0) { i__1 = ltemp; s_copy(temp + i__1, " TRACEBACK REQUESTED", ltemp + 20 - i__1, ( ftnlen)20); ltemp += 20; } else { i__1 = ltemp; s_copy(temp + i__1, " TRACEBACK NOT REQUESTED", ltemp + 24 - i__1, (ftnlen)24); ltemp += 24; } xerprn_(" ***", &c_n1, temp, &c__72, (ftnlen)4, ltemp); } /* NOW SEND OUT THE MESSAGE. */ xerprn_(" * ", &c_n1, messg, &c__72, (ftnlen)4, messg_len); /* IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A */ /* TRACEBACK. */ if (lkntrl > 0) { ici__1.icierr = 0; ici__1.icirnum = 1; ici__1.icirlen = 72; ici__1.iciunit = temp; ici__1.icifmt = "('ERROR NUMBER = ', I8)"; s_wsfi(&ici__1); do_fio(&c__1, (char *)&(*nerr), (ftnlen)sizeof(integer)); e_wsfi(); for (i__ = 16; i__ <= 22; ++i__) { if (*(unsigned char *)&temp[i__ - 1] != ' ') { goto L20; } /* L10: */ } L20: /* Writing concatenation */ i__3[0] = 15, a__1[0] = temp; i__3[1] = 23 - (i__ - 1), a__1[1] = temp + (i__ - 1); s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)87); xerprn_(" * ", &c_n1, ch__1, &c__72, (ftnlen)4, 23 - (i__ - 1) + 15); fdump_(); } /* IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. */ if (lkntrl != 0) { xerprn_(" * ", &c_n1, " ", &c__72, (ftnlen)4, (ftnlen)1); xerprn_(" ***", &c_n1, "END OF MESSAGE", &c__72, (ftnlen)4, (ftnlen) 14); xerprn_(" ", &c__0, " ", &c__72, (ftnlen)4, (ftnlen)1); } /* IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE */ /* CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. */ L30: if ((*level <= 0) || (*level == 1 && mkntrl <= 1)) { return 0; } /* THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A */ /* FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR */ /* SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. */ if (lkntrl > 0 && kount < max(1,maxmes)) { if (*level == 1) { xerprn_(" ***", &c_n1, "JOB ABORT DUE TO UNRECOVERED ERROR.", & c__72, (ftnlen)4, (ftnlen)35); } else { xerprn_(" ***", &c_n1, "JOB ABORT DUE TO FATAL ERROR.", &c__72, ( ftnlen)4, (ftnlen)29); } xersve_(" ", " ", " ", &c_n1, &c__0, &c__0, &kdummy, (ftnlen)1, ( ftnlen)1, (ftnlen)1); xerhlt_(" ", (ftnlen)1); } else { xerhlt_(messg, messg_len); } return 0; } /* xermsg_ */
/* DECK XGETUA */ /* Subroutine */ int xgetua_(integer *iunita, integer *n) { /* System generated locals */ integer i__1; /* Local variables */ static integer i__, index; extern integer j4save_(integer *, integer *, logical *); /* ***BEGIN PROLOGUE XGETUA */ /* ***PURPOSE Return unit number(s) to which error messages are being */ /* sent. */ /* ***LIBRARY SLATEC (XERROR) */ /* ***CATEGORY R3C */ /* ***TYPE ALL (XGETUA-A) */ /* ***KEYWORDS ERROR, XERROR */ /* ***AUTHOR Jones, R. E., (SNLA) */ /* ***DESCRIPTION */ /* Abstract */ /* XGETUA may be called to determine the unit number or numbers */ /* to which error messages are being sent. */ /* These unit numbers may have been set by a call to XSETUN, */ /* or a call to XSETUA, or may be a default value. */ /* Description of Parameters */ /* --Output-- */ /* IUNIT - an array of one to five unit numbers, depending */ /* on the value of N. A value of zero refers to the */ /* default unit, as defined by the I1MACH machine */ /* constant routine. Only IUNIT(1),...,IUNIT(N) are */ /* defined by XGETUA. The values of IUNIT(N+1),..., */ /* IUNIT(5) are not defined (for N .LT. 5) or altered */ /* in any way by XGETUA. */ /* N - the number of units to which copies of the */ /* error messages are being sent. N will be in the */ /* range from 1 to 5. */ /* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ /* Error-handling Package, SAND82-0800, Sandia */ /* Laboratories, 1982. */ /* ***ROUTINES CALLED J4SAVE */ /* ***REVISION HISTORY (YYMMDD) */ /* 790801 DATE WRITTEN */ /* 861211 REVISION DATE from Version 3.2 */ /* 891214 Prologue converted to Version 4.0 format. (BAB) */ /* 920501 Reformatted the REFERENCES section. (WRB) */ /* ***END PROLOGUE XGETUA */ /* ***FIRST EXECUTABLE STATEMENT XGETUA */ /* Parameter adjustments */ --iunita; /* Function Body */ *n = j4save_(&c__5, &c__0, &c_false); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { index = i__ + 4; if (i__ == 1) { index = 3; } iunita[i__] = j4save_(&index, &c__0, &c_false); /* L30: */ } return 0; } /* xgetua_ */