1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
*DECK XERRWD
SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2)
C***BEGIN PROLOGUE XERRWD
C***SUBSIDIARY
C***PURPOSE Write error message with values.
C***LIBRARY MATHLIB
C***CATEGORY R3C
C***TYPE DOUBLE PRECISION (XERRWV-S, XERRWD-D)
C***AUTHOR Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C Subroutines XERRWD, XSETF1, XSETUN1, and the function routine IXSAV,
C as given here, constitute a simplified version of the SLATEC error
C handling package.
C
C All arguments are input arguments.
C
C MSG = The message (character array).
C NMES = The length of MSG (number of characters).
C NERR = The error number (not used).
C LEVEL = The error level..
C 0 or 1 means recoverable (control returns to caller).
C 2 means fatal (run is aborted--see note below).
C NI = Number of integers (0, 1, or 2) to be printed with message.
C I1,I2 = Integers to be printed, depending on NI.
C NR = Number of reals (0, 1, or 2) to be printed with message.
C R1,R2 = Reals to be printed, depending on NR.
C
C Note.. this routine is machine-dependent and specialized for use
C in limited context, in the following ways..
C 1. The argument MSG is assumed to be of type CHARACTER, and
C the message is printed with a format of (1X,A).
C 2. The message is assumed to take only one line.
C Multi-line messages are generated by repeated calls.
C 3. If LEVEL = 2, control passes to the statement STOP
C to abort the run. This statement may be machine-dependent.
C 4. R1 and R2 are assumed to be in double precision and are printed
C in D21.13 format.
C
C***ROUTINES CALLED IXSAV
C***REVISION HISTORY (YYMMDD)
C 920831 DATE WRITTEN
C 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH)
C 930329 Modified prologue to SLATEC format. (FNF)
C 930407 Changed MSG from CHARACTER*1 array to variable. (FNF)
C 930922 Minor cosmetic change. (FNF)
C***END PROLOGUE XERRWD
C
C*Internal Notes:
C
C For a different default logical unit number, IXSAV (or a subsidiary
C routine that it calls) will need to be modified.
C For a different run-abort command, change the statement following
C statement 100 at the end.
C-----------------------------------------------------------------------
C Subroutines called by XERRWD.. None
C Function routine called by XERRWD.. IXSAV
C-----------------------------------------------------------------------
C**End
C
C Declare arguments.
C
DOUBLE PRECISION R1, R2
INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR
CHARACTER*(*) MSG
C
C Declare local variables.
C
INTEGER LUNIT, IXSAV, MESFLG
C
C Get logical unit number and message print flag.
C
C***FIRST EXECUTABLE STATEMENT XERRWD
LUNIT = IXSAV (1, 0, .FALSE.)
MESFLG = IXSAV (2, 0, .FALSE.)
IF (MESFLG .EQ. 0) GO TO 100
C
C Write the message.
C
WRITE (LUNIT,10) MSG
10 FORMAT(1X,A)
IF (NI .EQ. 1) WRITE (LUNIT, 20) I1
20 FORMAT(6X,'In above message, I1 =',I10)
IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2
30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10)
IF (NR .EQ. 1) WRITE (LUNIT, 40) R1
40 FORMAT(6X,'In above message, R1 =',D21.13)
IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2
50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13)
C
C Abort the run if LEVEL = 2.
C
100 IF (LEVEL .NE. 2) RETURN
STOP
C----------------------- End of Subroutine XERRWD ----------------------
END
*DECK XSETF1
SUBROUTINE XSETF1 (MFLAG)
C***BEGIN PROLOGUE XSETF1
C***PURPOSE Reset the error print control flag.
C***LIBRARY MATHLIB
C***CATEGORY R3A
C***TYPE ALL (XSETF1-A)
C***KEYWORDS ERROR CONTROL
C***AUTHOR Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C XSETF1 sets the error print control flag to MFLAG:
C MFLAG=1 means print all messages (the default).
C MFLAG=0 means no printing.
C
C***SEE ALSO XERMSG, XERRWD, XERRWV
C***REFERENCES (NONE)
C***ROUTINES CALLED IXSAV
C***REVISION HISTORY (YYMMDD)
C 921118 DATE WRITTEN
C 930329 Added SLATEC format prologue. (FNF)
C 930407 Corrected SEE ALSO section. (FNF)
C 930922 Made user-callable, and other cosmetic changes. (FNF)
C***END PROLOGUE XSETF1
C
C Subroutines called by XSETF1.. None
C Function routine called by XSETF1.. IXSAV
C-----------------------------------------------------------------------
C**End
INTEGER MFLAG, JUNK, IXSAV
C
C***FIRST EXECUTABLE STATEMENT XSETF1
IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = IXSAV (2,MFLAG,.TRUE.)
RETURN
C----------------------- End of Subroutine XSETF1 ----------------------
END
*DECK XSETUN1
SUBROUTINE XSETUN1 (LUN)
C***BEGIN PROLOGUE XSETUN1
C***PURPOSE Reset the logical unit number for error messages.
C***LIBRARY MATHLIB
C***CATEGORY R3B
C***TYPE ALL (XSETUN1-A)
C***KEYWORDS ERROR CONTROL
C***DESCRIPTION
C
C XSETUN1 sets the logical unit number for error messages to LUN.
C
C***AUTHOR Hindmarsh, Alan C., (LLNL)
C***SEE ALSO XERMSG, XERRWD, XERRWV
C***REFERENCES (NONE)
C***ROUTINES CALLED IXSAV
C***REVISION HISTORY (YYMMDD)
C 921118 DATE WRITTEN
C 930329 Added SLATEC format prologue. (FNF)
C 930407 Corrected SEE ALSO section. (FNF)
C 930922 Made user-callable, and other cosmetic changes. (FNF)
C***END PROLOGUE XSETUN1
C
C Subroutines called by XSETUN1.. None
C Function routine called by XSETUN1.. IXSAV
C-----------------------------------------------------------------------
C**End
INTEGER LUN, JUNK, IXSAV
C
C***FIRST EXECUTABLE STATEMENT XSETUN1
IF (LUN .GT. 0) JUNK = IXSAV (1,LUN,.TRUE.)
RETURN
C----------------------- End of Subroutine XSETUN1 ---------------------
END
*DECK IXSAV
INTEGER FUNCTION IXSAV (IPAR, IVALUE, ISET)
C***BEGIN PROLOGUE IXSAV
C***SUBSIDIARY
C***PURPOSE Save and recall error message control parameters.
C***LIBRARY MATHLIB
C***CATEGORY R3C
C***TYPE ALL (IXSAV-A)
C***AUTHOR Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C IXSAV saves and recalls one of two error message parameters:
C LUNIT, the logical unit number to which messages are printed, and
C MESFLG, the message print flag.
C This is a modification of the SLATEC library routine J4SAVE.
C
C Saved local variables..
C LUNIT = Logical unit number for messages.
C LUNDEF = Default logical unit number, data-loaded to 6 below
C (may be machine-dependent).
C MESFLG = Print control flag..
C 1 means print all messages (the default).
C 0 means no printing.
C
C On input..
C IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG).
C IVALUE = The value to be set for the parameter, if ISET = .TRUE.
C ISET = Logical flag to indicate whether to read or write.
C If ISET = .TRUE., the parameter will be given
C the value IVALUE. If ISET = .FALSE., the parameter
C will be unchanged, and IVALUE is a dummy argument.
C
C On return..
C IXSAV = The (old) value of the parameter.
C
C***SEE ALSO XERMSG, XERRWD, XERRWV
C***ROUTINES CALLED NONE
C***REVISION HISTORY (YYMMDD)
C 921118 DATE WRITTEN
C 930329 Modified prologue to SLATEC format. (FNF)
C 941025 Minor modification re default unit number. (ACH)
C***END PROLOGUE IXSAV
C
C**End
LOGICAL ISET
INTEGER IPAR, IVALUE
C-----------------------------------------------------------------------
INTEGER LUNIT, LUNDEF, MESFLG
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this routine.
C-----------------------------------------------------------------------
SAVE LUNIT, LUNDEF, MESFLG
DATA LUNIT/-1/, LUNDEF/6/, MESFLG/1/
C
C***FIRST EXECUTABLE STATEMENT IXSAV
IF (IPAR .EQ. 1) THEN
IF (LUNIT .EQ. -1) LUNIT = LUNDEF
IXSAV = LUNIT
IF (ISET) LUNIT = IVALUE
ENDIF
C
IF (IPAR .EQ. 2) THEN
IXSAV = MESFLG
IF (ISET) MESFLG = IVALUE
ENDIF
C
RETURN
C----------------------- End of Function IXSAV -------------------------
END
|
