345 lines
11 KiB
C
345 lines
11 KiB
C
/* daux.f -- translated by f2c (version 20030320).
|
|
You must link the resulting object file with the libraries:
|
|
-lf2c -lm (in that order)
|
|
*/
|
|
|
|
#include "f2c.h"
|
|
|
|
/* Table of constant values */
|
|
|
|
static integer c__1 = 1;
|
|
static integer c__0 = 0;
|
|
static logical c_false = FALSE_;
|
|
static integer c__2 = 2;
|
|
static logical c_true = TRUE_;
|
|
|
|
/* DOUBLE PRECISION FUNCTION D1MACH (IDUM) */
|
|
/* INTEGER IDUM */
|
|
/* C----------------------------------------------------------------------- */
|
|
/* C THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE */
|
|
/* C PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER */
|
|
/* C U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION). */
|
|
/* C----------------------------------------------------------------------- */
|
|
/* DOUBLE PRECISION U, COMP */
|
|
/* U = 1.0D0 */
|
|
/* 10 U = U*0.5D0 */
|
|
/* COMP = 1.0D0 + U */
|
|
/* IF (COMP .NE. 1.0D0) GO TO 10 */
|
|
/* D1MACH = U*2.0D0 */
|
|
/* RETURN */
|
|
/* C----------------------- END OF FUNCTION D1MACH ------------------------ */
|
|
/* END */
|
|
/* DECK XERRWD */
|
|
/* Subroutine */ int xerrwd_(char *msg, integer *nmes, integer *nerr, integer
|
|
*level, integer *ni, integer *i1, integer *i2, integer *nr,
|
|
doublereal *r1, doublereal *r2, ftnlen msg_len)
|
|
{
|
|
/* Format strings */
|
|
static char fmt_10[] = "(1x,a)";
|
|
static char fmt_20[] = "(6x,\002In above message, I1 =\002,i10)";
|
|
static char fmt_30[] = "(6x,\002In above message, I1 =\002,i10,3x,\002I"
|
|
"2 =\002,i10)";
|
|
static char fmt_40[] = "(6x,\002In above message, R1 =\002,d21.13)";
|
|
static char fmt_50[] = "(6x,\002In above, R1 =\002,d21.13,3x,\002R2 "
|
|
"=\002,d21.13)";
|
|
|
|
/* Builtin functions */
|
|
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
|
|
/* Subroutine */ int s_stop(char *, ftnlen);
|
|
|
|
/* Local variables */
|
|
extern integer ixsav_(integer *, integer *, logical *);
|
|
integer lunit, mesflg;
|
|
|
|
/* Fortran I/O blocks */
|
|
static cilist io___3 = { 0, 0, 0, fmt_10, 0 };
|
|
static cilist io___4 = { 0, 0, 0, fmt_20, 0 };
|
|
static cilist io___5 = { 0, 0, 0, fmt_30, 0 };
|
|
static cilist io___6 = { 0, 0, 0, fmt_40, 0 };
|
|
static cilist io___7 = { 0, 0, 0, fmt_50, 0 };
|
|
|
|
|
|
/* ***BEGIN PROLOGUE XERRWD */
|
|
/* ***SUBSIDIARY */
|
|
/* ***PURPOSE Write error message with values. */
|
|
/* ***LIBRARY MATHLIB */
|
|
/* ***CATEGORY R3C */
|
|
/* ***TYPE DOUBLE PRECISION (XERRWV-S, XERRWD-D) */
|
|
/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */
|
|
/* ***DESCRIPTION */
|
|
|
|
/* Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV, */
|
|
/* as given here, constitute a simplified version of the SLATEC error */
|
|
/* handling package. */
|
|
|
|
/* All arguments are input arguments. */
|
|
|
|
/* MSG = The message (character array). */
|
|
/* NMES = The length of MSG (number of characters). */
|
|
/* NERR = The error number (not used). */
|
|
/* LEVEL = The error level.. */
|
|
/* 0 or 1 means recoverable (control returns to caller). */
|
|
/* 2 means fatal (run is aborted--see note below). */
|
|
/* NI = Number of integers (0, 1, or 2) to be printed with message. */
|
|
/* I1,I2 = Integers to be printed, depending on NI. */
|
|
/* NR = Number of reals (0, 1, or 2) to be printed with message. */
|
|
/* R1,R2 = Reals to be printed, depending on NR. */
|
|
|
|
/* Note.. this routine is machine-dependent and specialized for use */
|
|
/* in limited context, in the following ways.. */
|
|
/* 1. The argument MSG is assumed to be of type CHARACTER, and */
|
|
/* the message is printed with a format of (1X,A). */
|
|
/* 2. The message is assumed to take only one line. */
|
|
/* Multi-line messages are generated by repeated calls. */
|
|
/* 3. If LEVEL = 2, control passes to the statement STOP */
|
|
/* to abort the run. This statement may be machine-dependent. */
|
|
/* 4. R1 and R2 are assumed to be in double precision and are printed */
|
|
/* in D21.13 format. */
|
|
|
|
/* ***ROUTINES CALLED IXSAV */
|
|
/* ***REVISION HISTORY (YYMMDD) */
|
|
/* 920831 DATE WRITTEN */
|
|
/* 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH) */
|
|
/* 930329 Modified prologue to SLATEC format. (FNF) */
|
|
/* 930407 Changed MSG from CHARACTER*1 array to variable. (FNF) */
|
|
/* 930922 Minor cosmetic change. (FNF) */
|
|
/* ***END PROLOGUE XERRWD */
|
|
|
|
/* *Internal Notes: */
|
|
|
|
/* For a different default logical unit number, IXSAV (or a subsidiary */
|
|
/* routine that it calls) will need to be modified. */
|
|
/* For a different run-abort command, change the statement following */
|
|
/* statement 100 at the end. */
|
|
/* ----------------------------------------------------------------------- */
|
|
/* Subroutines called by XERRWD.. None */
|
|
/* Function routine called by XERRWD.. IXSAV */
|
|
/* ----------------------------------------------------------------------- */
|
|
/* **End */
|
|
|
|
/* Declare arguments. */
|
|
|
|
|
|
/* Declare local variables. */
|
|
|
|
|
|
/* Get logical unit number and message print flag. */
|
|
|
|
/* ***FIRST EXECUTABLE STATEMENT XERRWD */
|
|
lunit = ixsav_(&c__1, &c__0, &c_false);
|
|
mesflg = ixsav_(&c__2, &c__0, &c_false);
|
|
if (mesflg == 0) {
|
|
goto L100;
|
|
}
|
|
|
|
/* Write the message. */
|
|
|
|
io___3.ciunit = lunit;
|
|
s_wsfe(&io___3);
|
|
do_fio(&c__1, msg, msg_len);
|
|
e_wsfe();
|
|
if (*ni == 1) {
|
|
io___4.ciunit = lunit;
|
|
s_wsfe(&io___4);
|
|
do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer));
|
|
e_wsfe();
|
|
}
|
|
if (*ni == 2) {
|
|
io___5.ciunit = lunit;
|
|
s_wsfe(&io___5);
|
|
do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer));
|
|
do_fio(&c__1, (char *)&(*i2), (ftnlen)sizeof(integer));
|
|
e_wsfe();
|
|
}
|
|
if (*nr == 1) {
|
|
io___6.ciunit = lunit;
|
|
s_wsfe(&io___6);
|
|
do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal));
|
|
e_wsfe();
|
|
}
|
|
if (*nr == 2) {
|
|
io___7.ciunit = lunit;
|
|
s_wsfe(&io___7);
|
|
do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal));
|
|
do_fio(&c__1, (char *)&(*r2), (ftnlen)sizeof(doublereal));
|
|
e_wsfe();
|
|
}
|
|
|
|
/* Abort the run if LEVEL = 2. */
|
|
|
|
L100:
|
|
if (*level != 2) {
|
|
return 0;
|
|
}
|
|
s_stop("", (ftnlen)0);
|
|
/* ----------------------- End of Subroutine XERRWD ---------------------- */
|
|
return 0;
|
|
} /* xerrwd_ */
|
|
|
|
/* DECK XSETF */
|
|
/* Subroutine */ int xsetf_(integer *mflag)
|
|
{
|
|
integer junk;
|
|
extern integer ixsav_(integer *, integer *, logical *);
|
|
|
|
/* ***BEGIN PROLOGUE XSETF */
|
|
/* ***PURPOSE Reset the error print control flag. */
|
|
/* ***LIBRARY MATHLIB */
|
|
/* ***CATEGORY R3A */
|
|
/* ***TYPE ALL (XSETF-A) */
|
|
/* ***KEYWORDS ERROR CONTROL */
|
|
/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */
|
|
/* ***DESCRIPTION */
|
|
|
|
/* XSETF sets the error print control flag to MFLAG: */
|
|
/* MFLAG=1 means print all messages (the default). */
|
|
/* MFLAG=0 means no printing. */
|
|
|
|
/* ***SEE ALSO XERMSG, XERRWD, XERRWV */
|
|
/* ***REFERENCES (NONE) */
|
|
/* ***ROUTINES CALLED IXSAV */
|
|
/* ***REVISION HISTORY (YYMMDD) */
|
|
/* 921118 DATE WRITTEN */
|
|
/* 930329 Added SLATEC format prologue. (FNF) */
|
|
/* 930407 Corrected SEE ALSO section. (FNF) */
|
|
/* 930922 Made user-callable, and other cosmetic changes. (FNF) */
|
|
/* ***END PROLOGUE XSETF */
|
|
|
|
/* Subroutines called by XSETF.. None */
|
|
/* Function routine called by XSETF.. IXSAV */
|
|
/* ----------------------------------------------------------------------- */
|
|
/* **End */
|
|
|
|
/* ***FIRST EXECUTABLE STATEMENT XSETF */
|
|
if (*mflag == 0 || *mflag == 1) {
|
|
junk = ixsav_(&c__2, mflag, &c_true);
|
|
}
|
|
return 0;
|
|
/* ----------------------- End of Subroutine XSETF ----------------------- */
|
|
} /* xsetf_ */
|
|
|
|
/* DECK XSETUN */
|
|
/* Subroutine */ int xsetun_(integer *lun)
|
|
{
|
|
integer junk;
|
|
extern integer ixsav_(integer *, integer *, logical *);
|
|
|
|
/* ***BEGIN PROLOGUE XSETUN */
|
|
/* ***PURPOSE Reset the logical unit number for error messages. */
|
|
/* ***LIBRARY MATHLIB */
|
|
/* ***CATEGORY R3B */
|
|
/* ***TYPE ALL (XSETUN-A) */
|
|
/* ***KEYWORDS ERROR CONTROL */
|
|
/* ***DESCRIPTION */
|
|
|
|
/* XSETUN sets the logical unit number for error messages to LUN. */
|
|
|
|
/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */
|
|
/* ***SEE ALSO XERMSG, XERRWD, XERRWV */
|
|
/* ***REFERENCES (NONE) */
|
|
/* ***ROUTINES CALLED IXSAV */
|
|
/* ***REVISION HISTORY (YYMMDD) */
|
|
/* 921118 DATE WRITTEN */
|
|
/* 930329 Added SLATEC format prologue. (FNF) */
|
|
/* 930407 Corrected SEE ALSO section. (FNF) */
|
|
/* 930922 Made user-callable, and other cosmetic changes. (FNF) */
|
|
/* ***END PROLOGUE XSETUN */
|
|
|
|
/* Subroutines called by XSETUN.. None */
|
|
/* Function routine called by XSETUN.. IXSAV */
|
|
/* ----------------------------------------------------------------------- */
|
|
/* **End */
|
|
|
|
/* ***FIRST EXECUTABLE STATEMENT XSETUN */
|
|
if (*lun > 0) {
|
|
junk = ixsav_(&c__1, lun, &c_true);
|
|
}
|
|
return 0;
|
|
/* ----------------------- End of Subroutine XSETUN ---------------------- */
|
|
} /* xsetun_ */
|
|
|
|
/* DECK IXSAV */
|
|
integer ixsav_(integer *ipar, integer *ivalue, logical *iset)
|
|
{
|
|
/* System generated locals */
|
|
integer ret_val;
|
|
|
|
/* Local variables */
|
|
integer lunit, lundef, mesflg;
|
|
|
|
/* ***BEGIN PROLOGUE IXSAV */
|
|
/* ***SUBSIDIARY */
|
|
/* ***PURPOSE Save and recall error message control parameters. */
|
|
/* ***LIBRARY MATHLIB */
|
|
/* ***CATEGORY R3C */
|
|
/* ***TYPE ALL (IXSAV-A) */
|
|
/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */
|
|
/* ***DESCRIPTION */
|
|
|
|
/* IXSAV saves and recalls one of two error message parameters: */
|
|
/* LUNIT, the logical unit number to which messages are printed, and */
|
|
/* MESFLG, the message print flag. */
|
|
/* This is a modification of the SLATEC library routine J4SAVE. */
|
|
|
|
/* Saved local variables.. */
|
|
/* LUNIT = Logical unit number for messages. */
|
|
/* LUNDEF = Default logical unit number, data-loaded to 6 below */
|
|
/* (may be machine-dependent). */
|
|
/* MESFLG = Print control flag.. */
|
|
/* 1 means print all messages (the default). */
|
|
/* 0 means no printing. */
|
|
|
|
/* On input.. */
|
|
/* IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG). */
|
|
/* IVALUE = The value to be set for the parameter, if ISET = .TRUE. */
|
|
/* ISET = Logical flag to indicate whether to read or write. */
|
|
/* If ISET = .TRUE., the parameter will be given */
|
|
/* the value IVALUE. If ISET = .FALSE., the parameter */
|
|
/* will be unchanged, and IVALUE is a dummy argument. */
|
|
|
|
/* On return.. */
|
|
/* IXSAV = The (old) value of the parameter. */
|
|
|
|
/* ***SEE ALSO XERMSG, XERRWD, XERRWV */
|
|
/* ***ROUTINES CALLED NONE */
|
|
/* ***REVISION HISTORY (YYMMDD) */
|
|
/* 921118 DATE WRITTEN */
|
|
/* 930329 Modified prologue to SLATEC format. (FNF) */
|
|
/* 941025 Minor modification re default unit number. (ACH) */
|
|
/* ***END PROLOGUE IXSAV */
|
|
|
|
/* **End */
|
|
/* ----------------------------------------------------------------------- */
|
|
/* ----------------------------------------------------------------------- */
|
|
/* The following Fortran-77 declaration is to cause the values of the */
|
|
/* listed (local) variables to be saved between calls to this routine. */
|
|
/* ----------------------------------------------------------------------- */
|
|
/* SAVE LUNIT, LUNDEF, MESFLG */
|
|
/* dgg mod 2/2007 */
|
|
lunit = -1;
|
|
lundef = 6;
|
|
mesflg = 1;
|
|
/* DATA LUNIT/-1/, LUNDEF/6/, MESFLG/1/ */
|
|
|
|
/* ***FIRST EXECUTABLE STATEMENT IXSAV */
|
|
if (*ipar == 1) {
|
|
if (lunit == -1) {
|
|
lunit = lundef;
|
|
}
|
|
ret_val = lunit;
|
|
if (*iset) {
|
|
lunit = *ivalue;
|
|
}
|
|
}
|
|
|
|
if (*ipar == 2) {
|
|
ret_val = mesflg;
|
|
if (*iset) {
|
|
mesflg = *ivalue;
|
|
}
|
|
}
|
|
|
|
return ret_val;
|
|
/* ----------------------- End of Function IXSAV ------------------------- */
|
|
} /* ixsav_ */
|
|
|