math1/syslib/gllqnp.c

/*  -- translated by f2c (version 20100827).
   You must link the resulting object file with libf2c:
	on Microsoft Windows system, link with libf2c.lib;
	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
	or, if you install libf2c.a in a standard place, with -lf2c -lm
	-- in that order, at the end of the command line, as in
		cc *.o -lf2c -lm
	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,

		http://www.netlib.org/f2c/libf2c.zip
*/

#include "libtinyf2c.h"

/* Table of constant values */

static integer c__3 = 3;

/* ----------------------------------------------------------------------- */
/*     LOGICAL PARAMETER CONTROL */
/* ----------------------------------------------------------------------- */
/*     Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int gllqnp_0_(int n__, integer *ncp, char *cp, integer *idx,
	logical *lpara, integer *in, ftnlen cp_len)
{
    /* Initialized data */

    static char cparas[8*3] = "LMISS   " "LEPSL   " "LLMSG   ";
    static logical lx[3] = { FALSE_,FALSE_,FALSE_ };
    static char cparal[40*3] = "INTERPRET_MISSING_VALUE                 "
	    "INTERPRET_TRUNCATION                    " "ENABLE_LONG_MESSAGE "
	    "                    ";
    static logical lw[3] = { TRUE_,TRUE_,TRUE_ };
    static logical lfirst = TRUE_;

    /* System generated locals */
    address a__1[3];
    integer i__1[3];

    /* Builtin functions */
    /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
	     s_copy(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    static integer n;
    extern integer lenc_(char *, ftnlen);
    static char cmsg[80];
    extern logical lchreq_(char *, char *, ftnlen, ftnlen);
    extern /* Subroutine */ int msgdmp_(char *, char *, char *, ftnlen,
	    ftnlen, ftnlen), rllget_(char *, logical *, integer *, ftnlen),
	    rtlget_(char *, char *, logical *, integer *, ftnlen, ftnlen);

/*     / SHORT NAME / */
    switch(n__) {
	case 1: goto L_gllqid;
	case 2: goto L_gllqcp;
	case 3: goto L_gllqcl;
	case 4: goto L_gllqvl;
	case 5: goto L_gllsvl;
	case 6: goto L_gllqin;
	}

/*     / LONG NAME / */
    *ncp = 3;
    return 0;
/* ----------------------------------------------------------------------- */

L_gllqid:
    for (n = 1; n <= 3; ++n) {
	if (lchreq_(cp, cparas + (n - 1 << 3), cp_len, (ftnlen)8) || lchreq_(
		cp, cparal + (n - 1) * 40, cp_len, (ftnlen)40)) {
	    *idx = n;
	    return 0;
	}
/* L10: */
    }
/* Writing concatenation */
    i__1[0] = 11, a__1[0] = "PARAMETER '";
    i__1[1] = lenc_(cp, cp_len), a__1[1] = cp;
    i__1[2] = 17, a__1[2] = "' IS NOT DEFINED.";
    s_cat(cmsg, a__1, i__1, &c__3, (ftnlen)80);
    msgdmp_("E", "GLLQID", cmsg, (ftnlen)1, (ftnlen)6, (ftnlen)80);
    return 0;
/* ----------------------------------------------------------------------- */

L_gllqcp:
    if (1 <= *idx && *idx <= 3) {
	s_copy(cp, cparas + (*idx - 1 << 3), cp_len, (ftnlen)8);
    } else {
	msgdmp_("E", "GLLQCP", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
		ftnlen)20);
    }
    return 0;
/* ----------------------------------------------------------------------- */

L_gllqcl:
    if (1 <= *idx && *idx <= 3) {
	s_copy(cp, cparal + (*idx - 1) * 40, cp_len, (ftnlen)40);
    } else {
	msgdmp_("E", "GLLQCL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
		ftnlen)20);
    }
    return 0;
/* ----------------------------------------------------------------------- */

L_gllqvl:
    if (lfirst) {
	rtlget_("GL", cparas, lx, &c__3, (ftnlen)2, (ftnlen)8);
	rllget_(cparal, lx, &c__3, (ftnlen)40);
	lfirst = FALSE_;
    }
    if (1 <= *idx && *idx <= 3) {
	*lpara = lx[*idx - 1];
    } else {
	msgdmp_("E", "GLLQVL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
		ftnlen)20);
    }
    return 0;
/* ----------------------------------------------------------------------- */

L_gllsvl:
    if (lfirst) {
	rtlget_("GL", cparas, lx, &c__3, (ftnlen)2, (ftnlen)8);
	rllget_(cparal, lx, &c__3, (ftnlen)40);
	lfirst = FALSE_;
    }
    if (1 <= *idx && *idx <= 3) {
	if (lw[*idx - 1]) {
	    lx[*idx - 1] = *lpara;
	    return 0;
	} else {
/* Writing concatenation */
	    i__1[0] = 10, a__1[0] = "PARAMETER'";
	    i__1[1] = 8, a__1[1] = cparas + (*idx - 1 << 3);
	    i__1[2] = 16, a__1[2] = "' CANNOT BE SET.";
	    s_cat(cmsg, a__1, i__1, &c__3, (ftnlen)80);
	    msgdmp_("E", "GLLQVL", cmsg, (ftnlen)1, (ftnlen)6, (ftnlen)80);
	}
    } else {
	msgdmp_("E", "GLLQVL", "IDX IS OUT OF RANGE.", (ftnlen)1, (ftnlen)6, (
		ftnlen)20);
    }
    return 0;
/* ----------------------------------------------------------------------- */

L_gllqin:
    for (n = 1; n <= 3; ++n) {
	if (lchreq_(cp, cparas + (n - 1 << 3), cp_len, (ftnlen)8) || lchreq_(
		cp, cparal + (n - 1) * 40, cp_len, (ftnlen)40)) {
	    *in = n;
	    return 0;
	}
/* L20: */
    }
    *in = 0;
    return 0;
} /* gllqnp_ */

/* Subroutine */ int gllqnp_(integer *ncp)
{
    return gllqnp_0_(0, ncp, (char *)0, (integer *)0, (logical *)0, (integer *
	    )0, (ftnint)0);
    }

/* Subroutine */ int gllqid_(char *cp, integer *idx, ftnlen cp_len)
{
    return gllqnp_0_(1, (integer *)0, cp, idx, (logical *)0, (integer *)0,
	    cp_len);
    }

/* Subroutine */ int gllqcp_(integer *idx, char *cp, ftnlen cp_len)
{
    return gllqnp_0_(2, (integer *)0, cp, idx, (logical *)0, (integer *)0,
	    cp_len);
    }

/* Subroutine */ int gllqcl_(integer *idx, char *cp, ftnlen cp_len)
{
    return gllqnp_0_(3, (integer *)0, cp, idx, (logical *)0, (integer *)0,
	    cp_len);
    }

/* Subroutine */ int gllqvl_(integer *idx, logical *lpara)
{
    return gllqnp_0_(4, (integer *)0, (char *)0, idx, lpara, (integer *)0, (
	    ftnint)0);
    }

/* Subroutine */ int gllsvl_(integer *idx, logical *lpara)
{
    return gllqnp_0_(5, (integer *)0, (char *)0, idx, lpara, (integer *)0, (
	    ftnint)0);
    }

/* Subroutine */ int gllqin_(char *cp, integer *in, ftnlen cp_len)
{
    return gllqnp_0_(6, (integer *)0, cp, (integer *)0, (logical *)0, in,
	    cp_len);
    }