rts-slatec.c
1 //!@file rts-slatec.c
2 //!@author J. Marcel van der Veer
3 //
4 // !@section Copyright
5 //
6 // This file is part of VIF - vintage FORTRAN compiler.
7 // Copyright 2020-2024 J. Marcel van der Veer <algol68g@xs4all.nl>.
8 //
9 //! @section License
10 //
11 // This program is free software; you can redistribute it and/or modify it
12 // under the terms of the GNU General Public License as published by the
13 // Free Software Foundation; either version 3 of the License, or
14 // (at your option) any later version.
15 //
16 // This program is distributed in the hope that it will be useful, but
17 // WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 // or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 // more details. You should have received a copy of the GNU General Public
20 // License along with this program. If not, see <http://www.gnu.org/licenses/>.
21
22 //! @section Synopsis
23 //!
24 //! Runtime support for SLATEC subprograms.
25
26 //!@brief SLATEC stubs for VIF, adapted to C.
27 // SLATEC common mathematical library, version 4.1, July 1993.
28 //
29 // SLATEC was developed at US government research laboratories
30 // and is in the public domain.
31 // Repository: http://www.netlib.org/slatec/
32
33 #include <vif.h>
34
35 // d1mach yields machine-dependent parameters for the
36 // local machine environment.
37 //
38 // d1mach(1) = b**(emin-1), the smallest positive magnitude.
39 // d1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude.
40 // d1mach(3) = b**(-t), the smallest relative spacing.
41 // d1mach(4) = b**(1-t), the largest relative spacing.
42 // d1mach(5) = log10(b)
43
44 real_4 _r1mach (int_4 *i)
45 {
46 switch (*i) {
47 // r1mach(1) = b**(emin-1), the smallest positive magnitude.
48 case 1: return FLT_MIN;
49 // r1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude.
50 case 2: return FLT_MAX;
51 // r1mach(3) = b**(-t), the smallest relative spacing.
52 case 3: return 0.5 * FLT_EPSILON;
53 // r1mach(4) = b**(1-t), the largest relative spacing.
54 case 4: return FLT_EPSILON;
55 // r1mach(5) = log10(b)
56 case 5: return M_LOG10_2;
57 //
58 default: return 0.0;
59 }
60 }
61
62 real_8 _d1mach (int_4 *i)
63 {
64 switch (*i) {
65 // d1mach(1) = b**(emin-1), the smallest positive magnitude.
66 case 1: return DBL_MIN;
67 // d1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude.
68 case 2: return DBL_MAX;
69 // d1mach(3) = b**(-t), the smallest relative spacing.
70 case 3: return 0.5 * DBL_EPSILON;
71 // d1mach(4) = b**(1-t), the largest relative spacing.
72 case 4: return DBL_EPSILON;
73 // d1mach(5) = log10(b)
74 case 5: return M_LOG10_2;
75 //
76 default: return 0.0;
77 }
78 }
79
80 real_8 _dmach (int_4 *i)
81 {
82 return _d1mach (i);
83 }
84
85 // i1mach yields machine-dependent parameters for the
86 // local machine environment.
87 //
88 // i/o unit numbers:
89 // i1mach(1) = the standard input unit.
90 // i1mach(2) = the standard output unit.
91 // i1mach(3) = the standard punch unit.
92 // i1mach(4) = the standard error message unit.
93 //
94 // words:
95 // i1mach(5) = the number of bits per int_4 storage unit.
96 // i1mach(6) = the number of characters per int_4 storage unit.
97 //
98 // integers:
99 // assume int_4s are represented in the s-digit, base-a form
100 //
101 // sign (x(s-1)*a**(s-1) + ... + x(1)*a + x(0) )
102 //
103 // where 0 .le. x(i) .lt. a for i=0,...,s-1.
104 // i1mach(7) = a, the base.
105 // i1mach(8) = s, the number of base-a digits.
106 // i1mach(9) = a**s - 1, the largest magnitude.
107 //
108 // floating-point_4 numbers:
109 // assume floating-point_4 numbers are represented in the t-digit,
110 // base-b form
111 // sign (b**e)*((x(1)/b) + ... + (x(t)/b**t) )
112 //
113 // where 0 .le. x(i) .lt. b for i=1,...,t,
114 // 0 .lt. x(1), and emin .le. e .le. emax.
115 // i1mach(10) = b, the base.
116 //
117 // single-precision:
118 // i1mach(11) = t, the number of base-b digits.
119 // i1mach(12) = emin, the smallest exponent e.
120 // i1mach(13) = emax, the largest exponent e.
121 //
122 // double-precision:
123 // i1mach(14) = t, the number of base-b digits.
124 // i1mach(15) = emin, the smallest exponent e.
125 // i1mach(16) = emax, the largest exponent e.
126
127 int_4 _i1mach (int_4 *i)
128 {
129 switch(*i) {
130 // i1mach(1) = the standard input unit.
131 // i1mach(2) = the standard output unit.
132 // i1mach(3) = the standard punch unit.
133 // i1mach(4) = the standard error message unit.
134 case 1: return STDF_IN;
135 case 2: return STDF_OUT;
136 case 3: return STDF_PUN;
137 case 4: return STDF_ERR;
138 // i1mach(5) = the number of bits per int_4 storage unit.
139 // i1mach(6) = the number of characters per int_4 storage unit.
140 case 5: return CHAR_BIT * sizeof (int_4);
141 case 6: return sizeof (int_4);
142 // i1mach(7) = a, the base.
143 // i1mach(8) = s, the number of base-a digits.
144 // i1mach(9) = a**s - 1, the largest magnitude.
145 case 7: return 2;
146 case 8: return CHAR_BIT * sizeof (int_4) - 1;
147 case 9: return INT_MAX;
148 // i1mach(10) = b, the base.
149 case 10: return FLT_RADIX;
150 // i1mach(11) = t, the number of base-b digits.
151 // i1mach(12) = emin, the smallest exponent e.
152 // i1mach(13) = emax, the largest exponent e.
153 case 11: return FLT_MANT_DIG;
154 case 12: return FLT_MIN_EXP;
155 case 13: return FLT_MAX_EXP;
156 // i1mach(14) = t, the number of base-b digits.
157 // i1mach(15) = emin, the smallest exponent e.
158 // i1mach(16) = emax, the largest exponent e.
159 case 14: return DBL_MANT_DIG;
160 case 15: return DBL_MIN_EXP;
161 case 16: return DBL_MAX_EXP;
162 //
163 default: return 0;
164 }
165 }
166
167 // amach yields machine-dependent parameters for the local environment.
168 //
169 // subroutine amach(mode, i, i1, r1, d1)
170
171 int_4 _amach (int_4 _p_ mode_, int_4 _p_ i_, int_4 _p_ i1_, real_4 _p_ r1_, real_8 _p_ d1_)
172 {
173 if (*mode_ == 0) {
174 *i1_ = _i1mach(i_);
175 }
176 else if (*mode_ == 1) {
177 *r1_ = _r1mach(i_);
178 }
179 else {
180 *d1_ = _d1mach(i_);
181 }
182 return 0;
183 }
184
185 int_4 _xerclr (void)
186 {
187 // This routine simply resets the current error number to zero.
188 // This may be necessary in order to determine that a certain
189 // error has occurred again since the last time NUMXER was
190 // referenced.
191 errno = 0;
192 return 0;
193 }
194
195 static int_4 _kontrl = 0;
196
197 int_4 _xgetf (int_4 *kontrl)
198 {
199 // XGETF returns the current value of the error control flag
200 // in KONTRL. See subroutine XSETF for flag value meanings.
201 // (KONTRL is an output parameter only.)
202 //
203 *kontrl = _kontrl;
204 return 0;
205 }
206
207 int_4 _xsetf (int_4 *kontrl)
208 {
209 // XSETF sets the error control flag value to KONTRL.
210 // (KONTRL is an input parameter only.)
211 // The following table shows how each message is treated,
212 // depending on the values of KONTRL and LEVEL. (See XERMSG
213 // for description of LEVEL.)
214
215 // If KONTRL is zero or negative, no information other than the
216 // message itself (including numeric values, if any) will be
217 // printed. If KONTRL is positive, introductory messages,
218 // trace-backs, etc., will be printed in addition to the message.
219
220 // ABS(KONTRL)
221 // LEVEL 0 1 2
222 // value
223 // 2 fatal fatal fatal
224
225 // 1 not printed printed fatal
226
227 // 0 not printed printed printed
228
229 // -1 not printed printed printed
230 // only only
231 // once once
232 _kontrl = *kontrl;
233 return 0;
234 }
235
236 int_4 _xermsg (char *librar, char *subrou, char *messg, int_4 *nerr, int_4 *level)
237 {
238 // XERMSG processes a diagnostic message in a manner determined by the
239 // value of LEVEL and the current value of the library error control
240 // flag, KONTRL. See subroutine XSETF for details.
241
242 // LIBRAR A character constant (or character variable) with the name
243 // of the library. This will be 'SLATE' for the SLATEC
244 // ommon Math Library. The error handling package is
245 // general enough to be used by many libraries
246 // simultaneously, so it is desirable for the routine that
247 // detects and reports an error to identify the library name
248 // as well as the routine name.
249
250 // SUBROU A character constant (or character variable) with the name
251 // of the routine that detected the error. Usually it is the
252 // name of the routine that is calling XERMSG. There are
253 // some instances where a user callable library routine calls
254 // lower level subsidiary routines where the error is
255 // detected. In such cases it may be more informative to
256 // supply the name of the routine the user called rather than
257 // the name of the subsidiary routine that detected the
258 // error.
259
260 // MESSG A character constant (or character variable) with the text
261 // of the error or warning message. In the example below,
262 // the message is a character constant that contains a
263 // generic message.
264
265 // ALL XERMSG ('SLATEC', 'MMPY',
266 // *'THE ORDER OF THE MATRIX EXEEDS THE ROW DIMENSION',
267 // *3, 1)
268
269 // It is possible (and is sometimes desirable) to generate a
270 // specific message--e.g., one that contains actual numeric
271 // values. Specific numeric values can be converted into
272 // character strings using formatted WRITE statements into
273 // character variables. This is called standard Fortran
274 // internal file I/O and is exemplified in the first three
275 // lines of the following example. You can also catenate
276 // substrings of characters to construct the error message.
277 // Here is an example showing the use of both writing to
278 // an internal file and catenating character strings.
279
280 // CHARACTER*5 CHARN, CHARL
281 // WRITE (HARN,10) N
282 // WRITE (HARL,10) LDA
283 // 10 FORMAT(I5)
284 // ALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
285 // * ' OF THE MATRIX EXEEDS ITS ROW DIMENSION OF'//
286 // * HARL, 3, 1)
287
288 // There are two subtleties worth mentioning. One is that
289 // the // for character catenation is used to construct the
290 // error message so that no single character constant is
291 // continued to the next line. This avoids confusion as to
292 // whether there are trailing blanks at the end of the line.
293 // The second is that by catenating the parts of the message
294 // as an actual argument rather than encoding the entire
295 // message into one large character variable, we avoid
296 // having to know how long the message will be in order to
297 // declare an adequate length for that large character
298 // variable. XERMSG calls XERPRN to print_4 the message using
299 // multiple lines if necessary. If the message is very long,
300 // XERPRN will break it into pieces of 72 characters (as
301 // requested by XERMSG) for printing on multiple lines.
302 // Also, XERMSG asks XERPRN to prefix each line with ' * '
303 // so that the total line length could be 76 characters.
304 // Note also that XERPRN scans the error message backwards
305 // to ignore trailing blanks. Another feature is that
306 // the substring '$$' is treated as a new line sentinel
307 // by XERPRN. If you want to construct a multiline
308 // message without having to count out multiples of 72
309 // characters, just use '$$' as a separator. '$$'
310 // obviously must occur within 72 characters of the
311 // start of each line to have its intended effect since
312 // XERPRN is asked to wrap around at 72 characters in
313 // addition to looking for '$$'.
314
315 // NERR An integer value that is chosen by the library routine's
316 // author. It must be in the range -99 to 999 (three
317 // printable digits). Each distinct error should have its
318 // own error number. These error numbers should be described
319 // in the machine readable documentation for the routine.
320 // The error numbers need be unique only within each routine,
321 // so it is reasonable for each routine to start enumerating
322 // errors from 1 and proceeding to the next integer.
323
324 // LEVEL An integer value in the range 0 to 2 that indicates the
325 // level (severity) of the error. Their meanings are
326
327 // -1 A warning message. This is used if it is not clear
328 // that there really is an error, but the user's attention
329 // may be needed. An attempt is made to only print_4 this
330 // message once.
331
332 // 0 A warning message. This is used if it is not clear
333 // that there really is an error, but the user's attention
334 // may be needed.
335
336 // 1 A recoverable error. This is used even if the error is
337 // so serious that the routine cannot return any useful
338 // answer. If the user has told the error package to
339 // return after recoverable errors, then XERMSG will
340 // return to the Library routine which can then return to
341 // the user's routine. The user may also permit the error
342 // package to terminate the program upon encountering a
343 // recoverable error.
344
345 // 2 A fatal error. XERMSG will not return to its caller
346 // after it receives a fatal error. This level should
347 // hardly ever be used; it is much better to allow the
348 // user a chance to recover. An example of one of the few
349 // cases in which it is permissible to declare a level 2
350 // error is a reverse communication Library routine that
351 // is likely to be called repeatedly until it integrates
352 // across some interval. If there is a serious error in
353 // the input such that another step cannot be taken and
354 // the Library routine is called again without the input
355 // error having been corrected by the caller, the Library
356 // routine will probably be called forever with improper
357 // input. In this case, it is reasonable to declare the
358 // error to be fatal.
359
360 // Each of the arguments to XERMSG is input; none will be modified by
361 // XERMSG. A routine may make multiple calls to XERMSG with warning
362 // level messages; however, after a call to XERMSG with a recoverable
363 // error, the routine should return to the user. Do not try to call
364 // XERMSG with a second recoverable error after the first recoverable
365 // error because the error package saves the error number. The user
366 // can retrieve this error number by calling another entry point_4 in
367 // the error handling package and then clear the error number when
368 // recovering from the error. Calling XERMSG in succession causes the
369 // old error number to be overwritten by the latest error number.
370 // This is considered harmless for error numbers associated with
371 // warning messages but must not be done for error numbers of serious
372 // errors. After a call to XERMSG with a recoverable error, the user
373 // must be given a chance to call NUMXER or XERLR to retrieve or
374 // clear the error number.
375 //
376
377 // Note that this stub ignores _kontrl.
378 fprintf (stderr, "** slatec ** error: %s: %s: %s\n", strlower (librar), strlower (subrou), strlower (messg));
379 errno = *nerr;
380 if (*level == 2) {
381 exit (EXIT_FAILURE);
382 }
383 return 0;
384 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
