Context Navigation

lmdz_xer.f90 @ 5185

Last change on this file since 5185 was 5159, checked in by abarral, 5 months ago
Put dimensions.h and paramet.h into modules
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: 43.6 KB

Line
1	! Contains "legacy" xer* functions required by some other very old external code
2
3	! Amaury (07/24) WTF ??? We have 1000+ lines of code JUST to allow calling xermsg to print some error message !!??
4	! Get rid of this 🤢
5
6	MODULE lmdz_xer
7	IMPLICIT NONE; PRIVATE
8	PUBLIC xermsg
9	CONTAINS
10
11	!DECK XERMSG
12	SUBROUTINE XERMSG(LIBRAR, SUBROU, MESSG, NERR, LEVEL)
13	IMPLICIT NONE
14	!***BEGIN PROLOGUE XERMSG
15	!***PURPOSE Process error messages for SLATEC and other libraries.
16	!***LIBRARY SLATEC (XERROR)
17	!***CATEGORY R3C
18	!***TYPE ALL (XERMSG-A)
19	!***KEYWORDS ERROR MESSAGE, XERROR
20	!***AUTHOR Fong, Kirby, (NMFECC at LLNL)
21	!***DESCRIPTION
22
23	! XERMSG processes a diagnostic message in a manner determined by the
24	! value of LEVEL and the current value of the library error control
25	! flag, KONTRL. See SUBROUTINE XSETF for details.
26
27	! LIBRAR A character constant (or character variable) with the name
28	! of the library. This will be 'SLATEC' for the SLATEC
29	! Common Math Library. The error handling package is
30	! general enough to be used by many libraries
31	! simultaneously, so it is desirable for the routine that
32	! detects and reports an error to identify the library name
33	! as well as the routine name.
34
35	! SUBROU A character constant (or character variable) with the name
36	! of the routine that detected the error. Usually it is the
37	! name of the routine that is calling XERMSG. There are
38	! some instances where a user callable library routine calls
39	! lower level subsidiary routines where the error is
40	! detected. In such cases it may be more informative to
41	! supply the name of the routine the user called rather than
42	! the name of the subsidiary routine that detected the
43	! error.
44
45	! MESSG A character constant (or character variable) with the text
46	! of the error or warning message. In the example below,
47	! the message is a character constant that contains a
48	! generic message.
49
50	! CALL XERMSG ('SLATEC', 'MMPY',
51	! *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
52	! *3, 1)
53
54	! It is possible (and is sometimes desirable) to generate a
55	! specific message--e.g., one that contains actual numeric
56	! values. Specific numeric values can be converted into
57	! character strings using formatted WRITE statements into
58	! character variables. This is called standard Fortran
59	! internal file I/O and is exemplified in the first three
60	! lines of the following example. You can also catenate
61	! substrings of characters to construct the error message.
62	! Here is an example showing the use of both writing to
63	! an internal file and catenating character strings.
64
65	! CHARACTER*5 CHARN, CHARL
66	! WRITE (CHARN,10) N
67	! WRITE (CHARL,10) LDA
68	! 10 FORMAT(I5)
69	! CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
70	! * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
71	! * CHARL, 3, 1)
72
73	! There are two subtleties worth mentioning. One is that
74	! the // for character catenation is used to construct the
75	! error message so that no single character constant is
76	! continued to the next line. This avoids confusion as to
77	! whether there are trailing blanks at the end of the line.
78	! The second is that by catenating the parts of the message
79	! as an actual argument rather than encoding the entire
80	! message into one large character variable, we avoid
81	! having to know how long the message will be in order to
82	! declare an adequate length for that large character
83	! variable. XERMSG calls XERPRN to print the message using
84	! multiple lines if necessary. If the message is very long,
85	! XERPRN will break it into pieces of 72 characters (as
86	! requested by XERMSG) for printing on multiple lines.
87	! Also, XERMSG asks XERPRN to prefix each line with ' * '
88	! so that the total line length could be 76 characters.
89	! Note also that XERPRN scans the error message backwards
90	! to ignore trailing blanks. Another feature is that
91	! the substring '$$' is treated as a new line sentinel
92	! by XERPRN. If you want to construct a multiline
93	! message without having to count out multiples of 72
94	! characters, just use '$$' as a separator. '$$'
95	! obviously must occur within 72 characters of the
96	! start of each line to have its intended effect since
97	! XERPRN is asked to wrap around at 72 characters in
98	! addition to looking for '$$'.
99
100	! NERR An integer value that is chosen by the library routine's
101	! author. It must be in the range -99 to 999 (three
102	! printable digits). Each distinct error should have its
103	! own error number. These error numbers should be described
104	! in the machine readable documentation for the routine.
105	! The error numbers need be unique only within each routine,
106	! so it is reasonable for each routine to start enumerating
107	! errors from 1 and proceeding to the next integer.
108
109	! LEVEL An integer value in the range 0 to 2 that indicates the
110	! level (severity) of the error. Their meanings are
111
112	! -1 A warning message. This is used if it is not clear
113	! that there really is an error, but the user's attention
114	! may be needed. An attempt is made to only print this
115	! message once.
116
117	! 0 A warning message. This is used if it is not clear
118	! that there really is an error, but the user's attention
119	! may be needed.
120
121	! 1 A recoverable error. This is used even if the error is
122	! so serious that the routine cannot return any useful
123	! answer. If the user has told the error package to
124	! return after recoverable errors, then XERMSG will
125	! return to the Library routine which can then return to
126	! the user's routine. The user may also permit the error
127	! package to terminate the program upon encountering a
128	! recoverable error.
129
130	! 2 A fatal error. XERMSG will not return to its caller
131	! after it receives a fatal error. This level should
132	! hardly ever be used; it is much better to allow the
133	! user a chance to recover. An example of one of the few
134	! cases in which it is permissible to declare a level 2
135	! error is a reverse communication Library routine that
136	! is likely to be called repeatedly until it integrates
137	! across some interval. If there is a serious error in
138	! the input such that another step cannot be taken and
139	! the Library routine is called again without the input
140	! error having been corrected by the caller, the Library
141	! routine will probably be called forever with improper
142	! input. In this case, it is reasonable to declare the
143	! error to be fatal.
144
145	! Each of the arguments to XERMSG is input; none will be modified by
146	! XERMSG. A routine may make multiple calls to XERMSG with warning
147	! level messages; however, after a CALL to XERMSG with a recoverable
148	! error, the routine should return to the user. Do not try to call
149	! XERMSG with a second recoverable error after the first recoverable
150	! error because the error package saves the error number. The user
151	! can retrieve this error number by calling another entry point in
152	! the error handling package and then clear the error number when
153	! recovering from the error. Calling XERMSG in succession causes the
154	! old error number to be overwritten by the latest error number.
155	! This is considered harmless for error numbers associated with
156	! warning messages but must not be done for error numbers of serious
157	! errors. After a CALL to XERMSG with a recoverable error, the user
158	! must be given a chance to CALL NUMXER or XERCLR to retrieve or
159	! clear the error number.
160	!***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
161	! Error-handling Package, SAND82-0800, Sandia
162	! Laboratories, 1982.
163	!***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE
164	!***REVISION HISTORY (YYMMDD)
165	! 880101 DATE WRITTEN
166	! 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
167	! THERE ARE TWO BASIC CHANGES.
168	! 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
169	! PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES
170	! INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS
171	! ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE
172	! ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER
173	! ' **' OR ' ' AND LONG MESSAGES ARE BROKEN EVERY
174	! 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
175	! LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
176	! 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
177	! FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
178	! OF LOWER CASE.
179	! 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
180	! THE PRINCIPAL CHANGES ARE
181	! 1. CLARIFY COMMENTS IN THE PROLOGUES
182	! 2. RENAME XRPRNT TO XERPRN
183	! 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
184	! SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
185	! CHARACTER FOR NEW RECORDS.
186	! 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
187	! CLEAN UP THE CODING.
188	! 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
189	! PREFIX.
190	! 891013 REVISED TO CORRECT COMMENTS.
191	! 891214 Prologue converted to Version 4.0 format. (WRB)
192	! 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but
193	! NERR .NE. 0, and on LEVEL to be -2 < LEVEL < 3. Added
194	! LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
195	! XERCTL to XERCNT. (RWC)
196	! 920501 Reformatted the REFERENCES section. (WRB)
197	!***END PROLOGUE XERMSG
198	CHARACTER(len = *) :: LIBRAR, SUBROU, MESSG
199	CHARACTER(len = 8) :: XLIBR, XSUBR
200	CHARACTER(len = 72) :: TEMP
201	CHARACTER(len = 20) :: LFIRST
202	INTEGER :: NERR, LEVEL, LKNTRL
203	INTEGER :: MAXMES, KDUMMY, I, KOUNT, LERR, LLEVEL
204	INTEGER :: MKNTRL, LTEMP
205	!***FIRST EXECUTABLE STATEMENT XERMSG
206	LKNTRL = J4SAVE (2, 0, .FALSE.)
207	MAXMES = J4SAVE (4, 0, .FALSE.)
208
209	! LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL.
210	! MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE
211	! SHOULD BE PRINTED.
212
213	! WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
214	! CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE,
215	! AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
216
217	IF (NERR<-9999999 .OR. NERR>99999999 .OR. NERR==0 .OR. &
218	LEVEL<-1 .OR. LEVEL>2) THEN
219	CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // &
220	'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ ' // &
221	'JOB ABORT DUE TO FATAL ERROR.', 72)
222	CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY)
223	CALL XERHLT (' ***XERMSG -- INVALID INPUT')
224	RETURN
225	ENDIF
226
227	! RECORD THE MESSAGE.
228
229	I = J4SAVE (1, NERR, .TRUE.)
230	CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT)
231
232	! HANDLE PRINT-ONCE WARNING MESSAGES.
233
234	IF (LEVEL==-1 .AND. KOUNT>1) RETURN
235
236	! ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG.
237
238	XLIBR = LIBRAR
239	XSUBR = SUBROU
240	LFIRST = MESSG
241	LERR = NERR
242	LLEVEL = LEVEL
243	CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL)
244
245	LKNTRL = MAX(-2, MIN(2, LKNTRL))
246	MKNTRL = ABS(LKNTRL)
247
248	! SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS
249	! ZERO AND THE ERROR IS NOT FATAL.
250
251	IF (LEVEL<2 .AND. LKNTRL==0) GO TO 30
252	IF (LEVEL==0 .AND. KOUNT>MAXMES) GO TO 30
253	IF (LEVEL==1 .AND. KOUNT>MAXMES .AND. MKNTRL==1) GO TO 30
254	IF (LEVEL==2 .AND. KOUNT>MAX(1, MAXMES)) GO TO 30
255
256	! ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
257	! MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
258	! AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG
259	! IS NOT ZERO.
260
261	IF (LKNTRL /= 0) THEN
262	TEMP(1:21) = 'MESSAGE FROM ROUTINE '
263	I = MIN(LEN(SUBROU), 16)
264	TEMP(22:21 + I) = SUBROU(1:I)
265	TEMP(22 + I:33 + I) = ' IN LIBRARY '
266	LTEMP = 33 + I
267	I = MIN(LEN(LIBRAR), 16)
268	TEMP(LTEMP + 1:LTEMP + I) = LIBRAR (1:I)
269	TEMP(LTEMP + I + 1:LTEMP + I + 1) = '.'
270	LTEMP = LTEMP + I + 1
271	CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
272	ENDIF
273
274	! IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
275	! PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE
276	! FROM EACH OF THE FOLLOWING THREE OPTIONS.
277	! 1. LEVEL OF THE MESSAGE
278	! 'INFORMATIVE MESSAGE'
279	! 'POTENTIALLY RECOVERABLE ERROR'
280	! 'FATAL ERROR'
281	! 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
282	! 'PROG CONTINUES'
283	! 'PROG ABORTED'
284	! 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK
285	! MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS
286	! WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.)
287	! 'TRACEBACK REQUESTED'
288	! 'TRACEBACK NOT REQUESTED'
289	! NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
290	! EXCEED 74 CHARACTERS.
291	! WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED.
292
293	IF (LKNTRL > 0) THEN
294
295	! THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
296
297	IF (LEVEL <= 0) THEN
298	TEMP(1:20) = 'INFORMATIVE MESSAGE,'
299	LTEMP = 20
300	ELSEIF (LEVEL == 1) THEN
301	TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
302	LTEMP = 30
303	ELSE
304	TEMP(1:12) = 'FATAL ERROR,'
305	LTEMP = 12
306	ENDIF
307
308	! THEN WHETHER THE PROGRAM WILL CONTINUE.
309
310	IF ((MKNTRL==2 .AND. LEVEL>=1) .OR. &
311	(MKNTRL==1 .AND. LEVEL==2)) THEN
312	TEMP(LTEMP + 1:LTEMP + 14) = ' PROG ABORTED,'
313	LTEMP = LTEMP + 14
314	ELSE
315	TEMP(LTEMP + 1:LTEMP + 16) = ' PROG CONTINUES,'
316	LTEMP = LTEMP + 16
317	ENDIF
318
319	! FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK.
320
321	IF (LKNTRL > 0) THEN
322	TEMP(LTEMP + 1:LTEMP + 20) = ' TRACEBACK REQUESTED'
323	LTEMP = LTEMP + 20
324	ELSE
325	TEMP(LTEMP + 1:LTEMP + 24) = ' TRACEBACK NOT REQUESTED'
326	LTEMP = LTEMP + 24
327	ENDIF
328	CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
329	ENDIF
330
331	! NOW SEND OUT THE MESSAGE.
332
333	CALL XERPRN (' * ', -1, MESSG, 72)
334
335	! IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A
336	! TRACEBACK.
337
338	IF (LKNTRL > 0) THEN
339	WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
340	DO I = 16, 22
341	IF (TEMP(I:I) /= ' ') GO TO 20
342	END DO
343
344	20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72)
345	ENDIF
346
347	! IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
348
349	IF (LKNTRL /= 0) THEN
350	CALL XERPRN (' * ', -1, ' ', 72)
351	CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72)
352	CALL XERPRN (' ', 0, ' ', 72)
353	ENDIF
354
355	! IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
356	! CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
357
358	30 IF (LEVEL<=0 .OR. (LEVEL==1 .AND. MKNTRL<=1)) RETURN
359
360	! THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
361	! FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR
362	! SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
363
364	IF (LKNTRL>0 .AND. KOUNT<MAX(1, MAXMES)) THEN
365	IF (LEVEL == 1) THEN
366	CALL XERPRN &
367	(' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
368	ELSE
369	CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72)
370	ENDIF
371	CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY)
372	CALL XERHLT (' ')
373	ELSE
374	CALL XERHLT (MESSG)
375	ENDIF
376
377	END SUBROUTINE XERMSG
378
379	!DECK I1MACH
380	INTEGER FUNCTION I1MACH(I)
381	IMPLICIT NONE
382	!***BEGIN PROLOGUE I1MACH
383	!***PURPOSE Return integer machine dependent constants.
384	!***LIBRARY SLATEC
385	!***CATEGORY R1
386	!***TYPE INTEGER (I1MACH-I)
387	!***KEYWORDS MACHINE CONSTANTS
388	!***AUTHOR Fox, P. A., (Bell Labs)
389	! Hall, A. D., (Bell Labs)
390	! Schryer, N. L., (Bell Labs)
391	!***DESCRIPTION
392
393	! I1MACH can be used to obtain machine-dependent parameters for the
394	! local machine environment. It is a function subprogram with one
395	! (input) argument and can be referenced as follows:
396
397	! K = I1MACH(I)
398
399	! where I=1,...,16. The (output) value of K above is determined by
400	! the (input) value of I. The results for various values of I are
401	! discussed below.
402
403	! I/O unit numbers:
404	! I1MACH( 1) = the standard input unit.
405	! I1MACH( 2) = the standard output unit.
406	! I1MACH( 3) = the standard punch unit.
407	! I1MACH( 4) = the standard error message unit.
408
409	! Words:
410	! I1MACH( 5) = the number of bits per integer storage unit.
411	! I1MACH( 6) = the number of characters per integer storage unit.
412
413	! Integers:
414	! assume integers are represented in the S-digit, base-A form
415
416	! sign ( X(S-1)A(S-1) + ... + X(1)A + X(0) )
417
418	! where 0 .LE. X(I) .LT. A for I=0,...,S-1.
419	! I1MACH( 7) = A, the base.
420	! I1MACH( 8) = S, the number of base-A digits.
421	! I1MACH( 9) = A**S - 1, the largest magnitude.
422
423	! Floating-Point Numbers:
424	! Assume floating-point numbers are represented in the T-digit,
425	! base-B form
426	! sign (B*E)( (X(1)/B) + ... + (X(T)/B**T) )
427
428	! where 0 .LE. X(I) .LT. B for I=1,...,T,
429	! 0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
430	! I1MACH(10) = B, the base.
431
432	! Single-Precision:
433	! I1MACH(11) = T, the number of base-B digits.
434	! I1MACH(12) = EMIN, the smallest exponent E.
435	! I1MACH(13) = EMAX, the largest exponent E.
436
437	! Double-Precision:
438	! I1MACH(14) = T, the number of base-B digits.
439	! I1MACH(15) = EMIN, the smallest exponent E.
440	! I1MACH(16) = EMAX, the largest exponent E.
441
442	! To alter this function for a particular environment, the desired
443	! set of DATA statements should be activated by removing the C from
444	! column 1. Also, the values of I1MACH(1) - I1MACH(4) should be
445	! checked for consistency with the local operating system.
446
447	!***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
448	! a portable library, ACM Transactions on Mathematical
449	! Software 4, 2 (June 1978), pp. 177-188.
450	!***ROUTINES CALLED (NONE)
451	!***REVISION HISTORY (YYMMDD)
452	! 750101 DATE WRITTEN
453	! 891012 Added VAX G-floating constants. (WRB)
454	! 891012 REVISION DATE from Version 3.2
455	! 891214 Prologue converted to Version 4.0 format. (BAB)
456	! 900618 Added DEC RISC constants. (WRB)
457	! 900723 Added IBM RS 6000 constants. (WRB)
458	! 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16.
459	! (RWC)
460	! 910710 Added HP 730 constants. (SMR)
461	! 911114 Added Convex IEEE constants. (WRB)
462	! 920121 Added SUN -r8 compiler option constants. (WRB)
463	! 920229 Added Touchstone Delta i860 constants. (WRB)
464	! 920501 Reformatted the REFERENCES section. (WRB)
465	! 920625 Added Convex -p8 and -pd8 compiler option constants.
466	! (BKS, WRB)
467	! 930201 Added DEC Alpha and SGI constants. (RWC and WRB)
468	! 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler
469	! options. (DWL, RWC and WRB).
470	! 100623 Use Fortran 95 intrinsic functions (Lionel GUEZ)
471	!***END PROLOGUE I1MACH
472
473	INTEGER :: IMACH(16), OUTPUT
474	SAVE IMACH
475	EQUIVALENCE (IMACH(4), OUTPUT)
476	INTEGER :: I
477	!***FIRST EXECUTABLE STATEMENT I1MACH
478	IMACH(1) = 5
479	IMACH(2) = 6
480	IMACH(3) = 6
481	IMACH(4) = 6
482	IMACH(5) = bit_size(0)
483	IMACH(6) = IMACH(5) / 8
484	IMACH(7) = radix(0)
485	IMACH(8) = digits(0)
486	IMACH(9) = huge(0)
487	IMACH(10) = radix(0.)
488	IMACH(11) = digits(0.)
489	IMACH(12) = minexponent(0.)
490	IMACH(13) = maxexponent(0.)
491	IMACH(14) = digits(0d0)
492	IMACH(15) = minexponent(0d0)
493	IMACH(16) = maxexponent(0d0)
494	IF (I < 1 .OR. I > 16) GO TO 10
495
496	I1MACH = IMACH(I)
497	RETURN
498
499	10 CONTINUE
500	WRITE (UNIT = OUTPUT, FMT = 9000)
501	9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS')
502
503	! CALL FDUMP
504
505	STOP
506	END FUNCTION I1MACH
507
508	!DECK XGETUA
509	SUBROUTINE XGETUA(IUNITA, N)
510	IMPLICIT NONE
511	!***BEGIN PROLOGUE XGETUA
512	!***PURPOSE Return unit number(s) to which error messages are being
513	! sent.
514	!***LIBRARY SLATEC (XERROR)
515	!***CATEGORY R3C
516	!***TYPE ALL (XGETUA-A)
517	!***KEYWORDS ERROR, XERROR
518	!***AUTHOR Jones, R. E., (SNLA)
519	!***DESCRIPTION
520
521	! Abstract
522	! XGETUA may be called to determine the unit number or numbers
523	! to which error messages are being sent.
524	! These unit numbers may have been set by a CALL to XSETUN,
525	! or a CALL to XSETUA, or may be a default value.
526
527	! Description of Parameters
528	! --Output--
529	! IUNIT - an array of one to five unit numbers, depending
530	! on the value of N. A value of zero refers to the
531	! default unit, as defined by the I1MACH machine
532	! constant routine. Only IUNIT(1),...,IUNIT(N) are
533	! defined by XGETUA. The values of IUNIT(N+1),...,
534	! IUNIT(5) are not defined (for N .LT. 5) or altered
535	! in any way by XGETUA.
536	! N - the number of units to which copies of the
537	! error messages are being sent. N will be in the
538	! range from 1 to 5.
539
540	!***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
541	! Error-handling Package, SAND82-0800, Sandia
542	! Laboratories, 1982.
543	!***ROUTINES CALLED J4SAVE
544	!***REVISION HISTORY (YYMMDD)
545	! 790801 DATE WRITTEN
546	! 861211 REVISION DATE from Version 3.2
547	! 891214 Prologue converted to Version 4.0 format. (BAB)
548	! 920501 Reformatted the REFERENCES section. (WRB)
549	!***END PROLOGUE XGETUA
550	DIMENSION IUNITA(5)
551	INTEGER :: IUNITA, N, INDEX, I
552	!***FIRST EXECUTABLE STATEMENT XGETUA
553	N = J4SAVE(5, 0, .FALSE.)
554	DO I = 1, N
555	INDEX = I + 4
556	IF (I==1) INDEX = 3
557	IUNITA(I) = J4SAVE(INDEX, 0, .FALSE.)
558	END DO
559
560	END SUBROUTINE XGETUA
561
562	!DECK XERSVE
563	SUBROUTINE XERSVE(LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, &
564	ICOUNT)
565	IMPLICIT NONE
566	!***BEGIN PROLOGUE XERSVE
567	!***SUBSIDIARY
568	!***PURPOSE Record that an error has occurred.
569	!***LIBRARY SLATEC (XERROR)
570	!***CATEGORY R3
571	!***TYPE ALL (XERSVE-A)
572	!***KEYWORDS ERROR, XERROR
573	!***AUTHOR Jones, R. E., (SNLA)
574	!***DESCRIPTION
575
576	! *Usage:
577
578	! INTEGER KFLAG, NERR, LEVEL, ICOUNT
579	! CHARACTER * (len) LIBRAR, SUBROU, MESSG
580
581	! CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT)
582
583	! *Arguments:
584
585	! LIBRAR :IN is the library that the message is from.
586	! SUBROU :IN is the SUBROUTINE that the message is from.
587	! MESSG :IN is the message to be saved.
588	! KFLAG :IN indicates the action to be performed.
589	! when KFLAG > 0, the message in MESSG is saved.
590	! when KFLAG=0 the tables will be dumped and
591	! cleared.
592	! when KFLAG < 0, the tables will be dumped and
593	! not cleared.
594	! NERR :IN is the error number.
595	! LEVEL :IN is the error severity.
596	! ICOUNT :OUT the number of times this message has been seen,
597	! or zero if the table has overflowed and does not
598	! contain this message specifically. When KFLAG=0,
599	! ICOUNT will not be altered.
600
601	! *Description:
602
603	! Record that this error occurred and possibly dump and clear the
604	! tables.
605
606	!***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
607	! Error-handling Package, SAND82-0800, Sandia
608	! Laboratories, 1982.
609	!***ROUTINES CALLED I1MACH, XGETUA
610	!***REVISION HISTORY (YYMMDD)
611	! 800319 DATE WRITTEN
612	! 861211 REVISION DATE from Version 3.2
613	! 891214 Prologue converted to Version 4.0 format. (BAB)
614	! 900413 Routine modified to remove reference to KFLAG. (WRB)
615	! 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling
616	! sequence, use IF-THEN-ELSE, make number of saved entries
617	! easily changeable, changed routine name from XERSAV to
618	! XERSVE. (RWC)
619	! 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS)
620	! 920501 Reformatted the REFERENCES section. (WRB)
621	!***END PROLOGUE XERSVE
622	INTEGER, PARAMETER :: LENTAB = 10
623	INTEGER :: LUN(5)
624	CHARACTER(len = *) :: LIBRAR, SUBROU, MESSG
625	CHARACTER(len = 8) :: LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB
626	CHARACTER(len = 20) :: MESTAB(LENTAB), MES
627	DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB)
628	SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
629	DATA KOUNTX/0/, NMSG/0/
630	INTEGER :: NERR, LEVEL, KONTRL
631	INTEGER :: NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
632	INTEGER :: KFLAG, ICOUNT, NUNIT, KUNIT, IUNIT, I
633	!***FIRST EXECUTABLE STATEMENT XERSVE
634
635	IF (KFLAG<=0) THEN
636
637	! Dump the table.
638
639	IF (NMSG==0) RETURN
640
641	! Print to each unit.
642
643	CALL XGETUA (LUN, NUNIT)
644	DO KUNIT = 1, NUNIT
645	IUNIT = LUN(KUNIT)
646	IF (IUNIT==0) IUNIT = I1MACH(4)
647
648	! Print the table header.
649
650	WRITE (IUNIT, 9000)
651
652	! Print body of table.
653
654	DO I = 1, NMSG
655	WRITE (IUNIT, 9010) LIBTAB(I), SUBTAB(I), MESTAB(I), &
656	NERTAB(I), LEVTAB(I), KOUNT(I)
657	END DO
658
659	! Print number of other errors.
660
661	IF (KOUNTX/=0) WRITE (IUNIT, 9020) KOUNTX
662	WRITE (IUNIT, 9030)
663	END DO
664
665	! Clear the error tables.
666
667	IF (KFLAG==0) THEN
668	NMSG = 0
669	KOUNTX = 0
670	ENDIF
671	ELSE
672
673	! PROCESS A MESSAGE...
674	! SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
675	! OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
676
677	LIB = LIBRAR
678	SUB = SUBROU
679	MES = MESSG
680	DO I = 1, NMSG
681	IF (LIB==LIBTAB(I) .AND. SUB==SUBTAB(I) .AND. &
682	MES==MESTAB(I) .AND. NERR==NERTAB(I) .AND. &
683	LEVEL==LEVTAB(I)) THEN
684	KOUNT(I) = KOUNT(I) + 1
685	ICOUNT = KOUNT(I)
686	RETURN
687	ENDIF
688	END DO
689
690	IF (NMSG<LENTAB) THEN
691
692	! Empty slot found for new message.
693
694	NMSG = NMSG + 1
695	LIBTAB(I) = LIB
696	SUBTAB(I) = SUB
697	MESTAB(I) = MES
698	NERTAB(I) = NERR
699	LEVTAB(I) = LEVEL
700	KOUNT (I) = 1
701	ICOUNT = 1
702	ELSE
703
704	! Table is full.
705
706	KOUNTX = KOUNTX + 1
707	ICOUNT = 0
708	ENDIF
709	ENDIF
710	RETURN
711
712	! Formats.
713
714	9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / &
715	' LIBRARY SUBROUTINE MESSAGE START NERR', &
716	' LEVEL COUNT')
717	9010 FORMAT (1X, A, 3X, A, 3X, A, 3I10)
718	9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10)
719	9030 FORMAT (1X)
720	END SUBROUTINE XERSVE
721
722	!DECK XERPRN
723	SUBROUTINE XERPRN(PREFIX, NPREF, MESSG, NWRAP)
724	IMPLICIT NONE
725	!***BEGIN PROLOGUE XERPRN
726	!***SUBSIDIARY
727	!***PURPOSE Print error messages processed by XERMSG.
728	!***LIBRARY SLATEC (XERROR)
729	!***CATEGORY R3C
730	!***TYPE ALL (XERPRN-A)
731	!***KEYWORDS ERROR MESSAGES, PRINTING, XERROR
732	!***AUTHOR Fong, Kirby, (NMFECC at LLNL)
733	!***DESCRIPTION
734
735	! This routine sends one or more lines to each of the (up to five)
736	! LOGICAL units to which error messages are to be sent. This routine
737	! is called several times by XERMSG, sometimes with a single line to
738	! print and sometimes with a (potentially very long) message that may
739	! wrap around into multiple lines.
740
741	! PREFIX Input argument of type CHARACTER. This argument contains
742	! characters to be put at the beginning of each line before
743	! the body of the message. No more than 16 characters of
744	! PREFIX will be used.
745
746	! NPREF Input argument of type INTEGER. This argument is the number
747	! of characters to use from PREFIX. If it is negative, the
748	! intrinsic function LEN is used to determine its length. If
749	! it is zero, PREFIX is not used. If it exceeds 16 or if
750	! LEN(PREFIX) exceeds 16, ONLY the first 16 characters will be
751	! used. If NPREF is positive and the length of PREFIX is less
752	! than NPREF, a copy of PREFIX extended with blanks to length
753	! NPREF will be used.
754
755	! MESSG Input argument of type CHARACTER. This is the text of a
756	! message to be printed. If it is a long message, it will be
757	! broken into pieces for printing on multiple lines. Each line
758	! will start with the appropriate prefix and be followed by a
759	! piece of the message. NWRAP is the number of characters per
760	! piece; that is, after each NWRAP characters, we break and
761	! start a new line. In addition the characters '$$' embedded
762	! in MESSG are a sentinel for a new line. The counting of
763	! characters up to NWRAP starts over for each new line. The
764	! value of NWRAP typically used by XERMSG is 72 since many
765	! older error messages in the SLATEC Library are laid out to
766	! rely on wrap-around every 72 characters.
767
768	! NWRAP Input argument of type INTEGER. This gives the maximum size
769	! piece into which to break MESSG for printing on multiple
770	! lines. An embedded '$$' ends a line, and the count restarts
771	! at the following character. If a line break does not occur
772	! on a blank (it would split a word) that word is moved to the
773	! next line. Values of NWRAP less than 16 will be treated as
774	! 16. Values of NWRAP greater than 132 will be treated as 132.
775	! The actual line length will be NPREF + NWRAP after NPREF has
776	! been adjusted to fall between 0 and 16 and NWRAP has been
777	! adjusted to fall between 16 and 132.
778
779	!***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
780	! Error-handling Package, SAND82-0800, Sandia
781	! Laboratories, 1982.
782	!***ROUTINES CALLED I1MACH, XGETUA
783	!***REVISION HISTORY (YYMMDD)
784	! 880621 DATE WRITTEN
785	! 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
786	! JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
787	! THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
788	! SLASH CHARACTER IN FORMAT STATEMENTS.
789	! 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
790	! STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
791	! LINES TO BE PRINTED.
792	! 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF
793	! CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
794	! 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
795	! 891214 Prologue converted to Version 4.0 format. (WRB)
796	! 900510 Added code to break messages between words. (RWC)
797	! 920501 Reformatted the REFERENCES section. (WRB)
798	!***END PROLOGUE XERPRN
799	CHARACTER(len = *) :: PREFIX, MESSG
800	INTEGER :: NPREF, NWRAP
801	CHARACTER(len = 148) :: CBUFF
802	INTEGER :: IU(5), NUNIT
803	CHARACTER(len = 2) :: NEWLIN
804	PARAMETER (NEWLIN = '$$')
805	INTEGER :: N, I, LPREF, LWRAP, LENMSG, NEXTC
806	INTEGER :: LPIECE, IDELTA
807	!***FIRST EXECUTABLE STATEMENT XERPRN
808	CALL XGETUA(IU, NUNIT)
809
810	! A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
811	! ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD
812	! ERROR MESSAGE UNIT.
813
814	N = I1MACH(4)
815	DO I = 1, NUNIT
816	IF (IU(I) == 0) IU(I) = N
817	END DO
818
819	! LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE
820	! BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
821	! THE REST OF THIS ROUTINE.
822
823	IF (NPREF < 0) THEN
824	LPREF = LEN(PREFIX)
825	ELSE
826	LPREF = NPREF
827	ENDIF
828	LPREF = MIN(16, LPREF)
829	IF (LPREF /= 0) CBUFF(1:LPREF) = PREFIX
830
831	! LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
832	! TIME FROM MESSG TO PRINT ON ONE LINE.
833
834	LWRAP = MAX(16, MIN(132, NWRAP))
835
836	! SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
837
838	LENMSG = LEN(MESSG)
839	N = LENMSG
840	DO I = 1, N
841	IF (MESSG(LENMSG:LENMSG) /= ' ') GO TO 30
842	LENMSG = LENMSG - 1
843	END DO
844	30 CONTINUE
845
846	! IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
847
848	IF (LENMSG == 0) THEN
849	CBUFF(LPREF + 1:LPREF + 1) = ' '
850	DO I = 1, NUNIT
851	WRITE(IU(I), '(A)') CBUFF(1:LPREF + 1)
852	END DO
853	RETURN
854	ENDIF
855
856	! SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
857	! STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
858	! WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
859	! WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
860
861	! WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE
862	! INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
863	! OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
864	! OF THE SECOND ARGUMENT.
865
866	! THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
867	! FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
868	! OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
869	! POSITION NEXTC.
870
871	! LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
872	! REMAINDER OF THE CHARACTER STRING. LPIECE
873	! SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
874	! WHICHEVER IS LESS.
875
876	! LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
877	! NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE
878	! PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
879	! BLANK LINES. THIS TAKES CARE OF THE SITUATION
880	! WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
881	! EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
882	! SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC
883	! SHOULD BE INCREMENTED BY 2.
884
885	! LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP.
886
887	! ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
888	! RESET LPIECE = LPIECE-1. NOTE THAT THIS
889	! PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
890	! LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY
891	! AT THE END OF A LINE.
892
893	NEXTC = 1
894	50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
895	IF (LPIECE == 0) THEN
896
897	! THERE WAS NO NEW LINE SENTINEL FOUND.
898
899	IDELTA = 0
900	LPIECE = MIN(LWRAP, LENMSG + 1 - NEXTC)
901	IF (LPIECE < LENMSG + 1 - NEXTC) THEN
902	DO I = LPIECE + 1, 2, -1
903	IF (MESSG(NEXTC + I - 1:NEXTC + I - 1) == ' ') THEN
904	LPIECE = I - 1
905	IDELTA = 1
906	GOTO 54
907	ENDIF
908	END DO
909	ENDIF
910	54 CBUFF(LPREF + 1:LPREF + LPIECE) = MESSG(NEXTC:NEXTC + LPIECE - 1)
911	NEXTC = NEXTC + LPIECE + IDELTA
912	ELSEIF (LPIECE == 1) THEN
913
914	! WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
915	! DON'T PRINT A BLANK LINE.
916
917	NEXTC = NEXTC + 2
918	GO TO 50
919	ELSEIF (LPIECE > LWRAP + 1) THEN
920
921	! LPIECE SHOULD BE SET DOWN TO LWRAP.
922
923	IDELTA = 0
924	LPIECE = LWRAP
925	DO I = LPIECE + 1, 2, -1
926	IF (MESSG(NEXTC + I - 1:NEXTC + I - 1) == ' ') THEN
927	LPIECE = I - 1
928	IDELTA = 1
929	GOTO 58
930	ENDIF
931	END DO
932	58 CBUFF(LPREF + 1:LPREF + LPIECE) = MESSG(NEXTC:NEXTC + LPIECE - 1)
933	NEXTC = NEXTC + LPIECE + IDELTA
934	ELSE
935
936	! IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
937	! WE SHOULD DECREMENT LPIECE BY ONE.
938
939	LPIECE = LPIECE - 1
940	CBUFF(LPREF + 1:LPREF + LPIECE) = MESSG(NEXTC:NEXTC + LPIECE - 1)
941	NEXTC = NEXTC + LPIECE + 2
942	ENDIF
943
944	! PRINT
945
946	DO I = 1, NUNIT
947	WRITE(IU(I), '(A)') CBUFF(1:LPREF + LPIECE)
948	END DO
949
950	IF (NEXTC <= LENMSG) GO TO 50
951
952	END SUBROUTINE XERPRN
953
954	!DECK XERHLT
955	SUBROUTINE XERHLT(MESSG)
956	!***BEGIN PROLOGUE XERHLT
957	!***SUBSIDIARY
958	!***PURPOSE Abort program execution and print error message.
959	!***LIBRARY SLATEC (XERROR)
960	!***CATEGORY R3C
961	!***TYPE ALL (XERHLT-A)
962	!***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR
963	!***AUTHOR Jones, R. E., (SNLA)
964	!***DESCRIPTION
965
966	! Abstract
967	! *Note* machine dependent routine
968	! XERHLT aborts the execution of the program.
969	! The error message causing the abort is given in the calling
970	! sequence, in case one needs it for printing on a dayfile,
971	! for example.
972
973	! Description of Parameters
974	! MESSG is as in XERMSG.
975
976	!***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
977	! Error-handling Package, SAND82-0800, Sandia
978	! Laboratories, 1982.
979	!***ROUTINES CALLED (NONE)
980	!***REVISION HISTORY (YYMMDD)
981	! 790801 DATE WRITTEN
982	! 861211 REVISION DATE from Version 3.2
983	! 891214 Prologue converted to Version 4.0 format. (BAB)
984	! 900206 Routine changed from user-callable to subsidiary. (WRB)
985	! 900510 Changed calling sequence to delete length of character
986	! and changed routine name from XERABT to XERHLT. (RWC)
987	! 920501 Reformatted the REFERENCES section. (WRB)
988	!***END PROLOGUE XERHLT
989	CHARACTER(len = *) :: MESSG
990	!***FIRST EXECUTABLE STATEMENT XERHLT
991	STOP
992	END SUBROUTINE XERHLT
993
994	!DECK XERCNT
995	SUBROUTINE XERCNT(LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL)
996	IMPLICIT NONE
997	!***BEGIN PROLOGUE XERCNT
998	!***SUBSIDIARY
999	!***PURPOSE Allow user control over handling of errors.
1000	!***LIBRARY SLATEC (XERROR)
1001	!***CATEGORY R3C
1002	!***TYPE ALL (XERCNT-A)
1003	!***KEYWORDS ERROR, XERROR
1004	!***AUTHOR Jones, R. E., (SNLA)
1005	!***DESCRIPTION
1006
1007	! Abstract
1008	! Allows user control over handling of individual errors.
1009	! Just after each message is recorded, but before it is
1010	! processed any further (i.e., before it is printed or
1011	! a decision to abort is made), a CALL is made to XERCNT.
1012	! If the user has provided his own version of XERCNT, he
1013	! can then override the value of KONTROL used in processing
1014	! this message by redefining its value.
1015	! KONTRL may be set to any value from -2 to 2.
1016	! The meanings for KONTRL are the same as in XSETF, except
1017	! that the value of KONTRL changes only for this message.
1018	! If KONTRL is set to a value outside the range from -2 to 2,
1019	! it will be moved back into that range.
1020
1021	! Description of Parameters
1022
1023	! --Input--
1024	! LIBRAR - the library that the routine is in.
1025	! SUBROU - the SUBROUTINE that XERMSG is being called from
1026	! MESSG - the first 20 characters of the error message.
1027	! NERR - same as in the CALL to XERMSG.
1028	! LEVEL - same as in the CALL to XERMSG.
1029	! KONTRL - the current value of the control flag as set
1030	! by a CALL to XSETF.
1031
1032	! --Output--
1033	! KONTRL - the new value of KONTRL. If KONTRL is not
1034	! defined, it will remain at its original value.
1035	! This changed value of control affects only
1036	! the current occurrence of the current message.
1037
1038	!***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
1039	! Error-handling Package, SAND82-0800, Sandia
1040	! Laboratories, 1982.
1041	!***ROUTINES CALLED (NONE)
1042	!***REVISION HISTORY (YYMMDD)
1043	! 790801 DATE WRITTEN
1044	! 861211 REVISION DATE from Version 3.2
1045	! 891214 Prologue converted to Version 4.0 format. (BAB)
1046	! 900206 Routine changed from user-callable to subsidiary. (WRB)
1047	! 900510 Changed calling sequence to INCLUDE LIBRARY and SUBROUTINE
1048	! names, changed routine name from XERCTL to XERCNT. (RWC)
1049	! 920501 Reformatted the REFERENCES section. (WRB)
1050	!***END PROLOGUE XERCNT
1051	CHARACTER(len = *) :: LIBRAR, SUBROU, MESSG
1052	INTEGER :: NERR, LEVEL, KONTRL
1053	!***FIRST EXECUTABLE STATEMENT XERCNT
1054
1055	END SUBROUTINE XERCNT
1056
1057	!DECK J4SAVE
1058	INTEGER FUNCTION J4SAVE(IWHICH, IVALUE, ISET)
1059	IMPLICIT NONE
1060	!***BEGIN PROLOGUE J4SAVE
1061	!***SUBSIDIARY
1062	!***PURPOSE Save or reCALL global variables needed by error
1063	! handling routines.
1064	!***LIBRARY SLATEC (XERROR)
1065	!***TYPE INTEGER (J4SAVE-I)
1066	!***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR
1067	!***AUTHOR Jones, R. E., (SNLA)
1068	!***DESCRIPTION
1069
1070	! Abstract
1071	! J4SAVE saves and recalls several global variables needed
1072	! by the library error handling routines.
1073
1074	! Description of Parameters
1075	! --Input--
1076	! IWHICH - Index of item desired.
1077	! = 1 Refers to current error number.
1078	! = 2 Refers to current error control flag.
1079	! = 3 Refers to current unit number to which error
1080	! messages are to be sent. (0 means use standard.)
1081	! = 4 Refers to the maximum number of times any
1082	! message is to be printed (as set by XERMAX).
1083	! = 5 Refers to the total number of units to which
1084	! each error message is to be written.
1085	! = 6 Refers to the 2nd unit for error messages
1086	! = 7 Refers to the 3rd unit for error messages
1087	! = 8 Refers to the 4th unit for error messages
1088	! = 9 Refers to the 5th unit for error messages
1089	! IVALUE - The value to be set for the IWHICH-th parameter,
1090	! if ISET is .TRUE. .
1091	! ISET - If ISET=.TRUE., the IWHICH-th parameter will BE
1092	! given the value, IVALUE. If ISET=.FALSE., the
1093	! IWHICH-th parameter will be unchanged, and IVALUE
1094	! is a dummy parameter.
1095	! --Output--
1096	! The (old) value of the IWHICH-th parameter will be returned
1097	! in the function value, J4SAVE.
1098
1099	!***SEE ALSO XERMSG
1100	!***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
1101	! Error-handling Package, SAND82-0800, Sandia
1102	! Laboratories, 1982.
1103	!***ROUTINES CALLED (NONE)
1104	!***REVISION HISTORY (YYMMDD)
1105	! 790801 DATE WRITTEN
1106	! 891214 Prologue converted to Version 4.0 format. (BAB)
1107	! 900205 Minor modifications to prologue. (WRB)
1108	! 900402 Added TYPE section. (WRB)
1109	! 910411 Added KEYWORDS section. (WRB)
1110	! 920501 Reformatted the REFERENCES section. (WRB)
1111	!***END PROLOGUE J4SAVE
1112	LOGICAL :: ISET
1113	INTEGER :: IPARAM(9)
1114	SAVE IPARAM
1115	DATA IPARAM(1), IPARAM(2), IPARAM(3), IPARAM(4)/0, 2, 0, 10/
1116	DATA IPARAM(5)/1/
1117	DATA IPARAM(6), IPARAM(7), IPARAM(8), IPARAM(9)/0, 0, 0, 0/
1118	INTEGER :: IWHICH, IVALUE
1119	!***FIRST EXECUTABLE STATEMENT J4SAVE
1120	J4SAVE = IPARAM(IWHICH)
1121	IF (ISET) IPARAM(IWHICH) = IVALUE
1122
1123	END FUNCTION J4SAVE
1124
1125
1126	END MODULE lmdz_xer

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format