//!@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;
}

// REAL*4 subprograms

real_4 _sinh (real_4 _p_ x)
{
  return sinhf (*x);
}

real_4 _cosh (real_4 _p_ x)
{
  return coshf (*x);
}

real_4 _tanh (real_4 _p_ x)
{
  return tanhf (*x);
}

real_4 _asinh (real_4 _p_ x)
{
  return asinhf (*x);
}

real_4 _acosh (real_4 _p_ x)
{
  return acoshf (*x);
}

real_4 _atanh (real_4 _p_ x)
{
  return atanhf (*x);
}

real_4 _alngam (real_4 _p_ x)
{
  return lgammaf (*x);
}

real_4 _gamma (real_4 _p_ x)
{
  return tgammaf (*x);
}

real_4 _erfc (real_4 _p_ x)
{
  return erfcf (*x);
}

real_4 _erf (real_4 _p_ x)
{
  return erff (*x);
}

// REAL*8 subprograms

real_8 _derf (real_8 _p_ x)
{
  return erf (*x);
}

real_8 _derfc (real_8 _p_ x)
{
  return erfc (*x);
}

real_8 _dgamma (real_8 _p_ x)
{
  return tgamma (*x);
}

real_8 _dlngam (real_8 _p_ x)
{
  return lgamma (*x);
}

real_8 _dsinh (real_8 _p_ x)
{
  return sinh (*x);
}

real_8 _dcosh (real_8 _p_ x)
{
  return cosh (*x);
}

real_8 _dtanh (real_8 _p_ x)
{
  return tanh (*x);
}

real_8 _dasinh (real_8 _p_ x)
{
  return asinh (*x);
}

real_8 _dacosh (real_8 _p_ x)
{
  return acosh (*x);
}

real_8 _datanh (real_8 _p_ x)
{
  return atanh (*x);
}

