☰  Menu Navigation ‣ Home ‣ About Marcel ‣ Privacy and cookies Algol 68 Genie ‣ The Algol 68 Genie project ‣ Downloads and tutorials ‣ Code browser Blog ‣ Vintage Fortran compiler ‣ Snoopy calendar 1969-2025 ‣ Partial Least Squares Regression in Algol 68 ‣ The battle for Arnhem bridge ‣ Chemometrics algorithms in the original Latin ‣ Building a LAMP and git server ‣ …

rts-slatec.c

 //!@file rts-slatec.c
 //!@author J. Marcel van der Veer
 //
 // !@section Copyright
 //
 // This file is part of VIF - vintage FORTRAN compiler.
 // Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
 //
 //! @section License
 //
 // This program is free software; you can redistribute it and/or modify it 
 // under the terms of the GNU General Public License as published by the 
 // Free Software Foundation; either version 3 of the License, or 
 // (at your option) any later version.
 //
 // This program is distributed in the hope that it will be useful, but 
 // WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
 // or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
 // more details. You should have received a copy of the GNU General Public 
 // License along with this program. If not, see <http://www.gnu.org/licenses/>.
 
 //! @section Synopsis
 //!
 //! Runtime support for SLATEC subprograms.
 
 //!@brief SLATEC stubs for VIF, adapted to C.
 // SLATEC common mathematical library, version 4.1, July 1993.
 //
 // SLATEC was developed at US government research laboratories 
 // and is in the public domain.
 // Repository: http://www.netlib.org/slatec/
 
 #include <vif.h>
 
 // d1mach yields machine-dependent parameters for the 
 // local machine environment.
 //
 // d1mach(1) = b**(emin-1), the smallest positive magnitude. 
 // d1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude. 
 // d1mach(3) = b**(-t), the smallest relative spacing. 
 // d1mach(4) = b**(1-t), the largest relative spacing. 
 // d1mach(5) = log10(b) 
 
 real_4 _r1mach (int_4 *i)
 {
   switch (*i) {
 //    r1mach(1) = b**(emin-1), the smallest positive magnitude. 
   case 1: return FLT_MIN;
 //    r1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude. 
   case 2: return FLT_MAX;
 //    r1mach(3) = b**(-t), the smallest relative spacing. 
   case 3: return 0.5 * FLT_EPSILON;
 //    r1mach(4) = b**(1-t), the largest relative spacing. 
   case 4: return FLT_EPSILON;
 //    r1mach(5) = log10(b) 
   case 5: return M_LOG10_2;
 //
   default: return 0.0;
   }
 }
  
 real_8 _d1mach (int_4 *i)
 {
   switch (*i) {
 //    d1mach(1) = b**(emin-1), the smallest positive magnitude. 
   case 1: return DBL_MIN;
 //    d1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude. 
   case 2: return DBL_MAX;
 //    d1mach(3) = b**(-t), the smallest relative spacing. 
   case 3: return 0.5 * DBL_EPSILON;
 //    d1mach(4) = b**(1-t), the largest relative spacing. 
   case 4: return DBL_EPSILON;
 //    d1mach(5) = log10(b) 
   case 5: return M_LOG10_2;
 //
   default: return 0.0;
   }
 }
 
 real_8 _dmach (int_4 *i)
 {
   return _d1mach (i);
 }
  
 // i1mach yields machine-dependent parameters for the 
 // local machine environment.
 //
 // i/o unit numbers: 
 //  i1mach(1) = the standard input unit. 
 //  i1mach(2) = the standard output unit. 
 //  i1mach(3) = the standard punch unit. 
 //  i1mach(4) = the standard error message unit. 
 //
 // words: 
 //  i1mach(5) = the number of bits per int_4 storage unit. 
 //  i1mach(6) = the number of characters per int_4 storage unit. 
 //
 // integers: 
 //  assume int_4s are represented in the s-digit, base-a form 
 //
 //             sign (x(s-1)*a**(s-1) + ... + x(1)*a + x(0) ) 
 //
 //             where 0 .le. x(i) .lt. a for i=0,...,s-1. 
 //  i1mach(7) = a, the base. 
 //  i1mach(8) = s, the number of base-a digits. 
 //  i1mach(9) = a**s - 1, the largest magnitude. 
 //
 // floating-point_4 numbers: 
 //  assume floating-point_4 numbers are represented in the t-digit, 
 //  base-b form 
 //             sign (b**e)*((x(1)/b) + ... + (x(t)/b**t) ) 
 //
 //             where 0 .le. x(i) .lt. b for i=1,...,t, 
 //             0 .lt. x(1), and emin .le. e .le. emax. 
 //  i1mach(10) = b, the base. 
 //
 // single-precision: 
 //  i1mach(11) = t, the number of base-b digits. 
 //  i1mach(12) = emin, the smallest exponent e. 
 //  i1mach(13) = emax, the largest exponent e. 
 //
 // double-precision: 
 //  i1mach(14) = t, the number of base-b digits. 
 //  i1mach(15) = emin, the smallest exponent e. 
 //  i1mach(16) = emax, the largest exponent e. 
 
 int_4 _i1mach (int_4 *i) 
 {
   switch(*i) {
 //  i1mach(1) = the standard input unit. 
 //  i1mach(2) = the standard output unit. 
 //  i1mach(3) = the standard punch unit. 
 //  i1mach(4) = the standard error message unit. 
   case  1: return STDF_IN;
   case  2: return STDF_OUT;
   case  3: return STDF_PUN;
   case  4: return STDF_ERR;
 //  i1mach(5) = the number of bits per int_4 storage unit. 
 //  i1mach(6) = the number of characters per int_4 storage unit. 
   case  5: return CHAR_BIT * sizeof (int_4);
   case  6: return sizeof (int_4);
 //  i1mach(7) = a, the base. 
 //  i1mach(8) = s, the number of base-a digits. 
 //  i1mach(9) = a**s - 1, the largest magnitude. 
   case  7: return 2;
   case  8: return CHAR_BIT * sizeof (int_4) - 1;
   case  9: return INT_MAX;
 //  i1mach(10) = b, the base. 
   case 10: return FLT_RADIX;
 //  i1mach(11) = t, the number of base-b digits. 
 //  i1mach(12) = emin, the smallest exponent e. 
 //  i1mach(13) = emax, the largest exponent e. 
   case 11: return FLT_MANT_DIG;
   case 12: return FLT_MIN_EXP;
   case 13: return FLT_MAX_EXP;
 //  i1mach(14) = t, the number of base-b digits. 
 //  i1mach(15) = emin, the smallest exponent e. 
 //  i1mach(16) = emax, the largest exponent e. 
   case 14: return DBL_MANT_DIG;
   case 15: return DBL_MIN_EXP;
   case 16: return DBL_MAX_EXP;
 //
   default: return 0;
   }
 }
 
 // amach yields machine-dependent parameters for the local environment.
 //
 // subroutine amach(mode, i, i1, r1, d1)
 
 int_4 _amach (int_4 _p_ mode_, int_4 _p_ i_, int_4 _p_ i1_, real_4 _p_ r1_, real_8 _p_ d1_)
 {
   if (*mode_ == 0) {
     *i1_ = _i1mach(i_);
   }
   else if (*mode_ == 1) {
     *r1_ = _r1mach(i_);
   }
   else {
     *d1_ = _d1mach(i_);
   }
   return 0;
 }
 
 // SLATEC message routine stubs.
 
 int_4 _j4save (int_4 _p_ iwhich, int_4 _p_ ivalue, logical_4 _p_ iset)
 {
 // J4SAVE saves and recalls several global variables needed
 // by the library error handling routines.
 //
 // Description of Parameters
 //      --Input--
 //        IWHICH - Index of item desired.
 //                = 1 Refers to current error number.
 //                = 2 Refers to current error control flag.
 //                = 3 Refers to current unit number to which error
 //                    messages are to be sent.  (0 means use standard.)
 //                = 4 Refers to the maximum number of times any
 //                     message is to be printed (as set by XERMAX).
 //                = 5 Refers to the total number of units to which
 //                     each error message is to be written.
 //                = 6 Refers to the 2nd unit for error messages
 //                = 7 Refers to the 3rd unit for error messages
 //                = 8 Refers to the 4th unit for error messages
 //                = 9 Refers to the 5th unit for error messages
 //        IVALUE - The value to be set for the IWHICH-th parameter,
 //                 if ISET is .TRUE. .
 //        ISET   - If ISET=.TRUE., the IWHICH-th parameter will BE
 //                 given the value, IVALUE.  If ISET=.FALSE., the
 //                 IWHICH-th parameter will be unchanged, and IVALUE
 //                 is a dummy parameter.
 //      --Output--
 //        The (old) value of the IWHICH-th parameter will be returned
 //        in the function value, J4SAVE.
 //
   static int_4 iparam[9] = {0, 2, 0, 10, 1, 0, 0, 0, 0};
   int_4 curr = iparam[*iwhich - 1];
   if (*iset) {
     iparam[*iwhich - 1] = *ivalue;
   }
   return curr;
 }
 
 static int_4 __kontrl__ = 0;
 
 int_4 _xerclr (void)
 {
 // This routine simply resets the current error number to zero.
 // This may be necessary in order to determine that a certain
 // error has occurred again since the last time NUMXER was
 // referenced.
   errno = 0;
   return 0;
 }
 
 int_4 _xerdmp (void)
 {
 // XERDMP prints the error tables, then clears them.
   return EXIT_SUCCESS;
 }
 
 int_4 _xermax (int_4 _p_ _max)
 {
 // XERMAX sets the maximum number of times any message is to be printed.
 // That is, non-fatal messages are not to be printed after they have occurred 
 // MAX times. Such non-fatal messages may be printed less than MAX times even
 // if they occur MAX times, if error suppression mode (KONTRL=0) is ever in 
 // MAX - the maximum number of times any one message is to be printed.
   (void) _max;
   return EXIT_SUCCESS;
 }
 
 int_4 _xgetf (int_4 _p_ kontrl)
 {
 // XGETF returns the current value of the error control flag
 // in KONTRL.  See subroutine XSETF for flag value meanings.
 // (KONTRL is an output parameter only.)
 //
   *kontrl = __kontrl__;
   return EXIT_SUCCESS;
 }
 
 int_4 _xsetf (int_4 _p_ kontrl)
 {
 // XSETF sets the error control flag value to KONTRL.
 // (KONTRL is an input parameter only.)
 // The following table shows how each message is treated,
 // depending on the values of KONTRL and LEVEL.  (See XERMSG
 // for description of LEVEL.)
 
 // If KONTRL is zero or negative, no information other than the
 // message itself (including numeric values, if any) will be
 // printed.  If KONTRL is positive, introductory messages,
 // trace-backs, etc., will be printed in addition to the message.
 
 //   ABS(KONTRL)
 // LEVEL        0              1              2
 // value
 //  2        fatal          fatal          fatal
 
 //  1     not printed      printed         fatal
 
 //  0     not printed      printed        printed
 
 // -1     not printed      printed        printed
 //                       only           only
 //                       once           once
   __kontrl__ = *kontrl;
   return 0;
 }
 
 int_4 _xgetun (int_4 _p_ iunit)
 {
 // XGETUN gets the (first) output file to which error messages
 // are being sent.  To find out if more than one file is being
 // used, one must use the XGETUA routine.
   (void) iunit;
   return EXIT_SUCCESS;
 }
 
 
 int_4 xsetun (int_4 _p_ iunit)
 {
 // XSETUN sets the output file to which error messages are to
 // be sent.  Only one file will be used.  See XSETUA for
 // how to declare more than one file.
   (void) iunit;
   return EXIT_SUCCESS;
 }
 
 int_4 xsetua (int_4 _p_ iunita, int_4 _p_ n)
 {
 // XSETUA may be called to declare a list of up to five
 // logical units, each of which is to receive a copy of
 // each error message processed by this package.
 // The purpose of XSETUA is to allow simultaneous printing
 // of each error message on, say, a main output file,
 // an interactive terminal, and other files such as graphics
 // communication files.
   (void) iunita;
   (void) n;
   return EXIT_SUCCESS;
 }
 
 int_4 _xgetua (int_4 _p_ iunita, int_4 _p_ n)
 {
 // XGETUA may be called to determine the unit number or numbers
 // to which error messages are being sent.
 // These unit numbers may have been set by a call to XSETUN,
 // or a call to XSETUA, or may be a default value.
   (void) iunita;
   (void) n;
   return EXIT_SUCCESS;
 }
 
 int_4 _xerprn (char _p_ prefix_, int_4 _p_ npref_, char _p_ messg_, int_4 _p_ nwrap_)
 {
 // This routine sends one or more lines to each of the (up to five)
 // logical units to which error messages are to be sent.  This routine
 // is called several times by XERMSG, sometimes with a single line to
 // print and sometimes with a (potentially very long) message that may
 // wrap around into multiple lines.
 //
 // PREFIX  Input argument of type CHARACTER.  This argument contains
 //         characters to be put at the beginning of each line before
 //         the body of the message.  No more than 16 characters of
 //         PREFIX will be used.
 //
 // NPREF   Input argument of type INTEGER.  This argument is the number
 //         of characters to use from PREFIX.  If it is negative, the
 //         intrinsic function LEN is used to determine its length.  If
 //         it is zero, PREFIX is not used.  If it exceeds 16 or if
 //         LEN(PREFIX) exceeds 16, only the first 16 characters will be
 //         used.  If NPREF is positive and the length of PREFIX is less
 //         than NPREF, a copy of PREFIX extended with blanks to length
 //         NPREF will be used.
 //
 // MESSG   Input argument of type CHARACTER.  This is the text of a
 //         message to be printed.  If it is a long message, it will be
 //         broken into pieces for printing on multiple lines.  Each line
 //         will start with the appropriate prefix and be followed by a
 //         piece of the message.  NWRAP is the number of characters per
 //         piece; that is, after each NWRAP characters, we break and
 //         start a new line.  In addition the characters '$$' embedded
 //         in MESSG are a sentinel for a new line.  The counting of
 //         characters up to NWRAP starts over for each new line.  The
 //         value of NWRAP typically used by XERMSG is 72 since many
 //         older error messages in the SLATEC Library are laid out to
 //         rely on wrap-around every 72 characters.
 //
 // NWRAP   Input argument of type INTEGER.  This gives the maximum size
 //         piece into which to break MESSG for printing on multiple
 //         lines.  An embedded '$$' ends a line, and the count restarts
 //         at the following character.  If a line break does not occur
 //         on a blank (it would split a word) that word is moved to the
 //         next line.  Values of NWRAP less than 16 will be treated as
 //         16.  Values of NWRAP greater than 132 will be treated as 132.
 //         The actual line length will be NPREF + NWRAP after NPREF has
 //         been adjusted to fall between 0 and 16 and NWRAP has been
 //         adjusted to fall between 16 and 132.
   (void) prefix_;
   (void) npref_;
   (void) messg_;
   (void) nwrap_;
   return EXIT_SUCCESS;
 }
 
 int_4 _xersve (char _p_ librar_, char _p_ subrou_, char _p_ messg_, int_4 _p_ kflag_, int_4 _p_ nerr_, int_4 _p_ level_, int_4 _p_ icount_)
 {
 // Record that an error has occurred and possibly dump and clear the tables.
   (void) librar_;
   (void) subrou_;
   (void) messg_;
   (void) kflag_;
   (void) nerr_;
   (void) level_;
   (void) icount_;
   return EXIT_SUCCESS;
 }
 
 int_4 _xermsg (char _p_ librar, char _p_ subrou, char _p_ messg, int_4 _p_ nerr, int_4 _p_ level)
 {
 // XERMSG processes a diagnostic message in a manner determined by the
 // value of LEVEL and the current value of the library error control
 // flag, KONTRL.  See subroutine XSETF for details.
 
 // LIBRAR   A character constant (or character variable) with the name
 //       of the library.  This will be 'SLATE' for the SLATEC
 //       ommon Math Library.  The error handling package is
 //       general enough to be used by many libraries
 //       simultaneously, so it is desirable for the routine that
 //       detects and reports an error to identify the library name
 //       as well as the routine name.
 
 // SUBROU   A character constant (or character variable) with the name
 //       of the routine that detected the error.  Usually it is the
 //       name of the routine that is calling XERMSG.  There are
 //       some instances where a user callable library routine calls
 //       lower level subsidiary routines where the error is
 //       detected.  In such cases it may be more informative to
 //       supply the name of the routine the user called rather than
 //       the name of the subsidiary routine that detected the
 //       error.
 
 // MESSG    A character constant (or character variable) with the text
 //       of the error or warning message.  In the example below,
 //       the message is a character constant that contains a
 //       generic message.
 
 //             ALL XERMSG ('SLATEC', 'MMPY',
 //            *'THE ORDER OF THE MATRIX EXEEDS THE ROW DIMENSION',
 //            *3, 1)
 
 //       It is possible (and is sometimes desirable) to generate a
 //       specific message--e.g., one that contains actual numeric
 //       values.  Specific numeric values can be converted into
 //       character strings using formatted WRITE statements into
 //       character variables.  This is called standard Fortran
 //       internal file I/O and is exemplified in the first three
 //       lines of the following example.  You can also catenate
 //       substrings of characters to construct the error message.
 //       Here is an example showing the use of both writing to
 //       an internal file and catenating character strings.
 
 //             CHARACTER*5 CHARN, CHARL
 //             WRITE (HARN,10) N
 //             WRITE (HARL,10) LDA
 //          10 FORMAT(I5)
 //             ALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
 //            *   ' OF THE MATRIX EXEEDS ITS ROW DIMENSION OF'//
 //            *   HARL, 3, 1)
 
 //       There are two subtleties worth mentioning.  One is that
 //       the // for character catenation is used to construct the
 //       error message so that no single character constant is
 //       continued to the next line.  This avoids confusion as to
 //       whether there are trailing blanks at the end of the line.
 //       The second is that by catenating the parts of the message
 //       as an actual argument rather than encoding the entire
 //       message into one large character variable, we avoid
 //       having to know how long the message will be in order to
 //       declare an adequate length for that large character
 //       variable.  XERMSG calls XERPRN to print_4 the message using
 //       multiple lines if necessary.  If the message is very long,
 //       XERPRN will break it into pieces of 72 characters (as
 //       requested by XERMSG) for printing on multiple lines.
 //       Also, XERMSG asks XERPRN to prefix each line with ' *  '
 //       so that the total line length could be 76 characters.
 //       Note also that XERPRN scans the error message backwards
 //       to ignore trailing blanks.  Another feature is that
 //       the substring '$$' is treated as a new line sentinel
 //       by XERPRN.  If you want to construct a multiline
 //       message without having to count out multiples of 72
 //       characters, just use '$$' as a separator.  '$$'
 //       obviously must occur within 72 characters of the
 //       start of each line to have its intended effect since
 //       XERPRN is asked to wrap around at 72 characters in
 //       addition to looking for '$$'.
 
 // NERR     An integer value that is chosen by the library routine's
 //       author.  It must be in the range -99 to 999 (three
 //       printable digits).  Each distinct error should have its
 //       own error number.  These error numbers should be described
 //       in the machine readable documentation for the routine.
 //       The error numbers need be unique only within each routine,
 //       so it is reasonable for each routine to start enumerating
 //       errors from 1 and proceeding to the next integer.
 
 // LEVEL    An integer value in the range 0 to 2 that indicates the
 //       level (severity) of the error.  Their meanings are
 
 //      -1  A warning message.  This is used if it is not clear
 //          that there really is an error, but the user's attention
 //          may be needed.  An attempt is made to only print_4 this
 //          message once.
 
 //       0  A warning message.  This is used if it is not clear
 //          that there really is an error, but the user's attention
 //          may be needed.
 
 //       1  A recoverable error.  This is used even if the error is
 //          so serious that the routine cannot return any useful
 //          answer.  If the user has told the error package to
 //          return after recoverable errors, then XERMSG will
 //          return to the Library routine which can then return to
 //          the user's routine.  The user may also permit the error
 //          package to terminate the program upon encountering a
 //          recoverable error.
 
 //       2  A fatal error.  XERMSG will not return to its caller
 //          after it receives a fatal error.  This level should
 //          hardly ever be used; it is much better to allow the
 //          user a chance to recover.  An example of one of the few
 //          cases in which it is permissible to declare a level 2
 //          error is a reverse communication Library routine that
 //          is likely to be called repeatedly until it integrates
 //          across some interval.  If there is a serious error in
 //          the input such that another step cannot be taken and
 //          the Library routine is called again without the input
 //          error having been corrected by the caller, the Library
 //          routine will probably be called forever with improper
 //          input.  In this case, it is reasonable to declare the
 //          error to be fatal.
 
 // Each of the arguments to XERMSG is input; none will be modified by
 // XERMSG.  A routine may make multiple calls to XERMSG with warning
 // level messages; however, after a call to XERMSG with a recoverable
 // error, the routine should return to the user.  Do not try to call
 // XERMSG with a second recoverable error after the first recoverable
 // error because the error package saves the error number.  The user
 // can retrieve this error number by calling another entry point_4 in
 // the error handling package and then clear the error number when
 // recovering from the error. Calling XERMSG in succession causes the
 // old error number to be overwritten by the latest error number.
 // This is considered harmless for error numbers associated with
 // warning messages but must not be done for error numbers of serious
 // errors.  After a call to XERMSG with a recoverable error, the user
 // must be given a chance to call NUMXER or XERLR to retrieve or
 // clear the error number.
 //
 
 // Note that this stub ignores __kontrl__.
   fprintf (stderr, "** slatec     ** error: %s: %s: %s\n", _strlower (librar), _strlower (subrou), _strlower (messg));  
   errno = *nerr;
   if (*level == 2) {
     exit (EXIT_FAILURE);
   }
   return EXIT_FAILURE;
 }
 
 int_4 _xerbla(char _p_ srname, int_4 _p_ info)
 {
 //  XERBLA is called by Level 2 and 3 BLAS routines if an input parameter
 //  is invalid.
 //
 //  Parameters
 //  ==========
 //
 //  SRNAME - CHARACTER*6.
 //           On entry, SRNAME specifies the name of the routine which
 //           called XERBLA.
 //
 //  INFO   - INTEGER.
 //           On entry, INFO specifies the position of the invalid
 //           parameter in the parameter-list of the calling routine.
 //
     RECORD msg;
     _srecordf (msg, "** blas       ** %6s: invalid parameter #%2d\n", srname, *info);
     RTE ("xerbla", msg);
     return EXIT_FAILURE;
 }
 
 int_4 _xerabt(char _p_ msg, int_4 _p_ nmessg)
 {
 //
 //     Latest revision  -  January 24, 1990 (JRD)
 //
 //     ABSTRACT
 //        ***NOTE*** Machine dependent routine
 //        XERABT aborts the execution of the program.
 //        The error message causing the abort is given in the calling
 //        sequence in case one needs it for printing on a dayfile,
 //        for example.
 //
 //     DESCRIPTION OF PARAMETERS
 //        MESSG and NMESSG are as in xerror, except that nmessg may
 //        be zero, in which case no message is being supplied.
 //
 //     Written by Ron Jones, with SLATEC Common Math Library subcommittee
 //     latest revision ---  7 June 1978
 //
    if (*nmessg != 0) {
      RTE (NO_TEXT, msg); // Does not return.
    } else {
      RTE (NO_TEXT, NO_TEXT); // Does not return.
    }
    return EXIT_FAILURE;
 }
 

Deze website is gearchiveerd door de KB, nationale bibliotheek. This website is archived by the National Library of the Netherlands.