xerprn.f

Go to the documentation of this file.
00001 *DECK XERPRN
00002       SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
00003 C***BEGIN PROLOGUE  XERPRN
00004 C***SUBSIDIARY
00005 C***PURPOSE  Print error messages processed by XERMSG.
00006 C***LIBRARY   SLATEC (XERROR)
00007 C***CATEGORY  R3C
00008 C***TYPE      ALL (XERPRN-A)
00009 C***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
00010 C***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
00011 C***DESCRIPTION
00012 C
00013 C This routine sends one or more lines to each of the (up to five)
00014 C logical units to which error messages are to be sent.  This routine
00015 C is called several times by XERMSG, sometimes with a single line to
00016 C print and sometimes with a (potentially very long) message that may
00017 C wrap around into multiple lines.
00018 C
00019 C PREFIX  Input argument of type CHARACTER.  This argument contains
00020 C         characters to be put at the beginning of each line before
00021 C         the body of the message.  No more than 16 characters of
00022 C         PREFIX will be used.
00023 C
00024 C NPREF   Input argument of type INTEGER.  This argument is the number
00025 C         of characters to use from PREFIX.  If it is negative, the
00026 C         intrinsic function LEN is used to determine its length.  If
00027 C         it is zero, PREFIX is not used.  If it exceeds 16 or if
00028 C         LEN(PREFIX) exceeds 16, only the first 16 characters will be
00029 C         used.  If NPREF is positive and the length of PREFIX is less
00030 C         than NPREF, a copy of PREFIX extended with blanks to length
00031 C         NPREF will be used.
00032 C
00033 C MESSG   Input argument of type CHARACTER.  This is the text of a
00034 C         message to be printed.  If it is a long message, it will be
00035 C         broken into pieces for printing on multiple lines.  Each line
00036 C         will start with the appropriate prefix and be followed by a
00037 C         piece of the message.  NWRAP is the number of characters per
00038 C         piece; that is, after each NWRAP characters, we break and
00039 C         start a new line.  In addition the characters '$$' embedded
00040 C         in MESSG are a sentinel for a new line.  The counting of
00041 C         characters up to NWRAP starts over for each new line.  The
00042 C         value of NWRAP typically used by XERMSG is 72 since many
00043 C         older error messages in the SLATEC Library are laid out to
00044 C         rely on wrap-around every 72 characters.
00045 C
00046 C NWRAP   Input argument of type INTEGER.  This gives the maximum size
00047 C         piece into which to break MESSG for printing on multiple
00048 C         lines.  An embedded '$$' ends a line, and the count restarts
00049 C         at the following character.  If a line break does not occur
00050 C         on a blank (it would split a word) that word is moved to the
00051 C         next line.  Values of NWRAP less than 16 will be treated as
00052 C         16.  Values of NWRAP greater than 132 will be treated as 132.
00053 C         The actual line length will be NPREF + NWRAP after NPREF has
00054 C         been adjusted to fall between 0 and 16 and NWRAP has been
00055 C         adjusted to fall between 16 and 132.
00056 C
00057 C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
00058 C                 Error-handling Package, SAND82-0800, Sandia
00059 C                 Laboratories, 1982.
00060 C***ROUTINES CALLED  I1MACH, XGETUA
00061 C***REVISION HISTORY  (YYMMDD)
00062 C   880621  DATE WRITTEN
00063 C   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
00064 C           JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
00065 C           THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
00066 C           SLASH CHARACTER IN FORMAT STATEMENTS.
00067 C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
00068 C           STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
00069 C           LINES TO BE PRINTED.
00070 C   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
00071 C           CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
00072 C   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
00073 C   891214  Prologue converted to Version 4.0 format.  (WRB)
00074 C   900510  Added code to break messages between words.  (RWC)
00075 C   920501  Reformatted the REFERENCES section.  (WRB)
00076 C***END PROLOGUE  XERPRN
00077       CHARACTER*(*) PREFIX, MESSG
00078       INTEGER NPREF, NWRAP
00079       CHARACTER*148 CBUFF
00080       INTEGER IU(5), NUNIT
00081       CHARACTER*2 NEWLIN
00082       PARAMETER (NEWLIN = '$$')
00083 C***FIRST EXECUTABLE STATEMENT  XERPRN
00084       CALL XGETUA(IU,NUNIT)
00085 C
00086 C       A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
00087 C       ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
00088 C       ERROR MESSAGE UNIT.
00089 C
00090       N = I1MACH(4)
00091       DO 10 I=1,NUNIT
00092          IF (IU(I) .EQ. 0) IU(I) = N
00093    10 CONTINUE
00094 C
00095 C       LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
00096 C       BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
00097 C       THE REST OF THIS ROUTINE.
00098 C
00099       IF ( NPREF .LT. 0 ) THEN
00100          LPREF = LEN(PREFIX)
00101       ELSE
00102          LPREF = NPREF
00103       ENDIF
00104       LPREF = MIN(16, LPREF)
00105       IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX
00106 C
00107 C       LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
00108 C       TIME FROM MESSG TO PRINT ON ONE LINE.
00109 C
00110       LWRAP = MAX(16, MIN(132, NWRAP))
00111 C
00112 C       SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
00113 C
00114       LENMSG = LEN(MESSG)
00115       N = LENMSG
00116       DO 20 I=1,N
00117          IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30
00118          LENMSG = LENMSG - 1
00119    20 CONTINUE
00120    30 CONTINUE
00121 C
00122 C       IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
00123 C
00124       IF (LENMSG .EQ. 0) THEN
00125          CBUFF(LPREF+1:LPREF+1) = ' '
00126          DO 40 I=1,NUNIT
00127             WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
00128    40    CONTINUE
00129          RETURN
00130       ENDIF
00131 C
00132 C       SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
00133 C       STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
00134 C       WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
00135 C       WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
00136 C
00137 C       WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
00138 C       INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
00139 C       OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
00140 C       OF THE SECOND ARGUMENT.
00141 C
00142 C       THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
00143 C       FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
00144 C       OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
00145 C       POSITION NEXTC.
00146 C
00147 C       LPIECE .EQ. 0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
00148 C                       REMAINDER OF THE CHARACTER STRING.  LPIECE
00149 C                       SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
00150 C                       WHICHEVER IS LESS.
00151 C
00152 C       LPIECE .EQ. 1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
00153 C                       NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
00154 C                       PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
00155 C                       BLANK LINES.  THIS TAKES CARE OF THE SITUATION
00156 C                       WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
00157 C                       EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
00158 C                       SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
00159 C                       SHOULD BE INCREMENTED BY 2.
00160 C
00161 C       LPIECE .GT. LWRAP+1  REDUCE LPIECE TO LWRAP.
00162 C
00163 C       ELSE            THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
00164 C                       RESET LPIECE = LPIECE-1.  NOTE THAT THIS
00165 C                       PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
00166 C                       LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
00167 C                       AT THE END OF A LINE.
00168 C
00169       NEXTC = 1
00170    50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
00171       IF (LPIECE .EQ. 0) THEN
00172 C
00173 C       THERE WAS NO NEW LINE SENTINEL FOUND.
00174 C
00175          IDELTA = 0
00176          LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
00177          IF (LPIECE .LT. LENMSG+1-NEXTC) THEN
00178             DO 52 I=LPIECE+1,2,-1
00179                IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
00180                   LPIECE = I-1
00181                   IDELTA = 1
00182                   GOTO 54
00183                ENDIF
00184    52       CONTINUE
00185          ENDIF
00186    54    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
00187          NEXTC = NEXTC + LPIECE + IDELTA
00188       ELSEIF (LPIECE .EQ. 1) THEN
00189 C
00190 C       WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
00191 C       DON'T PRINT A BLANK LINE.
00192 C
00193          NEXTC = NEXTC + 2
00194          GO TO 50
00195       ELSEIF (LPIECE .GT. LWRAP+1) THEN
00196 C
00197 C       LPIECE SHOULD BE SET DOWN TO LWRAP.
00198 C
00199          IDELTA = 0
00200          LPIECE = LWRAP
00201          DO 56 I=LPIECE+1,2,-1
00202             IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
00203                LPIECE = I-1
00204                IDELTA = 1
00205                GOTO 58
00206             ENDIF
00207    56    CONTINUE
00208    58    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
00209          NEXTC = NEXTC + LPIECE + IDELTA
00210       ELSE
00211 C
00212 C       IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
00213 C       WE SHOULD DECREMENT LPIECE BY ONE.
00214 C
00215          LPIECE = LPIECE - 1
00216          CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
00217          NEXTC  = NEXTC + LPIECE + 2
00218       ENDIF
00219 C
00220 C       PRINT
00221 C
00222       DO 60 I=1,NUNIT
00223          WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
00224    60 CONTINUE
00225 C
00226       IF (NEXTC .LE. LENMSG) GO TO 50
00227       RETURN
00228       END
 All Classes Files Functions Variables Typedefs Enumerations Enumerator Friends Defines