src/numerical/slatec/fortran/xerprn.f

   1 *DECK XERPRN
   2       SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
   3 C***BEGIN PROLOGUE  XERPRN
   4 C***SUBSIDIARY
   5 C***PURPOSE  Print error messages processed by XERMSG.
   6 C***LIBRARY   SLATEC (XERROR)
   7 C***CATEGORY  R3C
   8 C***TYPE      ALL (XERPRN-A)
   9 C***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
  10 C***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
  11 C***DESCRIPTION
  12 C
  13 C This routine sends one or more lines to each of the (up to five)
  14 C logical units to which error messages are to be sent.  This routine
  15 C is called several times by XERMSG, sometimes with a single line to
  16 C print and sometimes with a (potentially very long) message that may
  17 C wrap around into multiple lines.
  18 C
  19 C PREFIX  Input argument of type CHARACTER.  This argument contains
  20 C         characters to be put at the beginning of each line before
  21 C         the body of the message.  No more than 16 characters of
  22 C         PREFIX will be used.
  23 C
  24 C NPREF   Input argument of type INTEGER.  This argument is the number
  25 C         of characters to use from PREFIX.  If it is negative, the
  26 C         intrinsic function LEN is used to determine its length.  If
  27 C         it is zero, PREFIX is not used.  If it exceeds 16 or if
  28 C         LEN(PREFIX) exceeds 16, only the first 16 characters will be
  29 C         used.  If NPREF is positive and the length of PREFIX is less
  30 C         than NPREF, a copy of PREFIX extended with blanks to length
  31 C         NPREF will be used.
  32 C
  33 C MESSG   Input argument of type CHARACTER.  This is the text of a
  34 C         message to be printed.  If it is a long message, it will be
  35 C         broken into pieces for printing on multiple lines.  Each line
  36 C         will start with the appropriate prefix and be followed by a
  37 C         piece of the message.  NWRAP is the number of characters per
  38 C         piece; that is, after each NWRAP characters, we break and
  39 C         start a new line.  In addition the characters '$$' embedded
  40 C         in MESSG are a sentinel for a new line.  The counting of
  41 C         characters up to NWRAP starts over for each new line.  The
  42 C         value of NWRAP typically used by XERMSG is 72 since many
  43 C         older error messages in the SLATEC Library are laid out to
  44 C         rely on wrap-around every 72 characters.
  45 C
  46 C NWRAP   Input argument of type INTEGER.  This gives the maximum size
  47 C         piece into which to break MESSG for printing on multiple
  48 C         lines.  An embedded '$$' ends a line, and the count restarts
  49 C         at the following character.  If a line break does not occur
  50 C         on a blank (it would split a word) that word is moved to the
  51 C         next line.  Values of NWRAP less than 16 will be treated as
  52 C         16.  Values of NWRAP greater than 132 will be treated as 132.
  53 C         The actual line length will be NPREF + NWRAP after NPREF has
  54 C         been adjusted to fall between 0 and 16 and NWRAP has been
  55 C         adjusted to fall between 16 and 132.
  56 C
  57 C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
  58 C                 Error-handling Package, SAND82-0800, Sandia
  59 C                 Laboratories, 1982.
  60 C***ROUTINES CALLED  I1MACH, XGETUA
  61 C***REVISION HISTORY  (YYMMDD)
  62 C   880621  DATE WRITTEN
  63 C   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
  64 C           JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
  65 C           THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
  66 C           SLASH CHARACTER IN FORMAT STATEMENTS.
  67 C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
  68 C           STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
  69 C           LINES TO BE PRINTED.
  70 C   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
  71 C           CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
  72 C   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
  73 C   891214  Prologue converted to Version 4.0 format.  (WRB)
  74 C   900510  Added code to break messages between words.  (RWC)
  75 C   920501  Reformatted the REFERENCES section.  (WRB)
  76 C***END PROLOGUE  XERPRN
  77       CHARACTER*(*) PREFIX, MESSG
  78       INTEGER NPREF, NWRAP
  79       CHARACTER*148 CBUFF
  80       INTEGER IU(5), NUNIT
  81       CHARACTER*2 NEWLIN
  82       PARAMETER (NEWLIN = '$$')
  83 C***FIRST EXECUTABLE STATEMENT  XERPRN
  84       CALL XGETUA(IU,NUNIT)
  85 C
  86 C       A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
  87 C       ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
  88 C       ERROR MESSAGE UNIT.
  89 C
  90       N = I1MACH(4)
  91       DO 10 I=1,NUNIT
  92          IF (IU(I) .EQ. 0) IU(I) = N
  93    10 CONTINUE
  94 C
  95 C       LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
  96 C       BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
  97 C       THE REST OF THIS ROUTINE.
  98 C
  99       IF ( NPREF .LT. 0 ) THEN
 100          LPREF = LEN(PREFIX)
 101       ELSE
 102          LPREF = NPREF
 103       ENDIF
 104       LPREF = MIN(16, LPREF)
 105       IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX
 106 C
 107 C       LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
 108 C       TIME FROM MESSG TO PRINT ON ONE LINE.
 109 C
 110       LWRAP = MAX(16, MIN(132, NWRAP))
 111 C
 112 C       SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
 113 C
 114       LENMSG = LEN(MESSG)
 115       N = LENMSG
 116       DO 20 I=1,N
 117          IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30
 118          LENMSG = LENMSG - 1
 119    20 CONTINUE
 120    30 CONTINUE
 121 C
 122 C       IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
 123 C
 124       IF (LENMSG .EQ. 0) THEN
 125          CBUFF(LPREF+1:LPREF+1) = ' '
 126          DO 40 I=1,NUNIT
 127             WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
 128    40    CONTINUE
 129          RETURN
 130       ENDIF
 131 C
 132 C       SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
 133 C       STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
 134 C       WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
 135 C       WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
 136 C
 137 C       WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
 138 C       INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
 139 C       OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
 140 C       OF THE SECOND ARGUMENT.
 141 C
 142 C       THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
 143 C       FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
 144 C       OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
 145 C       POSITION NEXTC.
 146 C
 147 C       LPIECE .EQ. 0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
 148 C                       REMAINDER OF THE CHARACTER STRING.  LPIECE
 149 C                       SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
 150 C                       WHICHEVER IS LESS.
 151 C
 152 C       LPIECE .EQ. 1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
 153 C                       NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
 154 C                       PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
 155 C                       BLANK LINES.  THIS TAKES CARE OF THE SITUATION
 156 C                       WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
 157 C                       EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
 158 C                       SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
 159 C                       SHOULD BE INCREMENTED BY 2.
 160 C
 161 C       LPIECE .GT. LWRAP+1  REDUCE LPIECE TO LWRAP.
 162 C
 163 C       ELSE            THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
 164 C                       RESET LPIECE = LPIECE-1.  NOTE THAT THIS
 165 C                       PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
 166 C                       LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
 167 C                       AT THE END OF A LINE.
 168 C
 169       NEXTC = 1
 170    50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
 171       IF (LPIECE .EQ. 0) THEN
 172 C
 173 C       THERE WAS NO NEW LINE SENTINEL FOUND.
 174 C
 175          IDELTA = 0
 176          LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
 177          IF (LPIECE .LT. LENMSG+1-NEXTC) THEN
 178             DO 52 I=LPIECE+1,2,-1
 179                IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
 180                   LPIECE = I-1
 181                   IDELTA = 1
 182                   GOTO 54
 183                ENDIF
 184    52       CONTINUE
 185          ENDIF
 186    54    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
 187          NEXTC = NEXTC + LPIECE + IDELTA
 188       ELSEIF (LPIECE .EQ. 1) THEN
 189 C
 190 C       WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
 191 C       DON'T PRINT A BLANK LINE.
 192 C
 193          NEXTC = NEXTC + 2
 194          GO TO 50
 195       ELSEIF (LPIECE .GT. LWRAP+1) THEN
 196 C
 197 C       LPIECE SHOULD BE SET DOWN TO LWRAP.
 198 C
 199          IDELTA = 0
 200          LPIECE = LWRAP
 201          DO 56 I=LPIECE+1,2,-1
 202             IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
 203                LPIECE = I-1
 204                IDELTA = 1
 205                GOTO 58
 206             ENDIF
 207    56    CONTINUE
 208    58    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
 209          NEXTC = NEXTC + LPIECE + IDELTA
 210       ELSE
 211 C
 212 C       IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
 213 C       WE SHOULD DECREMENT LPIECE BY ONE.
 214 C
 215          LPIECE = LPIECE - 1
 216          CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
 217          NEXTC  = NEXTC + LPIECE + 2
 218       ENDIF
 219 C
 220 C       PRINT
 221 C
 222       DO 60 I=1,NUNIT
 223          WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
 224    60 CONTINUE
 225 C
 226       IF (NEXTC .LE. LENMSG) GO TO 50
 227       RETURN
 228       END