Mercurial > octave-nkf

annotate libcruft/slatec-err/xsetua.f @ 12312:b10ea6efdc58 release-3-4-x ss-3-3-91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
version is now 3.3.91
author John W. Eaton <jwe@octave.org>
date Mon, 31 Jan 2011 08:36:58 -0500
parents 5a691cbef111
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
3274
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
1 *DECK XSETUA
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
2 SUBROUTINE XSETUA (IUNITA, N)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
3 C***BEGIN PROLOGUE XSETUA
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
4 C***PURPOSE Set logical unit numbers (up to 5) to which error
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
5 C messages are to be sent.
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
6 C***LIBRARY SLATEC (XERROR)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
7 C***CATEGORY R3B
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
8 C***TYPE ALL (XSETUA-A)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
9 C***KEYWORDS ERROR, XERROR
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
10 C***AUTHOR Jones, R. E., (SNLA)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
11 C***DESCRIPTION
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
12 C
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
13 C Abstract
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
14 C XSETUA may be called to declare a list of up to five
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
15 C logical units, each of which is to receive a copy of
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
16 C each error message processed by this package.
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
17 C The purpose of XSETUA is to allow simultaneous printing
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
18 C of each error message on, say, a main output file,
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
19 C an interactive terminal, and other files such as graphics
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
20 C communication files.
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
21 C
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
22 C Description of Parameters
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
23 C --Input--
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
24 C IUNIT - an array of up to five unit numbers.
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
25 C Normally these numbers should all be different
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
26 C (but duplicates are not prohibited.)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
27 C N - the number of unit numbers provided in IUNIT
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
28 C must have 1 .LE. N .LE. 5.
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
29 C
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
30 C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
31 C Error-handling Package, SAND82-0800, Sandia
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
32 C Laboratories, 1982.
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
33 C***ROUTINES CALLED J4SAVE, XERMSG
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
34 C***REVISION HISTORY (YYMMDD)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
35 C 790801 DATE WRITTEN
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
36 C 861211 REVISION DATE from Version 3.2
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
37 C 891214 Prologue converted to Version 4.0 format. (BAB)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
38 C 900510 Change call to XERRWV to XERMSG. (RWC)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
39 C 920501 Reformatted the REFERENCES section. (WRB)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
40 C***END PROLOGUE XSETUA
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
41 DIMENSION IUNITA(5)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
42 CHARACTER *8 XERN1
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
43 C***FIRST EXECUTABLE STATEMENT XSETUA
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
44 C
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
45 IF (N.LT.1 .OR. N.GT.5) THEN
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
46 WRITE (XERN1, '(I8)') N
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
47 CALL XERMSG ('SLATEC', 'XSETUA',
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
48 * 'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
49 RETURN
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
50 ENDIF
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
51 C
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
52 DO 10 I=1,N
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
53 INDEX = I+4
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
54 IF (I.EQ.1) INDEX = 3
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
55 JUNK = J4SAVE(INDEX,IUNITA(I),.TRUE.)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
56 10 CONTINUE
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
57 JUNK = J4SAVE(5,N,.TRUE.)
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
58 RETURN
5a691cbef111 [project @ 1999-10-12 05:21:34 by jwe]
jwe
parents:
diff changeset
59 END