Context Navigation

slatec_xer.f90 @ 5419

Last change on this file since 5419 was 5220, checked in by abarral, 3 months ago
Correct errors induced in r5218 r5219
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.5 KB

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

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

Download in other formats:

Original Format