Mercurial > jwe > octave
changeset 3122:c2d111b3f1bf
[project @ 1997-12-01 06:52:23 by jwe]
| author | jwe |
|---|---|
| date | Mon, 01 Dec 1997 06:52:23 +0000 |
| parents | 923049908004 |
| children | e3fc19fa9e69 |
| files | libcruft/dassl/xerhlt.f libcruft/dassl/xermsg.f libcruft/dassl/xerprn.f libcruft/dassl/xgetua.f libcruft/dassl/xsetua.f |
| diffstat | 5 files changed, 0 insertions(+), 700 deletions(-) [+] |
line wrap: on
line diff
--- a/libcruft/dassl/xerhlt.f Mon Dec 01 00:01:01 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,37 +0,0 @@ - SUBROUTINE XERHLT (MESSG) -C***BEGIN PROLOGUE XERHLT -C***SUBSIDIARY -C***PURPOSE Abort program execution and print error message. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERHLT-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR JONES, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C ***Note*** machine dependent routine -C XERHLT aborts the execution of the program. -C The error message causing the abort is given in the calling -C sequence, in case one needs it for printing on a dayfile, -C for example. -C -C Description of Parameters -C MESSG is as in XERROR. -C -C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- -C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, -C 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN as XERABT -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900206 Routine changed from user-callable to subsidiary. (WRB) -C 900510 Changed calling sequence to delete length of char string -C Changed subroutine name from XERABT to XERHLT. (RWC) -C***END PROLOGUE XERHLT - CHARACTER*(*) MESSG -C***FIRST EXECUTABLE STATEMENT XERHLT - CALL XSTOPX (MESSG) - END
--- a/libcruft/dassl/xermsg.f Mon Dec 01 00:01:01 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,308 +0,0 @@ -C*DECK XERMSG - SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) -C***BEGIN PROLOGUE XERMSG -C***PURPOSE Processes error messages for SLATEC and other libraries -C***LIBRARY SLATEC -C***CATEGORY R3C -C***TYPE ALL -C***KEYWORDS ERROR MESSAGE, XERROR -C***AUTHOR FONG, KIRBY, (NMFECC AT LLNL) -C Modified by -C FRITSCH, F. N., (LLNL) -C***DESCRIPTION -C -C XERMSG processes a diagnostic message in a manner determined by the -C value of LEVEL and the current value of the library error control -C flag, KONTRL. See subroutine XSETF for details. -C (XSETF is inoperable in this version.). -C -C LIBRAR A character constant (or character variable) with the name -C of the library. This will be 'SLATEC' for the SLATEC -C Common Math Library. The error handling package is -C general enough to be used by many libraries -C simultaneously, so it is desirable for the routine that -C detects and reports an error to identify the library name -C as well as the routine name. -C -C SUBROU A character constant (or character variable) with the name -C of the routine that detected the error. Usually it is the -C name of the routine that is calling XERMSG. There are -C some instances where a user callable library routine calls -C lower level subsidiary routines where the error is -C detected. In such cases it may be more informative to -C supply the name of the routine the user called rather than -C the name of the subsidiary routine that detected the -C error. -C -C MESSG A character constant (or character variable) with the text -C of the error or warning message. In the example below, -C the message is a character constant that contains a -C generic message. -C -C CALL XERMSG ('SLATEC', 'MMPY', -C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', -C *3, 1) -C -C It is possible (and is sometimes desirable) to generate a -C specific message--e.g., one that contains actual numeric -C values. Specific numeric values can be converted into -C character strings using formatted WRITE statements into -C character variables. This is called standard Fortran -C internal file I/O and is exemplified in the first three -C lines of the following example. You can also catenate -C substrings of characters to construct the error message. -C Here is an example showing the use of both writing to -C an internal file and catenating character strings. -C -C CHARACTER*5 CHARN, CHARL -C WRITE (CHARN,10) N -C WRITE (CHARL,10) LDA -C 10 FORMAT(I5) -C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// -C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// -C * CHARL, 3, 1) -C -C There are two subtleties worth mentioning. One is that -C the // for character catenation is used to construct the -C error message so that no single character constant is -C continued to the next line. This avoids confusion as to -C whether there are trailing blanks at the end of the line. -C The second is that by catenating the parts of the message -C as an actual argument rather than encoding the entire -C message into one large character variable, we avoid -C having to know how long the message will be in order to -C declare an adequate length for that large character -C variable. XERMSG calls XERPRN to print the message using -C multiple lines if necessary. If the message is very long, -C XERPRN will break it into pieces of 72 characters (as -C requested by XERMSG) for printing on multiple lines. -C Also, XERMSG asks XERPRN to prefix each line with ' * ' -C so that the total line length could be 76 characters. -C Note also that XERPRN scans the error message backwards -C to ignore trailing blanks. Another feature is that -C the substring '$$' is treated as a new line sentinel -C by XERPRN. If you want to construct a multiline -C message without having to count out multiples of 72 -C characters, just use '$$' as a separator. '$$' -C obviously must occur within 72 characters of the -C start of each line to have its intended effect since -C XERPRN is asked to wrap around at 72 characters in -C addition to looking for '$$'. -C -C NERR An integer value that is chosen by the library routine's -C author. It must be in the range -9999999 to 99999999 (8 -C printable digits). Each distinct error should have its -C own error number. These error numbers should be described -C in the machine readable documentation for the routine. -C The error numbers need be unique only within each routine, -C so it is reasonable for each routine to start enumerating -C errors from 1 and proceeding to the next integer. -C -C LEVEL An integer value in the range 0 to 2 that indicates the -C level (severity) of the error. Their meanings are -C -C -1 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. An attempt is made to only print this -C message once. -C -C 0 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. -C -C 1 A recoverable error. This is used even if the error is -C so serious that the routine cannot return any useful -C answer. If the user has told the error package to -C return after recoverable errors, then XERMSG will -C return to the Library routine which can then return to -C the user's routine. The user may also permit the error -C package to terminate the program upon encountering a -C recoverable error. -C -C 2 A fatal error. XERMSG will not return to its caller -C after it receives a fatal error. This level should -C hardly ever be used; it is much better to allow the -C user a chance to recover. An example of one of the few -C cases in which it is permissible to declare a level 2 -C error is a reverse communication Library routine that -C is likely to be called repeatedly until it integrates -C across some interval. If there is a serious error in -C the input such that another step cannot be taken and -C the Library routine is called again without the input -C error having been corrected by the caller, the Library -C routine will probably be called forever with improper -C input. In this case, it is reasonable to declare the -C error to be fatal. -C -C Each of the arguments to XERMSG is input; none will be modified by -C XERMSG. A routine may make multiple calls to XERMSG with warning -C level messages; however, after a call to XERMSG with a recoverable -C error, the routine should return to the user. -C -C***REFERENCES JONES, RONDALL E. AND KAHANER, DAVID K., "XERROR, THE -C SLATEC ERROR-HANDLING PACKAGE", SOFTWARE - PRACTICE -C AND EXPERIENCE, VOLUME 13, NO. 3, PP. 251-257, -C MARCH, 1983. -C***ROUTINES CALLED XERHLT, XERPRN -C***REVISION HISTORY (YYMMDD) -C 880101 DATE WRITTEN -C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. -C THERE ARE TWO BASIC CHANGES. -C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO -C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES -C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS -C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE -C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER -C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY -C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE -C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. -C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE -C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE -C OF LOWER CASE. -C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. -C THE PRINCIPAL CHANGES ARE -C 1. CLARIFY COMMENTS IN THE PROLOGUES -C 2. RENAME XRPRNT TO XERPRN -C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES -C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / -C CHARACTER FOR NEW RECORDS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C CLEAN UP THE CODING. -C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN -C PREFIX. -C 891013 REVISED TO CORRECT COMMENTS. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but -C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added -C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and -C XERCTL to XERCNT. (RWC) -C 901011 Removed error saving features to produce a simplified -C version for distribution with DASSL and other LLNL codes. -C (FNF) -C***END PROLOGUE XERMSG - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*72 TEMP -C***FIRST EXECUTABLE STATEMENT XERMSG -C -C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN -C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, -C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. -C - IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. - * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN - CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // - * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// - * 'JOB ABORT DUE TO FATAL ERROR.', 72) - CALL XERHLT (' ***XERMSG -- INVALID INPUT') - RETURN - ENDIF -C -C SET DEFAULT VALUES FOR CONTROL PARAMETERS. -C - LKNTRL = 1 - MKNTRL = 1 -C -C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A -C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) -C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG -C IS NOT ZERO. -C - IF (LKNTRL .NE. 0) THEN - TEMP(1:21) = 'MESSAGE FROM ROUTINE ' - I = MIN(LEN(SUBROU), 16) - TEMP(22:21+I) = SUBROU(1:I) - TEMP(22+I:33+I) = ' IN LIBRARY ' - LTEMP = 33 + I - I = MIN(LEN(LIBRAR), 16) - TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) - TEMP(LTEMP+I+1:LTEMP+I+1) = '.' - LTEMP = LTEMP + I + 1 - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE -C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE -C FROM EACH OF THE FOLLOWING TWO OPTIONS. -C 1. LEVEL OF THE MESSAGE -C 'INFORMATIVE MESSAGE' -C 'POTENTIALLY RECOVERABLE ERROR' -C 'FATAL ERROR' -C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE -C 'PROGRAM CONTINUES' -C 'PROGRAM ABORTED' -C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT -C EXCEED 74 CHARACTERS. -C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. -C - IF (LKNTRL .GT. 0) THEN -C -C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. -C - IF (LEVEL .LE. 0) THEN - TEMP(1:20) = 'INFORMATIVE MESSAGE,' - LTEMP = 20 - ELSEIF (LEVEL .EQ. 1) THEN - TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' - LTEMP = 30 - ELSE - TEMP(1:12) = 'FATAL ERROR,' - LTEMP = 12 - ENDIF -C -C THEN WHETHER THE PROGRAM WILL CONTINUE. -C - IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. - * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN - TEMP(LTEMP+1:LTEMP+17) = ' PROGRAM ABORTED.' - LTEMP = LTEMP + 17 - ELSE - TEMP(LTEMP+1:LTEMP+19) = ' PROGRAM CONTINUES.' - LTEMP = LTEMP + 19 - ENDIF -C - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C NOW SEND OUT THE MESSAGE. -C - CALL XERPRN (' * ', -1, MESSG, 72) -C -C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER. -C - IF (LKNTRL .GT. 0) THEN - WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR - DO 10 I=16,22 - IF (TEMP(I:I) .NE. ' ') GO TO 20 - 10 CONTINUE -C - 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) - ENDIF -C -C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. -C - IF (LKNTRL .NE. 0) THEN - CALL XERPRN (' * ', -1, ' ', 72) - CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) - CALL XERPRN (' ', 0, ' ', 72) - ENDIF -C -C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE -C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. -C - 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN -C -C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A -C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR -C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. -C - IF (LKNTRL.GT.0) THEN - IF (LEVEL .EQ. 1) THEN - CALL XERPRN - * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) - ELSE - CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) - ENDIF - CALL XERHLT (' ') - ENDIF - RETURN - END
--- a/libcruft/dassl/xerprn.f Mon Dec 01 00:01:01 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,225 +0,0 @@ -C*DECK XERPRN - SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) -C***BEGIN PROLOGUE XERPRN -C***SUBSIDIARY -C***PURPOSE This routine is called by XERMSG to print error messages -C***LIBRARY SLATEC -C***CATEGORY R3C -C***TYPE ALL -C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR -C***AUTHOR FONG, KIRBY, (NMFECC AT LLNL) -C***DESCRIPTION -C -C This routine sends one or more lines to each of the (up to five) -C logical units to which error messages are to be sent. This routine -C is called several times by XERMSG, sometimes with a single line to -C print and sometimes with a (potentially very long) message that may -C wrap around into multiple lines. -C -C PREFIX Input argument of type CHARACTER. This argument contains -C characters to be put at the beginning of each line before -C the body of the message. No more than 16 characters of -C PREFIX will be used. -C -C NPREF Input argument of type INTEGER. This argument is the number -C of characters to use from PREFIX. If it is negative, the -C intrinsic function LEN is used to determine its length. If -C it is zero, PREFIX is not used. If it exceeds 16 or if -C LEN(PREFIX) exceeds 16, only the first 16 characters will be -C used. If NPREF is positive and the length of PREFIX is less -C than NPREF, a copy of PREFIX extended with blanks to length -C NPREF will be used. -C -C MESSG Input argument of type CHARACTER. This is the text of a -C message to be printed. If it is a long message, it will be -C broken into pieces for printing on multiple lines. Each line -C will start with the appropriate prefix and be followed by a -C piece of the message. NWRAP is the number of characters per -C piece; that is, after each NWRAP characters, we break and -C start a new line. In addition the characters '$$' embedded -C in MESSG are a sentinel for a new line. The counting of -C characters up to NWRAP starts over for each new line. The -C value of NWRAP typically used by XERMSG is 72 since many -C older error messages in the SLATEC Library are laid out to -C rely on wrap-around every 72 characters. -C -C NWRAP Input argument of type INTEGER. This gives the maximum size -C piece into which to break MESSG for printing on multiple -C lines. An embedded '$$' ends a line, and the count restarts -C at the following character. If a line break does not occur -C on a blank (it would split a word) that word is moved to the -C next line. Values of NWRAP less than 16 will be treated as -C 16. Values of NWRAP greater than 132 will be treated as 132. -C The actual line length will be NPREF + NWRAP after NPREF has -C been adjusted to fall between 0 and 16 and NWRAP has been -C adjusted to fall between 16 and 132. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED I1MACH, XGETUA -C***REVISION HISTORY (YYMMDD) -C 880621 DATE WRITTEN -C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF -C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK -C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE -C SLASH CHARACTER IN FORMAT STATEMENTS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMMENS TO -C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK -C LINES TO BE PRINTED. -C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF -C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. -C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Added code to break messages between words. (RWC) -C***END PROLOGUE XERPRN - CHARACTER*(*) PREFIX, MESSG - INTEGER NPREF, NWRAP - CHARACTER*148 CBUFF - INTEGER IU(5), NUNIT - CHARACTER*2 NEWLIN - PARAMETER (NEWLIN = '$$') -C***FIRST EXECUTABLE STATEMENT XERPRN - CALL XGETUA(IU,NUNIT) -C -C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD -C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD -C ERROR MESSAGE UNIT. -C - N = I1MACH(4) - DO 10 I=1,NUNIT - IF (IU(I) .EQ. 0) IU(I) = N - 10 CONTINUE -C -C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE -C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING -C THE REST OF THIS ROUTINE. -C - IF ( NPREF .LT. 0 ) THEN - LPREF = LEN(PREFIX) - ELSE - LPREF = NPREF - ENDIF - LPREF = MIN(16, LPREF) - IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX -C -C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE -C TIME FROM MESSG TO PRINT ON ONE LINE. -C - LWRAP = MAX(16, MIN(132, NWRAP)) -C -C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. -C - LENMSG = LEN(MESSG) - N = LENMSG - DO 20 I=1,N - IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 - LENMSG = LENMSG - 1 - 20 CONTINUE - 30 CONTINUE -C -C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. -C - IF (LENMSG .EQ. 0) THEN - CBUFF(LPREF+1:LPREF+1) = ' ' - DO 40 I=1,NUNIT - WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) - 40 CONTINUE - RETURN - ENDIF -C -C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING -C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. -C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. -C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. -C -C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE -C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE -C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH -C OF THE SECOND ARGUMENT. -C -C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE -C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER -C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT -C POSITION NEXTC. -C -C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE -C REMAINDER OF THE CHARACTER STRING. LPIECE -C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, -C WHICHEVER IS LESS. -C -C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: -C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE -C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY -C BLANK LINES. THIS TAKES CARE OF THE SITUATION -C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF -C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE -C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC -C SHOULD BE INCREMENTED BY 2. -C -C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. -C -C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 -C RESET LPIECE = LPIECE-1. NOTE THAT THIS -C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. -C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY -C AT THE END OF A LINE. -C - NEXTC = 1 - 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) - IF (LPIECE .EQ. 0) THEN -C -C THERE WAS NO NEW LINE SENTINEL FOUND. -C - IDELTA = 0 - LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) - IF (LPIECE .LT. LENMSG+1-NEXTC) THEN - DO 52 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 54 - ENDIF - 52 CONTINUE - ENDIF - 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSEIF (LPIECE .EQ. 1) THEN -C -C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). -C DON'T PRINT A BLANK LINE. -C - NEXTC = NEXTC + 2 - GO TO 50 - ELSEIF (LPIECE .GT. LWRAP+1) THEN -C -C LPIECE SHOULD BE SET DOWN TO LWRAP. -C - IDELTA = 0 - LPIECE = LWRAP - DO 56 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 58 - ENDIF - 56 CONTINUE - 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSE -C -C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. -C WE SHOULD DECREMENT LPIECE BY ONE. -C - LPIECE = LPIECE - 1 - CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + 2 - ENDIF -C -C PRINT -C - DO 60 I=1,NUNIT - WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) - 60 CONTINUE -C - IF (NEXTC .LE. LENMSG) GO TO 50 - RETURN - END
--- a/libcruft/dassl/xgetua.f Mon Dec 01 00:01:01 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -C*DECK XGETUA - SUBROUTINE XGETUA (IUNITA, N) -C***BEGIN PROLOGUE XGETUA -C***PURPOSE Return unit number(s) to which error messages are being -C sent. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XGETUA-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR JONES, R. E., (SNLA) -C Modified by -C FRITSCH, F. N., (LLNL) -C***DESCRIPTION -C -C Abstract -C XGETUA may be called to determine the unit number or numbers -C to which error messages are being sent. -C These unit numbers may have been set by a call to XSETUN, -C or a call to XSETUA, or may be a default value. -C -C Description of Parameters -C --Output-- -C IUNIT - an array of one to five unit numbers, depending -C on the value of N. A value of zero refers to the -C default unit, as defined by the I1MACH machine -C constant routine. Only IUNIT(1),...,IUNIT(N) are -C defined by XGETUA. The values of IUNIT(N+1),..., -C IUNIT(5) are not defined (for N .LT. 5) or altered -C in any way by XGETUA. -C N - the number of units to which copies of the -C error messages are being sent. N will be in the -C range from 1 to 5. -C -C CAUTION: The use of COMMON in this version is not safe for -C multiprocessing. -C -C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- -C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, -C 1982. -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS XERUNI -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 901011 Rewritten to not use J4SAVE. (FNF) -C 901012 Corrected initialization problem. (FNF) -C***END PROLOGUE XGETUA - DIMENSION IUNITA(5) - INTEGER NUNIT, IUNIT(5) - COMMON /XERUNI/ NUNIT, IUNIT -C***FIRST EXECUTABLE STATEMENT XGETUA -C Initialize so XERMSG will use standard error unit number if -C block has not been set up by a CALL XSETUA. -C CAUTION: This assumes uninitialized COMMON tests .LE.0 . - IF (NUNIT.LE.0) THEN - NUNIT = 1 - IUNIT(1) = 0 - ENDIF - N = NUNIT - DO 30 I=1,N - IUNITA(I) = IUNIT(I) - 30 CONTINUE - RETURN - END
--- a/libcruft/dassl/xsetua.f Mon Dec 01 00:01:01 1997 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -C*DECK XSETUA - SUBROUTINE XSETUA (IUNITA, N) -C***BEGIN PROLOGUE XSETUA -C***PURPOSE Set logical unit numbers (up to 5) to which error -C messages are to be sent. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3B -C***TYPE ALL (XSETUA-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR JONES, R. E., (SNLA) -C Modified by -C FRITSCH, F. N., (LLNL) -C***DESCRIPTION -C -C Abstract -C XSETUA may be called to declare a list of up to five -C logical units, each of which is to receive a copy of -C each error message processed by this package. -C The purpose of XSETUA is to allow simultaneous printing -C of each error message on, say, a main output file, -C an interactive terminal, and other files such as graphics -C communication files. -C -C Description of Parameters -C --Input-- -C IUNIT - an array of up to five unit numbers. -C Normally these numbers should all be different -C (but duplicates are not prohibited.) -C N - the number of unit numbers provided in IUNIT -C must have 1 .LE. N .LE. 5. -C -C CAUTION: The use of COMMON in this version is not safe for -C multiprocessing. -C -C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- -C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, -C 1982. -C***ROUTINES CALLED XERMSG -C***COMMON BLOCKS XERUNI -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900510 Change call to XERRWV to XERMSG. (RWC) -C 901011 Rewritten to not use J4SAVE. (FNF) -C***END PROLOGUE XSETUA - DIMENSION IUNITA(5) - INTEGER NUNIT, IUNIT(5) - COMMON /XERUNI/ NUNIT, IUNIT - CHARACTER *8 XERN1 -C***FIRST EXECUTABLE STATEMENT XSETUA -C - IF (N.LT.1 .OR. N.GT.5) THEN - WRITE (XERN1, '(I8)') N - CALL XERMSG ('SLATEC', 'XSETUA', - * 'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2) - RETURN - ENDIF -C - DO 10 I=1,N - IUNIT(I) = IUNITA(I) - 10 CONTINUE - NUNIT = N - RETURN - END