source: LMDZ6/branches/Ocean_skin/libf/misc/xerprn.F @ 5422

Last change on this file since 5422 was 2197, checked in by Ehouarn Millour, 10 years ago

Added 'implicit none' statements and proper variable definitions where they were missing.
EM

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