integer nv3optmsat_(integer *ifunc, real *xin, real *xout)
{
/* System generated locals */
integer ret_val;
char ch__1[4];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Character */ VOID clit_(char *, ftnlen, integer *);
static char cfunc[4];
/* Parameter adjustments */
--xout;
--xin;
/* Function Body */
clit_(ch__1, (ftnlen)4, ifunc);
s_copy(cfunc, ch__1, (ftnlen)4, (ftnlen)4);
ret_val = 0;
if (s_cmp(cfunc, "SPOS", (ftnlen)4, (ftnlen)4) == 0) {
xout[1] = 0.f;
xout[2] = polyxxmsatnv3_1.sublon;
} else if (s_cmp(cfunc, "HGT ", (ftnlen)4, (ftnlen)4) == 0) {
metxxxmsatnv3_1.re = xin[1] + 6378.155f;
metxxxmsatnv3_1.a = .0033670033670033669f;
metxxxmsatnv3_1.rp = metxxxmsatnv3_1.re / (metxxxmsatnv3_1.a + 1.f);
} else {
ret_val = 1;
}
return ret_val;
} /* nv3optmsat_ */
integer nv2optrect_(integer *ifunc, real *xin, real *xout)
{
/* System generated locals */
integer ret_val;
char ch__1[4];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Character */ VOID clit_(char *, ftnlen, integer *);
static char cfunc[4];
extern /* Subroutine */ int llobl_(real *, real *);
/* Parameter adjustments */
--xout;
--xin;
/* Function Body */
clit_(ch__1, (ftnlen)4, ifunc);
s_copy(cfunc, ch__1, (ftnlen)4, (ftnlen)4);
ret_val = 0;
if (s_cmp(cfunc, "SPOS", (ftnlen)4, (ftnlen)4) == 0) {
xout[1] = rctcomrectnv2_1.zslat;
xout[2] = rctcomrectnv2_1.zslon;
} else if (s_cmp(cfunc, "ORAD", (ftnlen)4, (ftnlen)4) == 0) {
llobl_(&xin[1], &xout[1]);
} else {
ret_val = 1;
}
return ret_val;
} /* nv2optrect_ */
integer nv2optmsgt_(integer *ifunc, real *xin, real *xout)
{
/* System generated locals */
integer ret_val;
char ch__1[4];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Character */ VOID clit_(char *, ftnlen, integer *);
static char cfunc[4];
/* Parameter adjustments */
--xout;
--xin;
/* Function Body */
ret_val = 0;
clit_(ch__1, (ftnlen)4, ifunc);
s_copy(cfunc, ch__1, (ftnlen)4, (ftnlen)4);
if (s_cmp(cfunc, "SPOS", (ftnlen)4, (ftnlen)4) == 0) {
xout[1] = 0.f;
xout[2] = 0.f;
} else {
ret_val = -1;
}
return ret_val;
} /* nv2optmsgt_ */
/* Subroutine */ int timer_(char *a, ftnlen a_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
doublereal d__1, d__2;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *,
ftnlen, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_wsfe(void);
/* Local variables */
static doublereal t0, t1, t2;
extern doublereal second_(void);
/* Fortran I/O blocks */
static cilist io___5 = { 0, 6, 0, "(2X,A,A,F7.2,A,F8.2)", 0 };
static cilist io___6 = { 0, 6, 0, "(40X,'TIME LOST:',F7.2)", 0 };
if (first) {
/* DEFINE THE ZERO OF TIME */
t0 = second_();
t1 = t0;
first = FALSE_;
}
/* THE ACT OF CALLING THIS ROUTINE COSTS 0.026 SECONDS */
t0 += .026;
t2 = second_();
if (i_indx(a, "BEF", a_len, (ftnlen)3) == 0 && s_cmp(a, " ", a_len, (
ftnlen)1) != 0) {
s_wsfe(&io___5);
do_fio(&c__1, a, a_len);
do_fio(&c__1, " INTERVAL:", (ftnlen)10);
d__1 = t2 - t1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, " INTEGRAL:", (ftnlen)10);
d__2 = t2 - t0;
do_fio(&c__1, (char *)&d__2, (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
s_wsfe(&io___6);
d__1 = t2 - t1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
}
t1 = t2 + .026;
return 0;
} /* timer_ */
integer nv2optps_(integer *ifunc, real *xin, real *xout)
{
/* Initialized data */
static real rad = .01745329f;
/* System generated locals */
integer ret_val;
char ch__1[4];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Character */ VOID clit_(char *, ftnlen, integer *);
static char cfunc[4];
extern /* Subroutine */ int llobl_(real *, real *);
/* Parameter adjustments */
--xout;
--xin;
/* Function Body */
clit_(ch__1, (ftnlen)4, ifunc);
s_copy(cfunc, ch__1, (ftnlen)4, (ftnlen)4);
ret_val = 0;
if (s_cmp(cfunc, "SPOS", (ftnlen)4, (ftnlen)4) == 0) {
xout[1] = pscompsnv2_1.xpole - pscompsnv2_1.xlat1 / rad;
xout[2] = pscompsnv2_1.xqlon;
} else if (s_cmp(cfunc, "ORAD", (ftnlen)4, (ftnlen)4) == 0) {
llobl_(&xin[1], &xout[1]);
} else {
ret_val = 1;
}
return ret_val;
} /* nv2optps_ */
integer nv2optgmsx_(integer *ifunc, real *xin, real *xout)
{
/* System generated locals */
integer ret_val;
char ch__1[4];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int sublatlon_(real *);
extern /* Character */ VOID clit_(char *, ftnlen, integer *);
static char cfunc[4];
extern /* Subroutine */ int sdest_(char *, integer *, ftnlen);
/* Parameter adjustments */
--xout;
--xin;
/* Function Body */
clit_(ch__1, (ftnlen)4, ifunc);
s_copy(cfunc, ch__1, (ftnlen)4, (ftnlen)4);
ret_val = 0;
if (s_cmp(cfunc, "SPOS", (ftnlen)4, (ftnlen)4) == 0) {
sublatlon_(&xout[1]);
sdest_("IN NVX OPT USING --- SPOS", &c__0, (ftnlen)25);
} else if (s_cmp(cfunc, "ANG ", (ftnlen)4, (ftnlen)4) == 0) {
sdest_("IN NVX OPT USING --- ANG ", &c__0, (ftnlen)25);
} else if (s_cmp(cfunc, "HGT ", (ftnlen)4, (ftnlen)4) == 0) {
sdest_("IN NVX OPT USING --- HGT ", &c__0, (ftnlen)25);
} else {
ret_val = 1;
}
return ret_val;
} /* nv2optgmsx_ */
/* $Procedure BEUNS ( Be an unsigned integer? ) */
logical beuns_(char *string, ftnlen string_len)
{
/* System generated locals */
logical ret_val;
/* Builtin functions */
integer i_len(char *, ftnlen), i_indx(char *, char *, ftnlen, ftnlen),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__, l;
logical ok;
extern integer frstnb_(char *, ftnlen);
/* $ Abstract */
/* Determine whether a string represents an unsigned integer. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* WORDS */
/* $ Keywords */
/* ALPHANUMERIC */
/* NUMBERS */
/* SCANNING */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* STRING I Character string. */
/* The function returns TRUE if the string represents an unsigned */
/* integer. Otherwise, it returns FALSE. */
/* $ Detailed_Input */
/* STRING is any string. */
/* $ Detailed_Output */
/* If STRING contains a single word made entirely from the */
/* characters '0' through '9', then the function returns TRUE. */
/* Otherwise, it returns FALSE. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* By definition an unsigned integer is a word made exclusively */
/* from the characters '0', '1', '2', '3', '4', '5', '6', '7', '8', */
/* and '9'. */
/* $ Examples */
/* Four classes of numbers recognized by the various BE functions. */
/* UNS unsigned integer */
/* INT integer (includes INT) */
/* DEC decimal number (includes UNS, INT) */
/* NUM number (includes UNS, INT, NUM) */
/* The following table illustrates the differences between */
/* the classes. (Any number of leading and trailing blanks */
/* are acceptable.) */
/* String Accepted by */
/* ------------------ ------------------ */
/* 0 UNS, INT, DEC, NUM */
/* 21 */
/* 21994217453648 */
/* +0 INT, DEC, NUM */
/* -13 */
/* +21946 */
/* 1.23 DEC, NUM */
/* 12. */
/* .17 */
/* +4.1 */
/* -.25 */
/* 2.3e17 NUM */
/* 17.D-13275849 */
/* -.194265E+0004 */
/* Note that the functions don't take the magnitudes of the numbers */
/* into account. They may accept numbers that cannot be represented */
/* in Fortran variables. (For example, '2.19E999999999999' probably */
/* exceeds the maximum floating point number on any machine, but */
/* is perfectly acceptable to BENUM.) */
/* The following strings are not accepted by any of the functions. */
/* String Reason */
/* --------------- ---------------------------------------- */
/* 3/4 No implied operations (rational numbers) */
/* 37+14 No explicit operations */
/* E12 Must have mantissa */
/* 217,346.91 No commas */
/* 3.14 159 264 No embedded spaces */
/* PI No special numbers */
/* FIVE No textual numbers */
/* CXIV No roman numerals */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 01-DEC-1995 (WLT) */
/* -& */
/* $ Index_Entries */
/* determine if a string is an unsigned integer */
/* -& */
/* SPICE functions */
/* Local variables */
/* Get the length of the string and the position of its */
/* first non-blank character. */
l = i_len(string, string_len);
i__ = frstnb_(string, string_len);
/* If there isn't a non-blank character, this isn't an */
/* unsigned integer. */
if (i__ == 0) {
ret_val = FALSE_;
return ret_val;
}
/* As far as we know right now, everything is ok. Examine */
/* characters until we run out of string or until we */
/* hit a non-digit character. */
ok = TRUE_;
while(ok && i__ <= l) {
if (i_indx("0123456789", string + (i__ - 1), (ftnlen)10, (ftnlen)1) >
0) {
++i__;
} else {
ok = FALSE_;
}
}
/* If the string still is ok as an unsigned integer, it must be */
/* one... */
if (ok) {
ret_val = TRUE_;
} else {
/* ... otherwise, it's an unsigned integer if the remainder is blank. */
ret_val = s_cmp(string + (i__ - 1), " ", string_len - (i__ - 1), (
ftnlen)1) == 0;
}
return ret_val;
} /* beuns_ */
/* $Procedure PRINST (Display string of CK-file summary) */
/* Subroutine */ int prinst_0_(int n__, integer *id, doublereal *tbegin,
doublereal *tend, integer *avflag, integer *frame, char *tout,
logical *fdsp, logical *tdsp, logical *gdsp, logical *ndsp, ftnlen
tout_len)
{
/* Initialized data */
static doublereal tbprev = 0.;
static doublereal teprev = 0.;
static integer idprev = 0;
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer hint;
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
integer scidw;
logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
extern integer rtrim_(char *, ftnlen);
integer frcode;
extern /* Subroutine */ int ccifrm_(integer *, integer *, integer *, char
*, integer *, logical *, ftnlen);
char idline[256], fnline[256], tbline[256], avline[256], teline[256];
extern /* Subroutine */ int timecn_(doublereal *, integer *, char *, char
*, ftnlen, ftnlen), frmnam_(integer *, char *, ftnlen), repmcw_(
char *, char *, char *, integer *, char *, ftnlen, ftnlen, ftnlen,
ftnlen);
char outlin[256];
extern /* Subroutine */ int tostdo_(char *, ftnlen), intstr_(integer *,
char *, ftnlen);
/* $ Abstract */
/* Write a single CK-file summary record string to standard */
/* output in requested format. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* CKBRIEF.UG */
/* $ Keywords */
/* SUMMARY */
/* CK */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Author_and_Institution */
/* Y.K. Zaiko (BERC) */
/* B.V. Semenov (NAIF) */
/* $ Version */
/* - Toolkit Version 6.1.0, 27-JUN-2014 (BVS) */
/* BUG FIX: changed logic to make a combination of -a and an ID */
/* specified on the command line work in all cases. */
/* - CKBRIEF Version 6.0.0, 2014-04-28 (BVS) (NJB) */
/* Modified to treat all files as a single file (-a). */
/* Changed SCLKD display format to include 6 decimal */
/* places. */
/* Increased MAXBOD to 1,000,000 (from 100,000) and CMDSIZ to */
/* 50,000 (from 25,000). */
/* Added support for CK type 6. */
/* - CKBRIEF Version 5.0.0, 2009-02-11 (BVS) */
/* Updated version. */
/* - CKBRIEF Version 4.0.0, 2008-01-13 (BVS) */
/* Increased MAXBOD to 100,000 (from 10,000). */
/* Increased CMDSIZ to 25,000 (from 4,000). */
/* Updated version string and changed its format to */
/* '#.#.#, Month DD, YYYY' (from '#.#.#, YYYY-MM-DD'). */
/* - CKBRIEF Version 3.2.0, 2006-11-02 (BVS) */
/* Updated version string. */
/* - CKBRIEF Version 3.1.0, 2005-11-08 (BVS) */
/* Updated version string. */
/* - CKBRIEF Version 2.0.0, 2001-05-16 (BVS) */
/* Increased MAXBOD to 10000 (from 4000). Set LRGWIN to be */
/* MAXBOD*2 (was MAXBOD). Changed version string. */
/* - CKBRIEF Version 1.1.2, 2001-04-09 (BVS) */
/* Changed version parameter. */
/* - CKBRIEF Version 1.0.0 beta, 1999-02-17 (YKZ)(BVS) */
/* Initial release. */
/* -& */
/* The Version is stored as a string. */
/* The maximum number of segments or interpolation intervals */
/* that can be summarized is stored in the parameter MAXBOD. */
/* This is THE LIMIT that should be increased if window */
/* routines called by CKBRIEF fail. */
/* The largest expected window -- must be twice the size of */
/* MAXBOD for consistency. */
/* The longest command line that can be accommodated is */
/* given by CMDSIZ. */
/* MAXUSE is the maximum number of objects that can be explicitly */
/* specified on the command line for ckbrief summaries. */
/* Generic line size for all modules. */
/* Time type keys. */
/* Output time format pictures. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* ID I NAIF ID code of object */
/* TBEGIN I Start time of object coverage interval, SCLK ticks */
/* TEND I End time of object coverage interval, SCLK ticks */
/* AVFLAG I Angular velocity flag */
/* FRAME I NAIF ID code of reference frame */
/* TOUT I Key specifying times representation on output */
/* FDSP I Flag defining whether frames name/id is printed */
/* TDSP I Flag defining tabular/non-tabular summary format */
/* GDSP I Flag requesting object grouping by coverage */
/* NDSP I Flag to display frame assosiated with CK ID */
/* $ Detailed_Input */
/* ID Integer NAIF ID code found in summaries */
/* of CK-file and to be written to standard output. */
/* TBEGIN Begin time for object coverage given as DP */
/* SCLK ticks. */
/* TEND End time for object coverage given as DP */
/* SCLK ticks. */
/* AVFLAG Angular velocities presence flag: 0 - not present, */
/* 1 - present, 2 - mixed. */
/* FRAME Integer NAIF ID code of reference frame relative */
/* to which orientation of the ID was given. */
/* TOUT Key specifying time representation on output: */
/* SCLK string, encoded SCLK, ET, UTC or DOY */
/* FDSP Flag defining whether name or ID code of the */
/* FRAME should appear on output. */
/* TDSP Flag defining whether summaries have to be written */
/* in tabular or non-tabular format. */
/* GDSP Flag defining whether objects with the same */
/* coverage must be grouped together. */
/* NDSP Flag requesting display of the name of the frame */
/* associated with CK ID. */
/* $ Detailed_Output */
/* None. This subroutine displays summary line for a CK-file/segment */
/* for subroutine DISPSM. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* Y.K. Zaiko (BERC) */
/* B.V. Semenov (NAIF) */
/* $ Version */
/* - CKBRIEF Beta Version 2.0.0, 13-OCT-2008 (BVS) */
/* Added NDSP argument. Changed to display frame names associated */
/* with CK IDs when NDSP is .TRUE.. */
/* - CKBRIEF Beta Version 1.0.0, 17-FEB-1999 (YKZ)(BVS) */
/* -& */
/* SPICELIB functions */
/* Local parameters. */
/* Output fields widths. */
/* Preset output values. */
/* Local variables */
/* Save previous time boundaries and ID code. */
/* Set initial value to zeros. */
switch(n__) {
case 1: goto L_prinsr;
}
/* Convert all inputs to strings that will appear on output. */
if (*ndsp) {
scidw = 26;
ccifrm_(&c__3, id, &frcode, idline, &hint, &found, (ftnlen)256);
if (! found) {
s_copy(idline, "NO FRAME FOR #", (ftnlen)256, (ftnlen)14);
repmi_(idline, "#", id, idline, (ftnlen)256, (ftnlen)1, (ftnlen)
256);
}
} else {
scidw = 8;
intstr_(id, idline, (ftnlen)256);
}
timecn_(tbegin, id, tout, tbline, tout_len, (ftnlen)256);
timecn_(tend, id, tout, teline, tout_len, (ftnlen)256);
if (*avflag == 2) {
s_copy(avline, "*", (ftnlen)256, (ftnlen)1);
} else if (*avflag == 1) {
s_copy(avline, "Y", (ftnlen)256, (ftnlen)1);
} else {
s_copy(avline, "N", (ftnlen)256, (ftnlen)1);
}
frmnam_(frame, fnline, (ftnlen)256);
if (s_cmp(fnline, " ", (ftnlen)256, (ftnlen)1) == 0) {
if (*frame == 0) {
s_copy(fnline, "MIXED", (ftnlen)256, (ftnlen)5);
} else {
intstr_(frame, fnline, (ftnlen)256);
}
}
/* Make up output string and print them depending on what kind of */
/* output format was requested. */
if (*tdsp) {
/* For table output, set output line template depending on */
/* whether FRAME display was requested. */
if (*fdsp) {
s_copy(outlin, "# # # # #", (ftnlen)256, (ftnlen)11);
} else {
s_copy(outlin, "# # # #", (ftnlen)256, (ftnlen)7);
}
/* Check whether coverage is the same as previous one and */
/* reassign begin and end time to 'same' flag if so. */
if (*tbegin == tbprev && *tend == teprev && s_cmp(tbline, "NEED LSK "
"AND SCLK FILES", (ftnlen)256, (ftnlen)23) != 0 && s_cmp(
teline, "NEED LSK AND SCLK FILES", (ftnlen)256, (ftnlen)23) !=
0) {
s_copy(tbline, " -- same --", (ftnlen)256, (ftnlen)13);
s_copy(teline, " -- same --", (ftnlen)256, (ftnlen)13);
}
/* Substitute string and print out the line. */
repmcw_(outlin, "#", idline, &scidw, outlin, (ftnlen)256, (ftnlen)1, (
ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", tbline, &c__24, outlin, (ftnlen)256, (ftnlen)1, (
ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", teline, &c__24, outlin, (ftnlen)256, (ftnlen)1, (
ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", avline, &c__1, outlin, (ftnlen)256, (ftnlen)1, (
ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", fnline, &c__32, outlin, (ftnlen)256, (ftnlen)1, (
ftnlen)256, (ftnlen)256);
/* Display the line. */
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
} else {
/* If grouping flag is set, we display single coverage line for */
/* multiple objects. If it's not set, we display multiple */
/* coverage lines for a single object. Also when GDSP set we do */
/* NOT display angular velocity flags or FRAME names/ids. */
if (*gdsp) {
if (*tbegin == tbprev && *tend == teprev) {
/* This is another object in a group with the same */
/* coverage. Display just the object ID. */
s_copy(outlin, " #", (ftnlen)256, (ftnlen)10);
} else {
/* This is the first object in a group with a different */
/* coverage. Display blank line, coverage and ID of the */
/* first object. */
tostdo_(" ", (ftnlen)1);
s_copy(outlin, "Begin #: # End #: # ", (ftnlen)256, (ftnlen)
21);
repmc_(outlin, "#", tout, outlin, (ftnlen)256, (ftnlen)1,
tout_len, (ftnlen)256);
repmcw_(outlin, "#", tbline, &c__24, outlin, (ftnlen)256, (
ftnlen)1, (ftnlen)256, (ftnlen)256);
repmc_(outlin, "#", tout, outlin, (ftnlen)256, (ftnlen)1,
tout_len, (ftnlen)256);
repmcw_(outlin, "#", teline, &c__24, outlin, (ftnlen)256, (
ftnlen)1, (ftnlen)256, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
if (*ndsp) {
s_copy(outlin, "Frames: #", (ftnlen)256, (ftnlen)10);
} else {
s_copy(outlin, "Objects: #", (ftnlen)256, (ftnlen)10);
}
}
repmcw_(outlin, "#", idline, &scidw, outlin, (ftnlen)256, (ftnlen)
1, (ftnlen)256, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
} else {
/* No grouping by time was requested. So, display contains */
/* sets of coverage intervals for a particular object. */
if (*id == idprev) {
/* It's the same object. Print out only interval. */
if (*fdsp) {
s_copy(outlin, " # # # #", (ftnlen)256, (ftnlen)11);
} else {
s_copy(outlin, " # # #", (ftnlen)256, (ftnlen)7);
}
} else {
/* It's another object. Print object ID, header and */
/* the first interval. */
tostdo_(" ", (ftnlen)1);
if (*ndsp) {
s_copy(outlin, "Frame: #", (ftnlen)256, (ftnlen)10);
} else {
s_copy(outlin, "Object: #", (ftnlen)256, (ftnlen)10);
}
repmcw_(outlin, "#", idline, &scidw, outlin, (ftnlen)256, (
ftnlen)1, (ftnlen)256, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
if (*fdsp) {
s_copy(outlin, " Interval Begin ####### Interval End "
"####### AV Relative to FRAME", (ftnlen)256, (
ftnlen)73);
i__1 = rtrim_("#######", (ftnlen)7);
repmcw_(outlin, "#######", tout, &i__1, outlin, (ftnlen)
256, (ftnlen)7, tout_len, (ftnlen)256);
i__1 = rtrim_("#######", (ftnlen)7);
repmcw_(outlin, "#######", tout, &i__1, outlin, (ftnlen)
256, (ftnlen)7, tout_len, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
s_copy(outlin, " ------------------------ -------------"
"----------- --- ----------------- ", (ftnlen)256,
(ftnlen)74);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
s_copy(outlin, " # # # #", (ftnlen)256, (ftnlen)11);
} else {
s_copy(outlin, " Interval Begin ####### Interval End "
"####### AV ", (ftnlen)256, (ftnlen)56);
i__1 = rtrim_("#######", (ftnlen)7);
repmcw_(outlin, "#######", tout, &i__1, outlin, (ftnlen)
256, (ftnlen)7, tout_len, (ftnlen)256);
i__1 = rtrim_("#######", (ftnlen)7);
repmcw_(outlin, "#######", tout, &i__1, outlin, (ftnlen)
256, (ftnlen)7, tout_len, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
s_copy(outlin, " ------------------------ -------------"
"----------- --- ", (ftnlen)256, (ftnlen)56);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
s_copy(outlin, " # # #", (ftnlen)256, (ftnlen)7);
}
}
repmcw_(outlin, "#", tbline, &c__24, outlin, (ftnlen)256, (ftnlen)
1, (ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", teline, &c__24, outlin, (ftnlen)256, (ftnlen)
1, (ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", avline, &c__1, outlin, (ftnlen)256, (ftnlen)
1, (ftnlen)256, (ftnlen)256);
repmcw_(outlin, "#", fnline, &c__32, outlin, (ftnlen)256, (ftnlen)
1, (ftnlen)256, (ftnlen)256);
tostdo_(outlin, rtrim_(outlin, (ftnlen)256));
}
}
/* Reassign saved variables. */
tbprev = *tbegin;
teprev = *tend;
idprev = *id;
return 0;
/* $Procedure PRINSR (Reset saved variables) */
L_prinsr:
/* $ Abstract */
/* This entry point resets saved ID and start and stop time) */
/* to make sure that CKBRIEF generates table headers correctly. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* CKBRIEF.UG */
/* $ Keywords */
/* SUMMARY */
/* CK */
/* $ Declarations */
/* None. */
/* $ Brief_I/O */
/* None. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* Y.K. Zaiko (BERC) */
/* B.V. Semenov (NAIF) */
/* $ Version */
/* - CKBRIEF Beta Version 2.0.0, 13-OCT-2008 (BVS) */
/* -& */
tbprev = 0.;
teprev = 0.;
idprev = 0;
return 0;
} /* prinst_ */
/* $Procedure SEPOOL ( String from pool ) */
/* Subroutine */ int sepool_(char *item, integer *fidx, char *contin, char *
string, integer *size, integer *lidx, logical *found, ftnlen item_len,
ftnlen contin_len, ftnlen string_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer comp;
logical more;
char part[80];
integer room, n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer clast, csize;
logical gotit;
extern integer rtrim_(char *, ftnlen);
integer putat;
extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer
*, char *, logical *, ftnlen, ftnlen);
integer cfirst;
extern /* Subroutine */ int chkout_(char *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Retrieve the string starting at the FIDX element of the kernel */
/* pool variable, where the string may be continued across several */
/* components of the kernel pool variable. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* POOL */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEM I name of the kernel pool variable */
/* FIDX I index of the first component of the string */
/* CONTIN I character sequence used to indicate continuation */
/* STRING O a full string concatenated across continuations */
/* SIZE O the number of character in the full string value */
/* LIDX O index of the last component of the string */
/* FOUND O flag indicating success or failure of request */
/* $ Detailed_Input */
/* ITEM is the name of a kernel pool variable for which */
/* the caller wants to retrieve a full (potentially */
/* continued) string. */
/* FIDX is the index of the first component (the start) of */
/* the string in ITEM. */
/* CONTIN is a sequence of characters which (if they appear as */
/* the last non-blank sequence of characters in a */
/* component of a value of a kernel pool variable) */
/* indicate that the string associated with the */
/* component is continued into the next literal */
/* component of the kernel pool variable. */
/* If CONTIN is blank, all of the components of ITEM */
/* will be retrieved as a single string. */
/* $ Detailed_Output */
/* STRING is the full string starting at the FIDX element of the */
/* kernel pool variable specified by ITEM. */
/* Note that if STRING is not sufficiently long to hold */
/* the fully continued string, the value will be */
/* truncated. You can determine if STRING has been */
/* truncated by examining the variable SIZE. */
/* SIZE is the index of last non-blank character of */
/* continued string as it is represented in the */
/* kernel pool. This is the actual number of characters */
/* needed to hold the requested string. If STRING */
/* contains a truncated portion of the full string, */
/* RTRIM(STRING) will be less than SIZE. */
/* If the value of STRING should be a blank, then */
/* SIZE will be set to 1. */
/* LIDX is the index of the last component (the end) of */
/* the retrieved string in ITEM. */
/* FOUND is a logical variable indicating success of the */
/* request to retrieve the string. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the variable specified by ITEM is not present in the */
/* kernel pool or is present but is not character valued, STRING */
/* will be returned as a blank, SIZE will be returned with the */
/* value 0 and FOUND will be set to .FALSE. In particular if NTH */
/* is less than 1, STRING will be returned as a blank, SIZE will */
/* be zero and FOUND will be FALSE. */
/* 2) If the variable specified has a blank string associated */
/* with its full string starting at FIDX, STRING will be blank, */
/* SIZE will be 1 and FOUND will be set to .TRUE. */
/* 3) If STRING is not long enough to hold all of the characters */
/* associated with the NTH string, it will be truncated on the */
/* right. */
/* 4) If the continuation character is a blank, every component */
/* of the variable specified by ITEM will be inserted into */
/* the output string. */
/* 5) If the continuation character is blank, then a blank component */
/* of a variable is treated as a component with no letters. */
/* For example: */
/* STRINGS = ( 'This is a variable' */
/* 'with a blank' */
/* ' ' */
/* 'component.' ) */
/* Is equivalent to */
/* STRINGS = ( 'This is a variable' */
/* 'with a blank' */
/* 'component.' ) */
/* from the point of view of SEPOOL if CONTIN is set to the */
/* blank character. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The SPICE Kernel Pool provides a very convenient interface */
/* for supplying both numeric and textual data to user application */
/* programs. However, any particular component of a character */
/* valued component of a kernel pool variable is limited to 80 */
/* or fewer characters in length. */
/* This routine allows you to overcome this limitation by */
/* "continuing" a character component of a kernel pool variable. */
/* To do this you need to select a continuation sequence */
/* of characters and then insert this sequence as the last non-blank */
/* set of characters that make up the portion of the component */
/* that should be continued. */
/* For example, you may decide to use the sequence '//' to indicate */
/* that a string should be continued to the next component of */
/* a kernel pool variable. Then set up the */
/* kernel pool variable as shown below */
/* LONG_STRINGS = ( 'This is part of the first component //' */
/* 'that needs more than one line when //' */
/* 'inserting it into the kernel pool.' */
/* 'This is the second string that is split //' */
/* 'up as several components of a kernel pool //' */
/* 'variable.' ) */
/* When loaded into the kernel pool, the variable LONG_STRINGS */
/* will have six literal components: */
/* COMPONENT (1) = 'This is part of the first component //' */
/* COMPONENT (2) = 'that needs more than one line when //' */
/* COMPONENT (3) = 'inserting it into the kernel pool.' */
/* COMPONENT (4) = 'This is the second string that is split //' */
/* COMPONENT (5) = 'up as several components of a kernel pool //' */
/* COMPONENT (6) = 'variable.' */
/* These are the components that would be retrieved by the call */
/* CALL GCPOOL ( 'LONG_STRINGS', 1, 6, N, COMPONENT, FOUND ) */
/* However, using the routine SEPOOL you can view the variable */
/* LONG_STRINGS as having two long components. */
/* STRING (1) = 'This is part of the first component that ' */
/* . // 'needs more than one line when inserting ' */
/* . // 'it into the kernel pool. ' */
/* STRING (2) = 'This is the second string that is split ' */
/* . // 'up as several components of a kernel pool ' */
/* . // 'variable. ' */
/* These string components would be retrieved by the following two */
/* calls. */
/* FIDX = 1 */
/* CALL SEPOOL ( 'LONG_STRINGS', FIDX, '//', */
/* . STRING(1), SIZE, LIDX, FOUND ) */
/* FIDX = LIDX+1 */
/* CALL SEPOOL ( 'LONG_STRINGS', FIDX, '//', */
/* . STRING(2), SIZE, LIDX, FOUND ) */
/* $ Examples */
/* Example 1. Retrieving file names. */
/* Suppose a you have used the kernel pool as a mechanism for */
/* specifying SPK files to load at startup but that the full */
/* names of the files are too long to be contained in a single */
/* text line of a kernel pool assignment. */
/* By selecting an appropriate continuation character ('*' for */
/* example) you can insert the full names of the SPK files */
/* into the kernel pool and then retrieve them using this */
/* routine. */
/* First set up the kernel pool specification of the strings */
/* as shown here: */
/* SPK_FILES = ( 'this_is_the_full_path_specification_*' */
/* 'of_a_file_with_a_long_name' */
/* 'this_is_the_full_path_specification_*' */
/* 'of_a_second_file_with_a_very_long_*' */
/* 'name' ) */
/* Now to retrieve and load the SPK_FILES one at a time, */
/* exercise the following loop. */
/* INTEGER FILSIZ */
/* PARAMETER ( FILSIZ = 255 ) */
/* CHARACTER*(FILSIZ) FILE */
/* INTEGER I */
/* INTEGER LIDX */
/* I = 1 */
/* CALL SEPOOL ( 'SPK_FILES', I, '*', FILE, SIZE, LIDX, FOUND ) */
/* DO WHILE ( FOUND .AND. RTRIM(FILE) .EQ. SIZE ) */
/* CALL SPKLEF ( FILE, HANDLE ) */
/* I = LIDX + 1 */
/* CALL SEPOOL ( 'SPK_FILES', I, '*', FILE, SIZE, LIDX, FOUND ) */
/* END DO */
/* IF ( FOUND .AND. RTRIM(FILE) .NE. SIZE ) THEN */
/* WRITE (*,*) 'The ', I, '''th file name was too long.' */
/* END IF */
/* Example 2. Retrieving all components as a string. */
/* Occasionally, it may be useful to retrieve the entire */
/* contents of a kernel pool variable as a single string. To */
/* do this you can use the blank character as the */
/* continuation character. For example if you place the */
/* following assignment in a text kernel */
/* COMMENT = ( 'This is a long note ' */
/* ' about the intended ' */
/* ' use of this text kernel that ' */
/* ' can be retrieved at run time.' ) */
/* you can retrieve COMMENT as single string via the call below. */
/* CALL SEPOOL ( 'COMMENT', 1, ' ', COMMNT, SIZE, LIDX, FOUND ) */
/* The result will be that COMMNT will have the following value. */
/* COMMNT = 'This is a long note about the intended use of ' */
/* . // 'this text kernel that can be retrieved at run ' */
/* . // 'time. ' */
/* Note that the leading blanks of each component of COMMENT are */
/* significant, trailing blanks are not significant. */
/* If COMMENT had been set as */
/* COMMENT = ( 'This is a long note ' */
/* 'about the intended ' */
/* 'use of this text kernel that ' */
/* 'can be retrieved at run time.' ) */
/* Then the call to SEPOOL above would have resulted in several */
/* words being run together as shown below. */
/* COMMNT = 'This is a long noteabout the intendeduse of ' */
/* . // 'this text kernel thatcan be retrieved at run ' */
/* . // 'time. ' */
/* resulted in several words being run together as shown below. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 12-APR-2012 (WLT)(BVS) */
/* -& */
/* $ Index_Entries */
/* Retrieve a continued string value from the kernel pool */
/* -& */
/* SPICELIB Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
/* Return empty output if the input index is bad. */
if (*fidx < 1) {
*found = FALSE_;
s_copy(string, " ", string_len, (ftnlen)1);
*size = 0;
*lidx = 0;
return 0;
}
/* Check in. */
chkin_("SEPOOL", (ftnlen)6);
/* Check if the first component exists. Return empty output if not. */
gcpool_(item, fidx, &c__1, &n, part, &gotit, item_len, (ftnlen)80);
gotit = gotit && n > 0;
if (! gotit) {
*found = FALSE_;
s_copy(string, " ", string_len, (ftnlen)1);
*size = 0;
*lidx = 0;
chkout_("SEPOOL", (ftnlen)6);
return 0;
}
/* Fetch the string using Bill's algorithm from STPOOL 'as is'. */
room = i_len(string, string_len);
csize = rtrim_(contin, contin_len);
putat = 1;
comp = *fidx;
more = TRUE_;
s_copy(string, " ", string_len, (ftnlen)1);
n = 0;
while(more) {
gcpool_(item, &comp, &c__1, &n, part, &more, item_len, (ftnlen)80);
more = more && n > 0;
if (more) {
*found = TRUE_;
clast = rtrim_(part, (ftnlen)80);
cfirst = clast - csize + 1;
if (cfirst < 0) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), clast);
}
putat += clast;
more = FALSE_;
} else if (s_cmp(part + (cfirst - 1), contin, clast - (cfirst - 1)
, contin_len) != 0) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), clast);
}
putat += clast;
more = FALSE_;
} else if (cfirst > 1) {
if (putat <= room) {
s_copy(string + (putat - 1), part, string_len - (putat -
1), cfirst - 1);
}
putat = putat + cfirst - 1;
}
}
++comp;
}
/* We are done. Get the size of the full string and the index of its */
/* last component and checkout. */
*size = putat - 1;
*lidx = comp - 1;
chkout_("SEPOOL", (ftnlen)6);
return 0;
} /* sepool_ */
/* $Procedure SPCT2B ( SPK and CK, text to binary ) */
/* Subroutine */ int spct2b_(integer *unit, char *binary, ftnlen binary_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen), f_open(olist *), s_wsfe(
cilist *), e_wsfe(void), f_clos(cllist *);
/* Local variables */
char line[1000];
extern /* Subroutine */ int spcac_(integer *, integer *, char *, char *,
ftnlen, ftnlen), chkin_(char *, ftnlen);
extern integer ltrim_(char *, ftnlen), rtrim_(char *, ftnlen);
extern /* Subroutine */ int daft2b_(integer *, char *, integer *, ftnlen);
integer handle;
extern /* Subroutine */ int dafcls_(integer *), dafopw_(char *, integer *,
ftnlen);
integer scrtch;
extern /* Subroutine */ int errfnm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), getlun_(integer *),
setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Reconstruct a binary SPK or CK file including comments */
/* from a text file opened by the calling program. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SPC */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* UNIT I Logical unit connected to the text format file. */
/* BINARY I Name of a binary SPK or CK file to be created. */
/* $ Detailed_Input */
/* UNIT is the logical unit connected to an existing text */
/* format SPK or CK file that may contain comments in */
/* the appropriate SPC format, as written by SPCB2A or */
/* SPCB2T. This file must be opened for read access */
/* using the routine TXTOPR. */
/* This file may contain text that precedes and */
/* follows the SPK or CK data and comments, however, */
/* when calling this routine, the file pointer must be */
/* in a position in the file such that the next line */
/* returned by a READ statement is */
/* ''NAIF/DAF'' */
/* which marks the beginning of the data. */
/* BINARY is the name of a binary SPK or CK file to be created. */
/* The binary file contains the same data and comments */
/* as the text file, but in the binary format required */
/* for use with the SPICELIB reader subroutines. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Files */
/* 1) See arguments UNIT and BINARY above. */
/* 2) This routine uses a Fortran scratch file to temporarily */
/* store the lines of comments if there are any. */
/* $ Exceptions */
/* 1) If there is a problem opening or writing to the binary */
/* file, a routine that SPCT2B calls diagnoses and signals */
/* an error. */
/* 2) If there is a problem reading from the text file, the */
/* error SPICE(FILEREADFAILED) is signalled. */
/* 3) If there is a problem opening a scratch file, the error */
/* SPICE(FILEOPENERROR) is signalled. */
/* 4) If there is a problem writing to the scratch file, the */
/* error SPICE(FILEWRITEFAILED) is signalled. */
/* $ Particulars */
/* The SPICELIB SPK and CK reader subroutines read binary files. */
/* However, because different computing environments have different */
/* binary representations of numbers, you must convert SPK and CK */
/* files to text format when porting from one system to another. */
/* After converting the file to text, you can transfer it using */
/* a transfer protocol program like Kermit or FTP. Then, convert */
/* the text file back to binary format. */
/* The following is a list of the SPICELIB routines that convert */
/* SPK and CK files between binary and text format: */
/* SPCA2B converts text to binary. It opens the text file, */
/* creates a new binary file, and closes both files. */
/* SPCB2A converts binary to text. It opens the binary file, */
/* creates a new text file, and closes both files. */
/* SPCT2B converts text to binary. It creates a new binary */
/* file and closes it. The text file is open on */
/* entrance and exit. */
/* SPCB2T converts binary to text. It opens the binary */
/* file and closes it. The text file is open on */
/* entrance and exit */
/* See the SPC required reading for more information */
/* about SPC routines and the SPK and CK file formats. */
/* $ Examples */
/* 1) The following code fragment creates a text file containing */
/* text format SPK data and comments preceded and followed */
/* by a standard label. */
/* The SPICELIB routine TXTOPN opens a new text file and TXTOPR */
/* opens an existing text file for read access. TEXT and */
/* BINARY are character strings that contain the names of the */
/* text and binary files. */
/* CALL TXTOPN ( TEXT, UNIT ) */
/* (Write header label to UNIT) */
/* CALL SPCB2T ( BINARY, UNIT ) */
/* (Write trailing label to UNIT) */
/* CLOSE ( UNIT ) */
/* The following code fragment reconverts the text format */
/* SPK data and comments back into binary format. */
/* CALL TXTOPR ( TEXT, UNIT ) */
/* (Read, or just read past, header label from UNIT) */
/* CALL SPCT2B ( UNIT, BINARY ) */
/* (Read trailing label from UNIT, if desired ) */
/* CLOSE ( UNIT ) */
/* 2) Suppose three text format SPK files have been appended */
/* together into one text file called THREE.TSP. The following */
/* code fragment converts each set of data and comments into */
/* its own binary file. */
/* CALL TXTOPR ( 'THREE.TSP', UNIT ) */
/* CALL SPCT2B ( UNIT, 'FIRST.BSP' ) */
/* CALL SPCT2B ( UNIT, 'SECOND.BSP' ) */
/* CALL SPCT2B ( UNIT, 'THIRD.BSP' ) */
/* CLOSE ( UNIT ) */
/* $ Restrictions */
/* 1) This routine assumes that the data and comments in the */
/* text format SPK or CK file come from a binary file */
/* and were written by one of the routines SPCB2A or SPCB2T. */
/* Data and/or comments written any other way may not be */
/* in the correct format and, therefore, may not be handled */
/* properly. */
/* 2) Older versions of SPK and CK files did not have a comment */
/* area. These files, in text format, may still be converted */
/* to binary using SPCT2B. However, upon exit, the file pointer */
/* will not be in position ready to read the first line of text */
/* after the data. Instead, the next READ statement after */
/* calling SPCT2B will return the second line of text after */
/* the data. Therefore, example 1 may not work as desired */
/* if the trailing label begins on the first line after the */
/* data. To solve this problem, use DAFT2B instead of SPCT2B. */
/* 3) UNIT must be obtained via TXTOPR. Use TXTOPR to open text */
/* files for read access and get the logical unit. System */
/* dependencies regarding opening text files have been isolated */
/* in the routines TXTOPN and TXTOPR. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* J.E. McLean (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 05-APR-1991 (JEM) */
/* -& */
/* $ Index_Entries */
/* text spk or ck to binary */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SPCT2B", (ftnlen)6);
}
/* DAFT2B creates the new binary file and writes the data to */
/* it. If the 'NAIF/DAF' keyword is not the first line that */
/* it reads from the text file, it will signal an error. */
/* Initially, no records are reserved. */
daft2b_(unit, binary, &c__0, binary_len);
/* The comments follow the data and are surrounded by markers. */
/* BMARK should be the next line that we read. If it isn't, */
/* then this is an old file, created before the comment area */
/* existed. In this case, we've read one line too far, but */
/* we can't backspace because the file was written using list- */
/* directed formatting (See the ANSI standard). All we can do */
/* is check out, leaving the file pointer where it is, but */
/* that's better than signalling an error. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, (ftnlen)1000);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
if (iostat > 0) {
setmsg_("Error reading the text file named FNM. Value of IOSTAT is "
"#.", (ftnlen)61);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", unit, (ftnlen)3);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
i__1 = ltrim_(line, (ftnlen)1000) - 1;
if (s_cmp(line + i__1, "~NAIF/SPC BEGIN COMMENTS~", 1000 - i__1, (ftnlen)
25) != 0 || iostat < 0) {
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
/* We're not at the end of the file, and the line we read */
/* is BMARK, so we write the comments to a scratch file. */
/* We do this because we have to use SPCAC to add the comments */
/* to the comment area of the binary file, and SPCAC rewinds */
/* the file. It's okay for SPCAC to rewind a scratch file, */
/* but it's not okay to rewind the file connected to UNIT -- */
/* we don't know the initial location of the file pointer. */
getlun_(&scrtch);
o__1.oerr = 1;
o__1.ounit = scrtch;
o__1.ofnm = 0;
o__1.orl = 0;
o__1.osta = "SCRATCH";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
setmsg_("Error opening a scratch file. File name was FNM. Value of"
" IOSTAT is #.", (ftnlen)72);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEOPENERROR)", (ftnlen)20);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
ci__1.cierr = 1;
ci__1.ciunit = scrtch;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, line, rtrim_(line, (ftnlen)1000));
if (iostat != 0) {
goto L100002;
}
iostat = e_wsfe();
L100002:
if (iostat != 0) {
setmsg_("Error writing to scratch file. File name is FNM. Value of "
"IOSTAT is #.", (ftnlen)71);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
/* Continue reading lines from the text file and storing them */
/* in the scratch file until we get to the end marker. */
for(;;) { /* while(complicated condition) */
i__1 = ltrim_(line, (ftnlen)1000) - 1;
if (!(s_cmp(line + i__1, "~NAIF/SPC END COMMENTS~", 1000 - i__1, (
ftnlen)23) != 0))
break;
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, line, (ftnlen)1000);
if (iostat != 0) {
goto L100003;
}
iostat = e_rsfe();
L100003:
if (iostat != 0) {
setmsg_("Error reading the text file named FNM. Value of IOSTAT"
" is #.", (ftnlen)61);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", unit, (ftnlen)3);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
ci__1.cierr = 1;
ci__1.ciunit = scrtch;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100004;
}
iostat = do_fio(&c__1, line, rtrim_(line, (ftnlen)1000));
if (iostat != 0) {
goto L100004;
}
iostat = e_wsfe();
L100004:
if (iostat != 0) {
setmsg_("Error writing to scratch file. File name is FNM. Valu"
"e of IOSTAT is #.", (ftnlen)72);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
}
/* Open the new binary file and add the comments that have been */
/* stored temporarily in a scratch file. */
dafopw_(binary, &handle, binary_len);
spcac_(&handle, &scrtch, "~NAIF/SPC BEGIN COMMENTS~", "~NAIF/SPC END COM"
"MENTS~", (ftnlen)25, (ftnlen)23);
/* Close the files. The scratch file is automatically deleted. */
dafcls_(&handle);
cl__1.cerr = 0;
cl__1.cunit = scrtch;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("SPCT2B", (ftnlen)6);
return 0;
} /* spct2b_ */
/* $Procedure META_2 ( Percy's interface to META_0 ) */
/* Subroutine */ int meta_2__0_(int n__, char *command, char *temps, integer *
ntemps, char *temp, integer *btemp, char *error, ftnlen command_len,
ftnlen temps_len, ftnlen temp_len, ftnlen error_len)
{
/* Initialized data */
static logical pass1 = TRUE_;
static char margns[128] = "LEFT 1 RIGHT 75 "
" "
" ";
static char keynam[6*10] = "1 " "2 " "3 " "4 " "5 "
"6 " "7 " "8 " "9 " "10 ";
/* System generated locals */
address a__1[5];
integer i__1, i__2[5];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), e_wsle(
void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer do_lio(integer *, integer *, char *, ftnlen);
/* Local variables */
extern /* Subroutine */ int getopt_1__(char *, integer *, char *, integer
*, char *, integer *, char *, char *, ftnlen, ftnlen, ftnlen,
ftnlen, ftnlen);
static integer sbeg;
static char mode[16], pick[32];
static integer b, e, i__, j;
extern integer cardc_(char *, ftnlen);
extern logical batch_(void);
static integer score;
static logical fixit;
extern integer rtrim_(char *, ftnlen);
static char style[128];
static integer m2code;
static char tryit[600];
extern /* Subroutine */ int m2gmch_(char *, char *, char *, integer *,
logical *, integer *, logical *, integer *, integer *, char *,
ftnlen, ftnlen, ftnlen, ftnlen), m2rcvr_(integer *, integer *,
char *, ftnlen), scardc_(integer *, char *, ftnlen);
static integer bscore, cutoff;
static logical reason;
extern /* Subroutine */ int prefix_(char *, integer *, char *, ftnlen,
ftnlen), ssizec_(integer *, char *, ftnlen), repsub_(char *,
integer *, integer *, char *, char *, ftnlen, ftnlen, ftnlen);
static logical intrct;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
static char thnwds[32*7], kwords[32*16];
extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen), prepsn_(char *, ftnlen);
static logical pssthn;
static char questn[80];
extern /* Subroutine */ int niceio_3__(char *, integer *, char *, ftnlen,
ftnlen), cnfirm_1__(char *, logical *, ftnlen);
/* Fortran I/O blocks */
static cilist io___19 = { 0, 6, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, 0, 0 };
static cilist io___21 = { 0, 6, 0, 0, 0 };
static cilist io___22 = { 0, 6, 0, 0, 0 };
static cilist io___23 = { 0, 6, 0, 0, 0 };
static cilist io___27 = { 0, 6, 0, 0, 0 };
static cilist io___29 = { 0, 6, 0, 0, 0 };
static cilist io___30 = { 0, 6, 0, 0, 0 };
static cilist io___31 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Given a collection of acceptable syntax's and a statement */
/* (COMMAND) this routine determines if the statement is */
/* syntactically correct. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* The META/2 Book. */
/* $ Keywords */
/* COMPARE */
/* PARSING */
/* SEARCH */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* COMMAND I A candidate PERCY command. */
/* TEMPS I A collection of language definition statements */
/* NTEMPS I The number of definition statements */
/* TEMP - Work space required for comparison of statements. */
/* BTEMP O The first of the def statements that best matches. */
/* ERROR O Non-blank if none of the def's match. */
/* $ Detailed_Input */
/* COMMAND A candidate PERCY command. */
/* TEMPS A collection of language definition statements */
/* NTEMPS The number of definition statements */
/* TEMP Work space required for comparison of statements. */
/* TEMP should be declared to have the same length */
/* as the character strings that make up TEMPS. */
/* $ Detailed_Output */
/* BTEMP The first of the def statements that best matches. */
/* ERROR Non-blank if none of the def's match. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* None. */
/* $ Particulars */
/* Later. */
/* $ Examples */
/* Later. */
/* $ Restrictions */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - META/2 Configured Version 3.0.0, 11-AUG-1995 (WLT) */
/* The control flow through this routine was modified */
/* so that it will now re-try all templates (starting */
/* with the best previous match) if a spelling error */
/* is encountered. This should fix the confused */
/* responses that META/2 gave occassionally before. */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 9, 1994 */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 */
/* Added a pretty print formatting capability to the */
/* error diagnostics. */
/* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of META/2 */
/* software as of May 3, 1994 */
/* - Beta Version 2.0.0, 14-JAN-1993 (HAN) */
/* Assigned the value 'INTERACTIVE' to the variable MODE, and */
/* replaced calls to VTLIB routines with calls to more */
/* portable routines. */
/* - Beta Version 1.0.0, 13-JUL-1988 (WLT) (IMU) */
/* -& */
/* Spice Functions */
/* Local variables. */
/* Saved variables */
/* Initial values */
/* Parameter adjustments */
if (temps) {
}
if (error) {
}
/* Function Body */
switch(n__) {
case 1: goto L_m2marg;
}
/* %&END_DECLARATIONS */
/* Take care of first pass initializations. */
if (pass1) {
pass1 = FALSE_;
ssizec_(&c__1, thnwds, (ftnlen)32);
scardc_(&c__0, thnwds, (ftnlen)32);
ssizec_(&c__10, kwords, (ftnlen)32);
scardc_(&c__0, kwords, (ftnlen)32);
/* Determine if were in batch or interactive mode. */
if (batch_()) {
s_copy(mode, "BATCH", (ftnlen)16, (ftnlen)5);
} else {
s_copy(mode, "INTERACTIVE", (ftnlen)16, (ftnlen)11);
}
}
intrct = s_cmp(mode, "BATCH", (ftnlen)16, (ftnlen)5) != 0;
s_copy(style, margns, (ftnlen)128, (ftnlen)128);
suffix_("NEWLINE /cr VTAB /vt HARDSPACE , ", &c__1, style, (ftnlen)33, (
ftnlen)128);
i__ = 0;
bscore = -1;
m2code = -1;
cutoff = 72;
reason = TRUE_;
/* Look through the templates until we get a match or we */
/* run out of templates to try. */
i__1 = *ntemps;
for (i__ = 1; i__ <= i__1; ++i__) {
score = 0;
s_copy(temp, temps + (i__ - 1) * temps_len, temp_len, temps_len);
sbeg = 1;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &pssthn, &
m2code, &score, error, temp_len, (ftnlen)32, command_len,
error_len);
/* If M2CODE comes back zero, we are done with the work */
/* of this routine. */
if (m2code == 0) {
*btemp = i__;
return 0;
}
if (score > bscore) {
bscore = score;
*btemp = i__;
}
}
/* If we get here, we know we didn't have a match. Examine the */
/* highest scoring template to get available diagnostics */
/* about the mismatch. */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len, temps_len);
sbeg = 1;
fixit = TRUE_;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &c_true, &cutoff, &pssthn, &m2code,
&score, error, temp_len, (ftnlen)32, command_len, error_len);
/* If we are in interactiive mode and we have a spelling error, we */
/* can attempt to fix it. Note this occurs only if the M2CODE */
/* is less than 100 mod 10000. */
while(m2code % 10000 < 100 && intrct && fixit) {
/* Construct a friendly message; display it; and */
/* get the user's response as to whether or not the */
/* command should be modified. */
s_copy(tryit, error, (ftnlen)600, error_len);
prefix_("Hmmmm.,,,", &c__1, tryit, (ftnlen)9, (ftnlen)600);
suffix_("/cr/cr I can repair this if you like.", &c__0, tryit, (
ftnlen)37, (ftnlen)600);
s_wsle(&io___19);
e_wsle();
niceio_3__(tryit, &c__6, style, (ftnlen)600, (ftnlen)128);
s_wsle(&io___20);
e_wsle();
s_wsle(&io___21);
e_wsle();
s_wsle(&io___22);
e_wsle();
s_wsle(&io___23);
e_wsle();
m2rcvr_(&b, &e, kwords, (ftnlen)32);
if (cardc_(kwords, (ftnlen)32) == 1) {
/* Writing concatenation */
i__2[0] = 17, a__1[0] = "Should I change \"";
i__2[1] = e - (b - 1), a__1[1] = command + (b - 1);
i__2[2] = 6, a__1[2] = "\" to \"";
i__2[3] = rtrim_(kwords + 192, (ftnlen)32), a__1[3] = kwords +
192;
i__2[4] = 3, a__1[4] = "\" ?";
s_cat(questn, a__1, i__2, &c__5, (ftnlen)80);
cnfirm_1__(questn, &fixit, rtrim_(questn, (ftnlen)80));
} else {
cnfirm_1__("Should I fix it?", &fixit, (ftnlen)16);
}
/* If the user has elected to have us fix the command */
/* we have a few things to do... */
if (fixit) {
/* Look up the suggested fixes. If there is more than */
/* one possibility, see which one the user thinks is */
/* best. Otherwise, no more questions for now. */
m2rcvr_(&b, &e, kwords, (ftnlen)32);
if (cardc_(kwords, (ftnlen)32) > 1) {
i__1 = cardc_(kwords, (ftnlen)32) - 4;
for (i__ = 1; i__ <= i__1; ++i__) {
s_wsle(&io___27);
e_wsle();
}
i__1 = cardc_(kwords, (ftnlen)32);
getopt_1__("Which word did you mean?", &i__1, keynam, &c__6,
kwords + 192, &c__32, kwords + 192, pick, (ftnlen)24,
(ftnlen)6, (ftnlen)32, (ftnlen)32, (ftnlen)32);
} else {
s_copy(pick, kwords + 192, (ftnlen)32, (ftnlen)32);
}
/* Make the requested repairs on the command, and */
/* redisplay the command. */
repsub_(command, &b, &e, pick, command, command_len, (ftnlen)32,
command_len);
cmprss_(" ", &c__1, command, command, (ftnlen)1, command_len,
command_len);
s_wsle(&io___29);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_wsle(&io___30);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
niceio_3__(command, &c__6, style, command_len, (ftnlen)128);
s_wsle(&io___31);
e_wsle();
/* Look through the templates again until we get a match or we */
/* run out of templates to try. Note however, that this time */
/* we will start in a different spot. We already have a best */
/* matching template. We'll start our search for a match */
/* there and simulate a circular list of templates so that */
/* we can examine all of them if necessary. */
s_copy(error, " ", error_len, (ftnlen)1);
s_copy(error + error_len, " ", error_len, (ftnlen)1);
bscore = -1;
m2code = -1;
cutoff = 72;
reason = TRUE_;
j = *btemp - 1;
i__1 = *ntemps;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Get the index of the next template to examine. */
++j;
while(j > *ntemps) {
j -= *ntemps;
}
/* Set the template, score for this template, spot to */
/* begin examining it and the M2CODE so far. */
s_copy(temp, temps + (j - 1) * temps_len, temp_len, temps_len)
;
sbeg = 1;
score = 0;
m2code = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &
pssthn, &m2code, &score, error, temp_len, (ftnlen)32,
command_len, error_len);
/* If we get back a zero M2CODE we've got a match */
/* This routine's work is done. */
if (m2code == 0) {
*btemp = i__;
return 0;
}
/* Hmmph. No match. See if we've got a better */
/* matching score so far and then go on to the next */
/* template if any are left. */
if (score > bscore) {
bscore = score;
*btemp = i__;
}
}
/* If we made it to this point the command doesn't properly */
/* match any of the templates. Get the best match and */
/* determine the diagnostics for this template. */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len,
temps_len);
sbeg = 1;
m2code = 0;
score = 0;
m2gmch_(temp, thnwds, command, &sbeg, &reason, &cutoff, &pssthn, &
m2code, &score, error, temp_len, (ftnlen)32, command_len,
error_len);
}
}
/* If you get to this point. We didn't have a match set up */
/* the second level of mismatch diagnostics using the best */
/* matching template. (BTEMP already points to it.) */
s_copy(temp, temps + (*btemp - 1) * temps_len, temp_len, temps_len);
cmprss_(" ", &c__1, temp, temp, (ftnlen)1, temp_len, temp_len);
prepsn_(temp, temp_len);
prepsn_(error + error_len, error_len);
prefix_("/cr/cr(-3:-3) ", &c__1, error + error_len, (ftnlen)14, error_len)
;
prefix_(temp, &c__1, error + error_len, temp_len, error_len);
prefix_("/cr/cr(3:3) ", &c__1, error + error_len, (ftnlen)12, error_len);
prefix_("a command with the following syntax:", &c__3, error + error_len,
(ftnlen)36, error_len);
prefix_("I Believe you were trying to enter", &c__1, error + error_len, (
ftnlen)34, error_len);
prefix_("META/2:", &c__1, error + error_len, (ftnlen)7, error_len);
return 0;
/* The following entry point allows user's to adjust the margins */
/* of the META/2 error messages. */
L_m2marg:
s_copy(margns, temp, (ftnlen)128, temp_len);
return 0;
} /* meta_2__ */
/* $Procedure ZZBODKER ( Private --- Process Body-Name Kernel Pool Maps ) */
/* Subroutine */ int zzbodker_(char *names, char *nornam, integer *codes,
integer *nvals, integer *ordnom, integer *ordcod, integer *nocds,
logical *extker, ftnlen names_len, ftnlen nornam_len)
{
/* Initialized data */
static char nbc[32] = "NAIF_BODY_CODE ";
static char nbn[32] = "NAIF_BODY_NAME ";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
logical drop[2000];
char type__[1*2];
integer nsiz[2];
extern /* Subroutine */ int zzbodini_(char *, char *, integer *, integer *
, integer *, integer *, integer *, ftnlen, ftnlen);
integer i__, j;
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen), errch_(char *, char *, ftnlen, ftnlen);
logical found;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
logical plfind[2];
extern /* Subroutine */ int orderc_(char *, integer *, integer *, ftnlen),
gcpool_(char *, integer *, integer *, integer *, char *, logical
*, ftnlen, ftnlen), gipool_(char *, integer *, integer *, integer
*, integer *, logical *, ftnlen), sigerr_(char *, ftnlen);
logical remdup;
extern /* Subroutine */ int chkout_(char *, ftnlen), dtpool_(char *,
logical *, integer *, char *, ftnlen, ftnlen), setmsg_(char *,
ftnlen), errint_(char *, integer *, ftnlen), cmprss_(char *,
integer *, char *, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
integer num[2];
/* $ Abstract */
/* SPICE Private routine intended solely for the support of SPICE */
/* routines. Users should not call this routine directly due */
/* to the volatile nature of this routine. */
/* This routine processes the kernel pool vectors NAIF_BODY_NAME */
/* and NAIF_BODY_CODE into the formatted lists required by ZZBODTRN */
/* to successfully compute code-name mappings. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* NAIF_IDS */
/* $ Keywords */
/* BODY */
/* $ Declarations */
/* $ Abstract */
/* This include file lists the parameter collection */
/* defining the number of SPICE ID -> NAME mappings. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* naif_ids.req */
/* $ Keywords */
/* Body mappings. */
/* $ Author_and_Institution */
/* E.D. Wright (JPL) */
/* $ Version */
/* SPICELIB 1.0.0 Thu May 20 07:57:58 2010 (EDW) */
/* A script generates this file. Do not edit by hand. */
/* Edit the creation script to modify the contents of */
/* ZZBODTRN.INC. */
/* Maximum size of a NAME string */
/* Count of default SPICE mapping assignments. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* NAMES O Array of kernel pool assigned names. */
/* NORNAM O Array of normalized kernel pool assigned names. */
/* CODES O Array of ID codes for NAMES/NORNAM. */
/* NVALS O Length of NAMES, NORNAM, CODES, and ORDNOM arrays. */
/* ORDNOM O Order vector for NORNAM. */
/* ORDCOD O Modified order vector for CODES. */
/* NOCDS O Length of ORDCOD array. */
/* EXTKER O Logical indicating presence of kernel pool names. */
/* MAXL P Maximum length of body name strings. */
/* NROOM P Maximum length of kernel pool data vectors. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* NAMES the array of highest precedent names extracted */
/* from the kernel pool vector NAIF_BODY_NAME. This */
/* array is parallel to NORNAM and CODES. */
/* NORNAM the array of highest precedent names extracted */
/* from the kernel pool vector NAIF_BODY_NAME. After */
/* extraction, each entry is converted to uppercase, */
/* and groups of spaces are compressed to a single */
/* space. This represents the canonical member of the */
/* equivalence class each parallel entry in NAMES */
/* belongs. */
/* CODES the array of highest precedent codes extracted */
/* from the kernel pool vector NAIF_BODY_CODE. This */
/* array is parallel to NAMES and NORNAM. */
/* NVALS the number of items contained in NAMES, NORNAM, */
/* CODES and ORDNOM. */
/* ORDNOM the order vector of indexes for NORNAM. The set */
/* of values NORNAM( ORDNOM(1) ), NORNAM( ORDNOM(2) ), */
/* ... forms an increasing list of name values. */
/* ORDCOD the modified ordering vector of indexes into */
/* CODES. The list CODES( ORDCOD(1) ), */
/* CODES( ORDCOD(2) ), ... , CODES( ORDCOD(NOCDS) ) */
/* forms an increasing non-repeating list of integers. */
/* Moreover, every value in CODES is listed exactly */
/* once in this sequence. */
/* NOCDS the number of indexes listed in ORDCOD. This */
/* value will never exceed NVALS. */
/* EXTKER is a logical that indicates to the caller whether */
/* any kernel pool name-code maps have been defined. */
/* If EXTKER is .FALSE., then the kernel pool variables */
/* NAIF_BODY_CODE and NAIF_BODY_NAME are empty and */
/* only the built-in and ZZBODDEF code-name mappings */
/* need consideration. If .TRUE., then the values */
/* returned by this module need consideration. */
/* $ Parameters */
/* MAXL is the maximum length of a body name. Defined in */
/* the include file 'zzbodtrn.inc'. */
/* NROOM is the maximum number of kernel pool data items */
/* that can be processed from the NAIF_BODY_CODE */
/* and NAIF_BODY_NAME lists. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* 1) The error SPICE(MISSINGKPV) is signaled when one of the */
/* NAIF_BODY_CODE and NAIF_BODY_NAME keywords is present in the */
/* kernel pool and the other is not. */
/* 2) The error SPICE(KERVARTOOBIG) is signaled if one or both of */
/* the NAIF_BODY_CODE and NAIF_BODY_NAME kernel pool vectors */
/* have a cardinality that exceeds NROOM. */
/* 3) The error SPICE(BADDIMENSIONS) is signaled if the cardinality */
/* of the NAIF_BODY_CODE and NAIF_BODY_NAME kernel pool vectors do */
/* not match. */
/* 4) The error SPICE(BLANKNAMEASSIGNED) is signaled if an entry */
/* in the NAIF_BODY_NAME kernel pool vector is a blank string. */
/* ID codes may not be assigned to a blank string. */
/* $ Particulars */
/* This routine examines the contents of the kernel pool, ingests */
/* the contents of the NAIF_BODY_CODE and NAIF_BODY_NAME keywords, */
/* and produces the order vectors and name/code lists that ZZBODTRN */
/* requires to resolve code to name and name to code mappings. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.0, 23-AUG-2002 (EDW) (FST) */
/* -& */
/* SPICELIB Functions */
/* Local Parameters */
/* Local Variables */
/* Saved Variables */
/* Data Statements */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZBODKER", (ftnlen)8);
}
/* Until the code below proves otherwise, we shall assume */
/* we lack kernel pool name/code mappings. */
*extker = FALSE_;
/* Check for the external body ID variables in the kernel pool. */
gcpool_(nbn, &c__1, &c__2000, num, names, plfind, (ftnlen)32, (ftnlen)36);
gipool_(nbc, &c__1, &c__2000, &num[1], codes, &plfind[1], (ftnlen)32);
/* Examine PLFIND(1) and PLFIND(2) for problems. */
if (plfind[0] != plfind[1]) {
/* If they are not both present or absent, signal an error. */
setmsg_("The kernel pool vector, #, used in mapping between names an"
"d ID-codes is absent, while # is not. This is often due to "
"an improperly constructed text kernel. Check loaded kernels"
" for these keywords.", (ftnlen)199);
if (plfind[0]) {
errch_("#", nbc, (ftnlen)1, (ftnlen)32);
errch_("#", nbn, (ftnlen)1, (ftnlen)32);
} else {
errch_("#", nbn, (ftnlen)1, (ftnlen)32);
errch_("#", nbc, (ftnlen)1, (ftnlen)32);
}
sigerr_("SPICE(MISSINGKPV)", (ftnlen)17);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
} else if (! plfind[0]) {
/* Return if both keywords are absent. */
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
/* If we reach here, then both kernel pool variables are present. */
/* Perform some simple sanity checks on their lengths. */
dtpool_(nbn, &found, nsiz, type__, (ftnlen)32, (ftnlen)1);
dtpool_(nbc, &found, &nsiz[1], type__ + 1, (ftnlen)32, (ftnlen)1);
if (nsiz[0] > 2000 || nsiz[1] > 2000) {
setmsg_("The kernel pool vectors used to define the names/ID-codes m"
"appingexceeds the max size. The size of the NAME vector is #"
"1. The size of the CODE vector is #2. The max number allowed"
" of elements is #3.", (ftnlen)198);
errint_("#1", nsiz, (ftnlen)2);
errint_("#2", &nsiz[1], (ftnlen)2);
errint_("#3", &c__2000, (ftnlen)2);
sigerr_("SPICE(KERVARTOOBIG)", (ftnlen)19);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
} else if (nsiz[0] != nsiz[1]) {
setmsg_("The kernel pool vectors used for mapping between names and "
"ID-codes are not the same size. The size of the name vector"
", NAIF_BODY_NAME is #. The size of the ID-code vector, NAIF_"
"BODY_CODE is #. You need to examine the ID-code kernel you l"
"oaded and correct the mismatch.", (ftnlen)270);
errint_("#", nsiz, (ftnlen)1);
errint_("#", &nsiz[1], (ftnlen)1);
sigerr_("SPICE(BADDIMENSIONS)", (ftnlen)20);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
/* Compute the canonical member of the equivalence class of NAMES, */
/* NORNAM. This normalization compresses groups of spaces into a */
/* single space, left justifies the string, and uppercases the */
/* contents. While passing through the NAMES array, look for any */
/* blank strings and signal an appropriate error. */
*nvals = num[0];
i__1 = *nvals;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Check for blank strings. */
if (s_cmp(names + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("names", i__2, "zzbodker_", (ftnlen)345)) * 36, " ", (
ftnlen)36, (ftnlen)1) == 0) {
setmsg_("An attempt to assign the code, #, to a blank string was"
" made. Check loaded text kernels for a blank string in "
"the NAIF_BODY_NAME array.", (ftnlen)136);
errint_("#", &i__, (ftnlen)1);
sigerr_("SPICE(BLANKNAMEASSIGNED)", (ftnlen)24);
chkout_("ZZBODKER", (ftnlen)8);
return 0;
}
/* Compute the canonical member of the equivalence class. */
ljust_(names + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"names", i__2, "zzbodker_", (ftnlen)361)) * 36, nornam + ((
i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("nornam",
i__3, "zzbodker_", (ftnlen)361)) * 36, (ftnlen)36, (ftnlen)36)
;
ucase_(nornam + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"nornam", i__2, "zzbodker_", (ftnlen)362)) * 36, nornam + ((
i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("nornam",
i__3, "zzbodker_", (ftnlen)362)) * 36, (ftnlen)36, (ftnlen)36)
;
cmprss_(" ", &c__1, nornam + ((i__2 = i__ - 1) < 2000 && 0 <= i__2 ?
i__2 : s_rnge("nornam", i__2, "zzbodker_", (ftnlen)363)) * 36,
nornam + ((i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 :
s_rnge("nornam", i__3, "zzbodker_", (ftnlen)363)) * 36, (
ftnlen)1, (ftnlen)36, (ftnlen)36);
}
/* Determine a preliminary order vector for NORNAM. */
orderc_(nornam, nvals, ordnom, (ftnlen)36);
/* We are about to remove duplicates. Make some initial */
/* assumptions, no duplicates exist in NORNAM. */
i__1 = *nvals;
for (i__ = 1; i__ <= i__1; ++i__) {
drop[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge("drop",
i__2, "zzbodker_", (ftnlen)377)] = FALSE_;
}
remdup = FALSE_;
/* ORDERC clusters duplicate entries in NORNAM together. */
/* Use this fact to locate duplicates on one pass through */
/* NORNAM. */
i__1 = *nvals - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s_cmp(nornam + ((i__3 = ordnom[(i__2 = i__ - 1) < 2000 && 0 <=
i__2 ? i__2 : s_rnge("ordnom", i__2, "zzbodker_", (ftnlen)389)
] - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("nornam", i__3,
"zzbodker_", (ftnlen)389)) * 36, nornam + ((i__5 = ordnom[(
i__4 = i__) < 2000 && 0 <= i__4 ? i__4 : s_rnge("ordnom",
i__4, "zzbodker_", (ftnlen)389)] - 1) < 2000 && 0 <= i__5 ?
i__5 : s_rnge("nornam", i__5, "zzbodker_", (ftnlen)389)) * 36,
(ftnlen)36, (ftnlen)36) == 0) {
/* We have at least one duplicate to remove. */
remdup = TRUE_;
/* If the normalized entries are equal, drop the one with */
/* the lower index in the NAMES array. Entries defined */
/* later in the kernel pool have higher precedence. */
if (ordnom[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"ordnom", i__2, "zzbodker_", (ftnlen)401)] < ordnom[(i__3
= i__) < 2000 && 0 <= i__3 ? i__3 : s_rnge("ordnom", i__3,
"zzbodker_", (ftnlen)401)]) {
drop[(i__3 = ordnom[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ?
i__2 : s_rnge("ordnom", i__2, "zzbodker_", (ftnlen)
402)] - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge("drop",
i__3, "zzbodker_", (ftnlen)402)] = TRUE_;
} else {
drop[(i__3 = ordnom[(i__2 = i__) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("ordnom", i__2, "zzbodker_", (ftnlen)404)] - 1)
< 2000 && 0 <= i__3 ? i__3 : s_rnge("drop", i__3,
"zzbodker_", (ftnlen)404)] = TRUE_;
}
}
}
/* If necessary, remove duplicates. */
if (remdup) {
/* Sweep through the DROP array, compressing off any elements */
/* that are to be dropped. */
j = 0;
i__1 = *nvals;
for (i__ = 1; i__ <= i__1; ++i__) {
if (! drop[(i__2 = i__ - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"drop", i__2, "zzbodker_", (ftnlen)423)]) {
++j;
s_copy(names + ((i__2 = j - 1) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("names", i__2, "zzbodker_", (ftnlen)425)) * 36,
names + ((i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3
: s_rnge("names", i__3, "zzbodker_", (ftnlen)425)) *
36, (ftnlen)36, (ftnlen)36);
s_copy(nornam + ((i__2 = j - 1) < 2000 && 0 <= i__2 ? i__2 :
s_rnge("nornam", i__2, "zzbodker_", (ftnlen)426)) *
36, nornam + ((i__3 = i__ - 1) < 2000 && 0 <= i__3 ?
i__3 : s_rnge("nornam", i__3, "zzbodker_", (ftnlen)
426)) * 36, (ftnlen)36, (ftnlen)36);
codes[(i__2 = j - 1) < 2000 && 0 <= i__2 ? i__2 : s_rnge(
"codes", i__2, "zzbodker_", (ftnlen)427)] = codes[(
i__3 = i__ - 1) < 2000 && 0 <= i__3 ? i__3 : s_rnge(
"codes", i__3, "zzbodker_", (ftnlen)427)];
}
}
/* Adjust NVALS to compensate for the number of elements that */
/* were compressed off the list. */
*nvals = j;
}
/* Compute the order vectors that ZZBODTRN requires. */
zzbodini_(names, nornam, codes, nvals, ordnom, ordcod, nocds, (ftnlen)36,
(ftnlen)36);
/* We're on the home stretch if we make it to this point. */
/* Set EXTKER to .TRUE., check out and return. */
*extker = TRUE_;
chkout_("ZZBODKER", (ftnlen)8);
return 0;
} /* zzbodker_ */
integer kb1inimsg_(char *cin, char *cout, integer *iopt, ftnlen cin_len,
ftnlen cout_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int movw_(integer *, integer *, integer *);
/* symbolic constants & shared data */
/* Copyright(c) 1997, Space Science and Engineering Center, UW-Madison */
/* Refer to "McIDAS Software Acquisition and Distribution Policies" */
/* in the file mcidas/data/license.txt */
/* *** $Id: areaparm.inc,v 1.1 2000/07/12 13:12:23 gad Exp $ *** */
/* area subsystem parameters */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* IF YOU CHANGE THESE VALUES, YOU MUST ALSO CHANGE THEM IN */
/* MCIDAS.H !! */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* MAXGRIDPT maximum number of grid points */
/* MAX_BANDS maximum number of bands within an area */
/* MAXDFELEMENTS maximum number of elements that DF can handle */
/* in an area line */
/* MAXOPENAREAS maximum number of areas that the library can */
/* have open (formerly called `NA') */
/* NUMAREAOPTIONS number of options settable through ARAOPT() */
/* It is presently 5 because there are five options */
/* that ARAOPT() knows about: */
/* 'PREC','SPAC','UNIT','SCAL','CALB' */
/* (formerly called `NB') */
/* --- Size (number of words) in an area directory */
/* MAX_AUXBLOCK_SIZE size (in bytes) of the internal buffers */
/* used to recieve AUX blocks during an */
/* ADDE transaction */
/* ----- MAX_AREA_NUMBER Maximum area number allowed on system */
/* ----- MAXAREARQSTLEN - max length of area request string */
/* external functions */
/* local variables */
/* Parameter adjustments */
--iopt;
/* Function Body */
movw_(&c__5, &iopt[1], msgcommsgkb1_1.jopt);
msgcommsgkb1_1.itype = 0;
msgcommsgkb1_1.calflg = 0;
if (s_cmp(cin, "RAW", (ftnlen)4, (ftnlen)3) == 0 && s_cmp(cout, "BRIT", (
ftnlen)4, (ftnlen)4) == 0) {
msgcommsgkb1_1.itype = 1;
}
if (s_cmp(cin, "RAW", (ftnlen)4, (ftnlen)3) == 0 && s_cmp(cout, "RAD ", (
ftnlen)4, (ftnlen)4) == 0) {
msgcommsgkb1_1.itype = 2;
}
if (s_cmp(cin, "RAW", (ftnlen)4, (ftnlen)3) == 0 && s_cmp(cout, "REFL", (
ftnlen)4, (ftnlen)4) == 0) {
msgcommsgkb1_1.itype = 3;
}
if (s_cmp(cin, "RAW", (ftnlen)4, (ftnlen)3) == 0 && s_cmp(cout, "TEMP", (
ftnlen)4, (ftnlen)4) == 0) {
msgcommsgkb1_1.itype = 4;
}
if (msgcommsgkb1_1.itype == 0) {
goto L900;
}
ret_val = 0;
return ret_val;
L900:
ret_val = -1;
return ret_val;
} /* kb1inimsg_ */
integer kb1calmsg_(integer *pfx, integer *idir, integer *nval, integer *band,
shortint *ibuf)
{
/* Initialized data */
static real factor[12] = { 21.21f,23.24f,19.77f,0.f,0.f,0.f,0.f,0.f,0.f,
0.f,0.f,22.39f };
static integer this__ = -9999;
static doublereal c1w3 = 0.;
static doublereal c2w = 0.;
static doublereal alpha = 0.;
static doublereal beta = 0.;
static doublereal gain = 0.;
static doublereal offset = 0.;
/* Format strings */
static char fmt_1[] = "(6e17.10)";
/* System generated locals */
address a__1[2];
integer ret_val, i__1[2], i__2;
real r__1;
char ch__1[116], ch__2[25], ch__3[12], ch__4[27];
static integer equiv_0[313];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_rsfi(icilist *), do_fio(integer *, char *, ftnlen), e_rsfi(void)
, i_nint(real *);
double sqrt(doublereal), log(doublereal);
/* Local variables */
extern /* Subroutine */ int m0sxtrce_(char *, ftnlen);
static integer i__, bandoffset;
extern /* Character */ VOID cff_(char *, ftnlen, doublereal *, integer *);
#define buf (equiv_0)
#define cbuf ((char *)equiv_0)
static integer ides;
static real refl;
static char cout[104];
static integer isou;
extern /* Subroutine */ int movw_(integer *, integer *, integer *);
static integer ibrit, itemp;
static real xtemp;
extern /* Subroutine */ int araget_(integer *, integer *, integer *,
integer *), mpixel_(integer *, integer *, integer *, shortint *),
gryscl_(real *, integer *);
/* Fortran I/O blocks */
static icilist io___13 = { 1, cout, 0, fmt_1, 104, 1 };
/* symbolic constants & shared data */
/* Copyright(c) 1997, Space Science and Engineering Center, UW-Madison */
/* Refer to "McIDAS Software Acquisition and Distribution Policies" */
/* in the file mcidas/data/license.txt */
/* *** $Id: areaparm.inc,v 1.1 2000/07/12 13:12:23 gad Exp $ *** */
/* area subsystem parameters */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* IF YOU CHANGE THESE VALUES, YOU MUST ALSO CHANGE THEM IN */
/* MCIDAS.H !! */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* MAXGRIDPT maximum number of grid points */
/* MAX_BANDS maximum number of bands within an area */
/* MAXDFELEMENTS maximum number of elements that DF can handle */
/* in an area line */
/* MAXOPENAREAS maximum number of areas that the library can */
/* have open (formerly called `NA') */
/* NUMAREAOPTIONS number of options settable through ARAOPT() */
/* It is presently 5 because there are five options */
/* that ARAOPT() knows about: */
/* 'PREC','SPAC','UNIT','SCAL','CALB' */
/* (formerly called `NB') */
/* --- Size (number of words) in an area directory */
/* MAX_AUXBLOCK_SIZE size (in bytes) of the internal buffers */
/* used to recieve AUX blocks during an */
/* ADDE transaction */
/* ----- MAX_AREA_NUMBER Maximum area number allowed on system */
/* ----- MAXAREARQSTLEN - max length of area request string */
/* external functions */
/* local variables */
/* Parameter adjustments */
--ibuf;
--idir;
--pfx;
/* Function Body */
if (this__ != idir[33]) {
this__ = idir[33];
s_copy(cout, " ", (ftnlen)104, (ftnlen)1);
if (msgcommsgkb1_1.calflg != 0) {
movw_(&c__51, msgcommsgkb1_1.calarr, buf);
} else {
araget_(&idir[33], &idir[63], &c__104, buf);
}
if (s_cmp(cbuf, "MSGT", (ftnlen)4, (ftnlen)4) == 0) {
if (msgcommsgkb1_1.calflg != 0) {
movw_(&c__313, msgcommsgkb1_1.calarr, buf);
} else {
araget_(&idir[33], &idir[63], &c__1252, buf);
}
bandoffset = (*band - 1) * 104 + 5;
s_copy(cout, cbuf + (bandoffset - 1), (ftnlen)104, (ftnlen)104);
} else {
s_copy(cout, cbuf, (ftnlen)104, (ftnlen)104);
}
/* Writing concatenation */
i__1[0] = 12, a__1[0] = "KBXMSG: CAL=";
i__1[1] = 104, a__1[1] = cout;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)116);
m0sxtrce_(ch__1, (ftnlen)116);
/* L1: */
i__2 = s_rsfi(&io___13);
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&c1w3, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&c2w, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&gain, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&offset, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = e_rsfi();
if (i__2 != 0) {
goto L999;
}
/* Writing concatenation */
i__1[0] = 13, a__1[0] = "KBXMSG: GAIN=";
cff_(ch__3, (ftnlen)12, &gain, &c__4);
i__1[1] = 12, a__1[1] = ch__3;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)25);
m0sxtrce_(ch__2, (ftnlen)25);
/* Writing concatenation */
i__1[0] = 15, a__1[0] = "KBXMSG: OFFSET=";
cff_(ch__3, (ftnlen)12, &offset, &c__4);
i__1[1] = 12, a__1[1] = ch__3;
s_cat(ch__4, a__1, i__1, &c__2, (ftnlen)27);
m0sxtrce_(ch__4, (ftnlen)27);
isou = msgcommsgkb1_1.jopt[0];
ides = msgcommsgkb1_1.jopt[1];
}
i__2 = *nval;
for (i__ = 1; i__ <= i__2; ++i__) {
itemp = ibuf[i__];
if (*band < 4 || *band == 12) {
if (msgcommsgkb1_1.itype == 4) {
ibuf[i__] = 0;
} else {
xtemp = (real) itemp * gain + offset;
if (xtemp <= 0.f) {
xtemp = 0.f;
}
if (msgcommsgkb1_1.itype == 2) {
r__1 = xtemp * 100.f;
ibuf[i__] = (shortint) i_nint(&r__1);
} else if (msgcommsgkb1_1.itype == 3) {
refl = xtemp / factor[*band - 1] * 100;
if (refl < 0.f) {
refl = 0.f;
}
if (refl > 100.f) {
refl = 100.f;
}
r__1 = refl * 100;
ibuf[i__] = (shortint) i_nint(&r__1);
} else {
refl = xtemp / factor[*band - 1] * 100;
if (refl < 0.f) {
refl = 0.f;
}
if (refl > 100.f) {
refl = 100.f;
}
r__1 = sqrt(refl) * 25.5f;
ibuf[i__] = (shortint) i_nint(&r__1);
}
}
} else {
xtemp = gain * itemp + offset;
if (xtemp < 0.f) {
xtemp = 0.f;
}
if (msgcommsgkb1_1.itype == 2) {
r__1 = xtemp * 100.f;
ibuf[i__] = (shortint) i_nint(&r__1);
} else if (msgcommsgkb1_1.itype == 3) {
ibuf[i__] = 0;
} else if (msgcommsgkb1_1.itype == 4) {
if (xtemp > 0.f) {
xtemp = (c2w / log(c1w3 / xtemp + 1.f) - beta) / alpha;
r__1 = xtemp * 100.f;
ibuf[i__] = (shortint) i_nint(&r__1);
} else {
ibuf[i__] = 0;
}
} else {
if (xtemp > 0.f) {
xtemp = (c2w / log(c1w3 / xtemp + 1.f) - beta) / alpha;
gryscl_(&xtemp, &ibrit);
ibuf[i__] = (shortint) ibrit;
} else {
ibuf[i__] = 255;
}
}
}
}
mpixel_(nval, &isou, &ides, &ibuf[1]);
ret_val = 0;
return ret_val;
L999:
m0sxtrce_("KBXMSG: CAN NOT READ CAL HEADER", (ftnlen)31);
ret_val = -1;
return ret_val;
} /* kb1calmsg_ */
int32
l_ge (string a, string b, fsize_t la, fsize_t lb)
{
return(s_cmp(a,b,la,lb) >= 0);
}
/* Subroutine */ int cnaupd_(integer *ido, char *bmat, integer *n, char *
which, integer *nev, real *tol, complex *resid, integer *ncv, complex
*v, integer *ldv, integer *iparam, integer *ipntr, complex *workd,
complex *workl, integer *lworkl, real *rwork, integer *info, ftnlen
bmat_len, ftnlen which_len)
{
/* Format strings */
static char fmt_1000[] = "(//,5x,\002==================================="
"==========\002,/5x,\002= Complex implicit Arnoldi update code "
" =\002,/5x,\002= Version Number: \002,\002 2.3\002,21x,\002 "
"=\002,/5x,\002= Version Date: \002,\002 07/31/96\002,16x,\002 ="
"\002,/5x,\002=============================================\002,/"
"5x,\002= Summary of timing statistics =\002,/5x,"
"\002=============================================\002,//)";
static char fmt_1100[] = "(5x,\002Total number update iterations "
" = \002,i5,/5x,\002Total number of OP*x operations "
" = \002,i5,/5x,\002Total number of B*x operations = "
"\002,i5,/5x,\002Total number of reorthogonalization steps = "
"\002,i5,/5x,\002Total number of iterative refinement steps = "
"\002,i5,/5x,\002Total number of restart steps = "
"\002,i5,/5x,\002Total time in user OP*x operation = "
"\002,f12.6,/5x,\002Total time in user B*x operation ="
" \002,f12.6,/5x,\002Total time in Arnoldi update routine = "
"\002,f12.6,/5x,\002Total time in naup2 routine ="
" \002,f12.6,/5x,\002Total time in basic Arnoldi iteration loop = "
"\002,f12.6,/5x,\002Total time in reorthogonalization phase ="
" \002,f12.6,/5x,\002Total time in (re)start vector generation = "
"\002,f12.6,/5x,\002Total time in Hessenberg eig. subproblem ="
" \002,f12.6,/5x,\002Total time in getting the shifts = "
"\002,f12.6,/5x,\002Total time in applying the shifts ="
" \002,f12.6,/5x,\002Total time in convergence testing = "
"\002,f12.6,/5x,\002Total time in computing final Ritz vectors ="
" \002,f12.6/)";
/* System generated locals */
integer v_dim1, v_offset, i__1, i__2;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe(
void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static integer j;
static real t0, t1;
static integer nb, ih, iq, np, iw, ldh, ldq, nev0, mode, ierr, iupd, next,
ritz;
extern /* Subroutine */ int cvout_(integer *, integer *, complex *,
integer *, char *, ftnlen), ivout_(integer *, integer *, integer *
, integer *, char *, ftnlen), cnaup2_(integer *, char *, integer *
, char *, integer *, integer *, real *, complex *, integer *,
integer *, integer *, integer *, complex *, integer *, complex *,
integer *, complex *, complex *, complex *, integer *, complex *,
integer *, complex *, real *, integer *, ftnlen, ftnlen);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int second_(real *);
static integer bounds, ishift, msglvl, mxiter;
extern /* Subroutine */ int cstatn_(void);
/* Fortran I/O blocks */
static cilist io___21 = { 0, 6, 0, fmt_1000, 0 };
static cilist io___22 = { 0, 6, 0, fmt_1100, 0 };
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* Parameter adjustments */
--workd;
--resid;
--rwork;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
if (*ido == 0) {
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
cstatn_();
second_(&t0);
msglvl = debug_1.mcaupd;
/* %----------------% */
/* | Error checking | */
/* %----------------% */
ierr = 0;
ishift = iparam[1];
/* levec = iparam(2) */
mxiter = iparam[3];
/* nb = iparam(4) */
nb = 1;
/* %--------------------------------------------% */
/* | Revision 2 performs only implicit restart. | */
/* %--------------------------------------------% */
iupd = 1;
mode = iparam[7];
if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev || *ncv > *n) {
ierr = -3;
} else if (mxiter <= 0) {
ierr = -4;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(
which, "SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR",
(ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (
ftnlen)2) != 0 && s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) !=
0 && s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat !=
'G') {
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + *ncv * 5) {
ierr = -7;
} else if (mode < 1 || mode > 3) {
ierr = -10;
} else if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
*ido = 99;
goto L9000;
}
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
if (nb <= 0) {
nb = 1;
}
if (*tol <= 0.f) {
*tol = slamch_("EpsMach", (ftnlen)7);
}
if (ishift != 0 && ishift != 1 && ishift != 2) {
ishift = 1;
}
/* %----------------------------------------------% */
/* | NP is the number of additional steps to | */
/* | extend the length NEV Lanczos factorization. | */
/* | NEV0 is the local variable designating the | */
/* | size of the invariant subspace desired. | */
/* %----------------------------------------------% */
np = *ncv - *nev;
nev0 = *nev;
/* %-----------------------------% */
/* | Zero out internal workspace | */
/* %-----------------------------% */
/* Computing 2nd power */
i__2 = *ncv;
i__1 = i__2 * i__2 * 3 + *ncv * 5;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
workl[i__2].r = 0.f, workl[i__2].i = 0.f;
/* L10: */
}
/* %-------------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:ncv*ncv) := generated Hessenberg matrix | */
/* | workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values | */
/* | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | */
/* | workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q | */
/* | workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace | */
/* | The final workspace is needed by subroutine cneigh called | */
/* | by cnaup2. Subroutine cneigh calls LAPACK routines for | */
/* | calculating eigenvalues and the last row of the eigenvector | */
/* | matrix. | */
/* %-------------------------------------------------------------% */
ldh = *ncv;
ldq = *ncv;
ih = 1;
ritz = ih + ldh * *ncv;
bounds = ritz + *ncv;
iq = bounds + *ncv;
iw = iq + ldq * *ncv;
/* Computing 2nd power */
i__1 = *ncv;
next = iw + i__1 * i__1 + *ncv * 3;
ipntr[4] = next;
ipntr[5] = ih;
ipntr[6] = ritz;
ipntr[7] = iq;
ipntr[8] = bounds;
ipntr[14] = iw;
}
/* %-------------------------------------------------------% */
/* | Carry out the Implicitly restarted Arnoldi Iteration. | */
/* %-------------------------------------------------------% */
cnaup2_(ido, bmat, n, which, &nev0, &np, tol, &resid[1], &mode, &iupd, &
ishift, &mxiter, &v[v_offset], ldv, &workl[ih], &ldh, &workl[ritz]
, &workl[bounds], &workl[iq], &ldq, &workl[iw], &ipntr[1], &workd[
1], &rwork[1], info, (ftnlen)1, (ftnlen)2);
/* %--------------------------------------------------% */
/* | ido .ne. 99 implies use of reverse communication | */
/* | to compute operations involving OP. | */
/* %--------------------------------------------------% */
if (*ido == 3) {
iparam[8] = np;
}
if (*ido != 99) {
goto L9000;
}
iparam[3] = mxiter;
iparam[5] = np;
iparam[9] = timing_1.nopx;
iparam[10] = timing_1.nbx;
iparam[11] = timing_1.nrorth;
/* %------------------------------------% */
/* | Exit if there was an informational | */
/* | error within cnaup2. | */
/* %------------------------------------% */
if (*info < 0) {
goto L9000;
}
if (*info == 2) {
*info = 3;
}
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &mxiter, &debug_1.ndigit, "_naupd: Nu"
"mber of update iterations taken", (ftnlen)41);
ivout_(&debug_1.logfil, &c__1, &np, &debug_1.ndigit, "_naupd: Number"
" of wanted \"converged\" Ritz values", (ftnlen)48);
cvout_(&debug_1.logfil, &np, &workl[ritz], &debug_1.ndigit, "_naupd:"
" The final Ritz values", (ftnlen)29);
cvout_(&debug_1.logfil, &np, &workl[bounds], &debug_1.ndigit, "_naup"
"d: Associated Ritz estimates", (ftnlen)33);
}
second_(&t1);
timing_1.tcaupd = t1 - t0;
if (msglvl > 0) {
/* %--------------------------------------------------------% */
/* | Version Number & Version Date are defined in version.h | */
/* %--------------------------------------------------------% */
s_wsfe(&io___21);
e_wsfe();
s_wsfe(&io___22);
do_fio(&c__1, (char *)&mxiter, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&timing_1.nopx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&timing_1.nbx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&timing_1.nrorth, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&timing_1.nitref, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&timing_1.nrstrt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&timing_1.tmvopx, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&timing_1.tmvbx, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&timing_1.tcaupd, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&timing_1.tcaup2, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&timing_1.tcaitr, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&timing_1.titref, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&timing_1.tgetv0, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&timing_1.tceigh, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&timing_1.tcgets, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&timing_1.tcapps, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&timing_1.tcconv, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&timing_1.trvec, (ftnlen)sizeof(real));
e_wsfe();
}
L9000:
return 0;
/* %---------------% */
/* | End of cnaupd | */
/* %---------------% */
} /* cnaupd_ */
/* $Procedure CHCKDO ( Check presence of required input parameters ) */
/* Subroutine */ int chckdo_(char *indtvl, integer *outtvl, integer *param,
integer *nparam, char *doval, ftnlen indtvl_len, ftnlen doval_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer l;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
logical found;
extern integer rtrim_(char *, ftnlen), isrchi_(integer *, integer *,
integer *);
extern logical return_(void);
char errlin[512];
extern /* Subroutine */ int setmsg_(char *, ftnlen), sigerr_(char *,
ftnlen), inssub_(char *, char *, integer *, char *, ftnlen,
ftnlen, ftnlen), chkout_(char *, ftnlen);
/* $ Abstract */
/* This routine is a module of the MKSPK program. It checks whether */
/* set of input parameters specified in the DATA_ORDER value */
/* contains all parameters required for a given input data type and */
/* output SPK type. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* MKSPK User's Guide */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Abstract */
/* MKSPK Include File. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.3.0, 08-FEB-2012 (BVS). */
/* Added TLE coverage and ID keywords. Added default TLE pad */
/* parameter. */
/* - Version 1.2.0, 16-JAN-2008 (BVS). */
/* Added ETTMWR parameter */
/* - Version 1.1.0, 05-JUN-2001 (BVS). */
/* Added MAXDEG parameter. */
/* - Version 1.0.4, 21-MAR-2001 (BVS). */
/* Added parameter for command line flag '-append' indicating */
/* that appending to an existing output file was requested. */
/* Added corresponding setup file keyword ('APPEND_TO_OUTPUT'.) */
/* Added parameters for yes and no values of this keyword. */
/* - Version 1.0.3, 28-JAN-2000 (BVS). */
/* Added parameter specifying number of supported input data */
/* types and parameter specifying number of supported output SPK */
/* types */
/* - Version 1.0.2, 22-NOV-1999 (NGK). */
/* Added parameters for two-line elements processing. */
/* - Version 1.0.1, 18-MAR-1999 (BVS). */
/* Added usage, help and template displays. Corrected comments. */
/* - Version 1.0.0, 8-SEP-1998 (NGK). */
/* -& */
/* Begin Include Section: MKSPK generic parameters. */
/* Maximum number of states allowed per one segment. */
/* String size allocation parameters */
/* Length of buffer for input text processing */
/* Length of a input text line */
/* Length of file name and comment line */
/* Length of string for keyword value processing */
/* Length of string for word processing */
/* Length of data order parameters string */
/* Length of string reserved as delimiter */
/* Numbers of different parameters */
/* Maximum number of allowed comment lines. */
/* Reserved number of input parameters */
/* Full number of delimiters */
/* Number of delimiters that may appear in time string */
/* Command line flags */
/* Setup file keywords reserved values */
/* Standard YES and NO values for setup file keywords. */
/* Number of supported input data types and input DATA TYPE */
/* reserved values. */
/* Number of supported output SPK data types -- this version */
/* supports SPK types 5, 8, 9, 10, 12, 13, 15 and 17. */
/* End of input record marker */
/* Maximum allowed polynomial degree. The value of this parameter */
/* is consistent with the ones in SPKW* routines. */
/* Special time wrapper tag for input times given as ET seconds past */
/* J2000 */
/* Default TLE pad, 1/2 day in seconds. */
/* End Include Section: MKSPK generic parameters. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INDTVL I Input data type. */
/* OUTTVL I Output spk type. */
/* PARAM I Array of DATA_ORDER parameter IDs */
/* NPARAM I Number of not zero parameter IDs in PARAM */
/* DOVAL I Array of parameter values acceptable in DATA_ORDER */
/* $ Detailed_Input */
/* INDTVL is the input data type. See MKSPK.INC for the */
/* current list of supported input data types. */
/* OUTTVL is the output SPK type. Currently supported output */
/* SPK types are 5, 8, 9, 12, 13, 15 and 17. */
/* PARAM is an integer array containing indexes of the */
/* recognizable input parameters present in the */
/* DATA_ORDER keyword value in the order in which they */
/* were provided in that value. */
/* NPARAM is the number of elements in PARAM. */
/* DOVAL is an array containing complete set recognizable */
/* input parameters. (see main module for the current */
/* list) */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* If the set of input parameters does not contain some of the */
/* required tokens, then the error 'SPICE(MISSINGDATAORDERTK)' */
/* will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.G. Khavenson (IKI RAS, Russia) */
/* B.V. Semenov (NAIF, JPL) */
/* $ Version */
/* - Version 1.0.3, 29-MAR-1999 (NGK). */
/* Added comments. */
/* - Version 1.0.2, 18-MAR-1999 (BVS). */
/* Corrected comments. */
/* - Version 1.0.1, 13-JAN-1999 (BVS). */
/* Modified error messages. */
/* - Version 1.0.0, 08-SEP-1998 (NGK). */
/* -& */
/* $ Index_Entries */
/* Check adequacy of the DATA_ORDER defined in MKSPK setup */
/* -& */
/* SPICELIB functions */
/* Parameters INELTP, INSTTP, INEQTP containing supported */
/* input data type names and keyword parameter KDATOR are declared */
/* in the include file. */
/* Local variables */
/* Error line variable. Size LINLEN declared in the include file. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("CHCKDO", (ftnlen)6);
}
/* Check if EPOCH is present among specified input parameters. */
if (isrchi_(&c__1, nparam, param) == 0) {
setmsg_("Set of input data parameters specified in the setup file ke"
"yword '#' must contain token '#' designating epoch position "
"in the input data records.", (ftnlen)145);
errch_("#", "DATA_ORDER", (ftnlen)1, (ftnlen)10);
errch_("#", doval, (ftnlen)1, doval_len);
sigerr_("SPICE(MISSINGEPOCHTOKEN)", (ftnlen)24);
}
/* Check whether all necessary input parameters are present */
/* according to the input data type. */
found = TRUE_;
s_copy(errlin, "The following token(s) designating input parameter(s) re"
"quired when input data type is '#' is(are) missing in the value "
"of the setup file keyword '#':", (ftnlen)512, (ftnlen)150);
if (s_cmp(indtvl, "ELEMENTS", rtrim_(indtvl, indtvl_len), (ftnlen)8) == 0)
{
/* Input type is ELEMENTS. Check whether eccentricity, */
/* inclination, argument of periapsis and longitude of ascending */
/* node are present in the input data. */
repmc_(errlin, "#", "ELEMENTS", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)8, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
if (isrchi_(&c__9, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)5, (
ftnlen)512);
repmc_(errlin, "#", doval + (doval_len << 3), errlin, (ftnlen)512,
(ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
for (l = 13; l <= 15; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
} else if (s_cmp(indtvl, "STATES", rtrim_(indtvl, indtvl_len), (ftnlen)6)
== 0) {
/* Input type is STATES. Check whether all state vector */
/* components are present in the input data. */
repmc_(errlin, "#", "STATES", errlin, (ftnlen)512, (ftnlen)1, (ftnlen)
6, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
for (l = 2; l <= 7; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
} else if (s_cmp(indtvl, "EQ_ELEMENTS", rtrim_(indtvl, indtvl_len), (
ftnlen)11) == 0) {
/* Input type is EQ_ELEMENTS. Check whether all equinoctial */
/* elements are present in the input data. */
repmc_(errlin, "#", "EQ_ELEMENTS", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)11, (ftnlen)512);
repmc_(errlin, "#", "DATA_ORDER", errlin, (ftnlen)512, (ftnlen)1, (
ftnlen)10, (ftnlen)512);
for (l = 21; l <= 29; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
}
/* Signal the error if any of the required parameters wasn't found. */
if (! found) {
i__1 = rtrim_(errlin, (ftnlen)512) - 1;
s_copy(errlin + i__1, ".", rtrim_(errlin, (ftnlen)512) - i__1, (
ftnlen)1);
setmsg_(errlin, (ftnlen)512);
sigerr_("SPICE(MISSINGDATAORDERTK)", (ftnlen)25);
}
/* Check whether all necessary input parameters are present */
/* according to the output SPK type. */
found = TRUE_;
if (*outtvl == 17) {
/* Output type is 17. Verify if dM/dt, dNOD/dt, dPER/dt */
/* exist in input data. */
s_copy(errlin, "The following token(s) designating input parameter(s"
") required when output SPK type is 17 is(are) missing in the"
" value of the setup file keyword '#':", (ftnlen)512, (ftnlen)
149);
for (l = 27; l <= 29; ++l) {
if (isrchi_(&l, nparam, param) == 0) {
i__1 = rtrim_(errlin, (ftnlen)512) + 1;
inssub_(errlin, " '#',", &i__1, errlin, (ftnlen)512, (ftnlen)
5, (ftnlen)512);
repmc_(errlin, "#", doval + (l - 1) * doval_len, errlin, (
ftnlen)512, (ftnlen)1, doval_len, (ftnlen)512);
found = FALSE_;
}
}
}
/* Signal the error if any of the required parameters wasn't found. */
if (! found) {
i__1 = rtrim_(errlin, (ftnlen)512) - 1;
s_copy(errlin + i__1, ".", rtrim_(errlin, (ftnlen)512) - i__1, (
ftnlen)1);
setmsg_(errlin, (ftnlen)512);
sigerr_("SPICE(MISSINGDATAORDERTK)", (ftnlen)25);
}
chkout_("CHCKDO", (ftnlen)6);
return 0;
} /* chckdo_ */
integer kb1optmsg_(char *cfunc, integer *iin, integer *iout, ftnlen cfunc_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern integer lit_(char *, ftnlen);
extern /* Subroutine */ int movw_(integer *, integer *, integer *);
/* external functions */
/* Copyright(c) 1997, Space Science and Engineering Center, UW-Madison */
/* Refer to "McIDAS Software Acquisition and Distribution Policies" */
/* in the file mcidas/data/license.txt */
/* *** $Id: areaparm.inc,v 1.1 2000/07/12 13:12:23 gad Exp $ *** */
/* area subsystem parameters */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* IF YOU CHANGE THESE VALUES, YOU MUST ALSO CHANGE THEM IN */
/* MCIDAS.H !! */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* MAXGRIDPT maximum number of grid points */
/* MAX_BANDS maximum number of bands within an area */
/* MAXDFELEMENTS maximum number of elements that DF can handle */
/* in an area line */
/* MAXOPENAREAS maximum number of areas that the library can */
/* have open (formerly called `NA') */
/* NUMAREAOPTIONS number of options settable through ARAOPT() */
/* It is presently 5 because there are five options */
/* that ARAOPT() knows about: */
/* 'PREC','SPAC','UNIT','SCAL','CALB' */
/* (formerly called `NB') */
/* --- Size (number of words) in an area directory */
/* MAX_AUXBLOCK_SIZE size (in bytes) of the internal buffers */
/* used to recieve AUX blocks during an */
/* ADDE transaction */
/* ----- MAX_AREA_NUMBER Maximum area number allowed on system */
/* ----- MAXAREARQSTLEN - max length of area request string */
/* Parameter adjustments */
--iout;
--iin;
/* Function Body */
ret_val = 0;
if (s_cmp(cfunc, "KEYS", (ftnlen)4, (ftnlen)4) == 0) {
if (iin[4] <= 3 || iin[4] == 12) {
iout[1] = 4;
iout[2] = lit_("RAW ", (ftnlen)4);
iout[3] = lit_("RAD ", (ftnlen)4);
iout[4] = lit_("REFL", (ftnlen)4);
iout[5] = lit_("BRIT", (ftnlen)4);
} else {
iout[1] = 4;
iout[2] = lit_("RAW ", (ftnlen)4);
iout[3] = lit_("RAD ", (ftnlen)4);
iout[4] = lit_("TEMP", (ftnlen)4);
iout[5] = lit_("BRIT", (ftnlen)4);
}
} else if (s_cmp(cfunc, "INFO", (ftnlen)4, (ftnlen)4) == 0) {
if (iin[1] <= 3 || iin[1] == 12) {
iout[1] = 4;
iout[2] = lit_("RAW ", (ftnlen)4);
iout[3] = lit_("RAD ", (ftnlen)4);
iout[4] = lit_("REFL", (ftnlen)4);
iout[5] = lit_("BRIT", (ftnlen)4);
iout[6] = lit_(" ", (ftnlen)4);
iout[7] = lit_("MW**", (ftnlen)4);
iout[8] = lit_("% ", (ftnlen)4);
iout[9] = lit_(" ", (ftnlen)4);
iout[10] = 1;
iout[11] = 100;
iout[12] = 100;
iout[13] = 1;
} else {
iout[1] = 4;
iout[2] = lit_("RAW ", (ftnlen)4);
iout[3] = lit_("RAD ", (ftnlen)4);
iout[4] = lit_("TEMP", (ftnlen)4);
iout[5] = lit_("BRIT", (ftnlen)4);
iout[6] = lit_(" ", (ftnlen)4);
iout[7] = lit_("MW**", (ftnlen)4);
iout[8] = lit_("K ", (ftnlen)4);
iout[9] = lit_(" ", (ftnlen)4);
iout[10] = 1;
iout[11] = 100;
iout[12] = 100;
iout[13] = 1;
}
} else if (s_cmp(cfunc, "CALB", (ftnlen)4, (ftnlen)4) == 0) {
msgcommsgkb1_1.calflg = 1;
movw_(&c__313, &iin[1], msgcommsgkb1_1.calarr);
} else {
ret_val = -1;
}
return ret_val;
} /* kb1optmsg_ */
Subroutine */ int igraphdnaupd_(integer *ido, char *bmat, integer *n, char *
which, integer *nev, doublereal *tol, doublereal *resid, integer *ncv,
doublereal *v, integer *ldv, integer *iparam, integer *ipntr,
doublereal *workd, doublereal *workl, integer *lworkl, integer *info)
{
/* Format strings */
static char fmt_1000[] = "(//,5x,\002==================================="
"==========\002,/5x,\002= Nonsymmetric implicit Arnoldi update co"
"de =\002,/5x,\002= Version Number: \002,\002 2.4\002,21x,\002 "
"=\002,/5x,\002= Version Date: \002,\002 07/31/96\002,16x,\002 ="
"\002,/5x,\002=============================================\002,/"
"5x,\002= Summary of timing statistics =\002,/5x,"
"\002=============================================\002,//)";
static char fmt_1100[] = "(5x,\002Total number update iterations "
" = \002,i5,/5x,\002Total number of OP*x operations "
" = \002,i5,/5x,\002Total number of B*x operations = "
"\002,i5,/5x,\002Total number of reorthogonalization steps = "
"\002,i5,/5x,\002Total number of iterative refinement steps = "
"\002,i5,/5x,\002Total number of restart steps = "
"\002,i5,/5x,\002Total time in user OP*x operation = "
"\002,f12.6,/5x,\002Total time in user B*x operation ="
" \002,f12.6,/5x,\002Total time in Arnoldi update routine = "
"\002,f12.6,/5x,\002Total time in naup2 routine ="
" \002,f12.6,/5x,\002Total time in basic Arnoldi iteration loop = "
"\002,f12.6,/5x,\002Total time in reorthogonalization phase ="
" \002,f12.6,/5x,\002Total time in (re)start vector generation = "
"\002,f12.6,/5x,\002Total time in Hessenberg eig. subproblem ="
" \002,f12.6,/5x,\002Total time in getting the shifts = "
"\002,f12.6,/5x,\002Total time in applying the shifts ="
" \002,f12.6,/5x,\002Total time in convergence testing = "
"\002,f12.6,/5x,\002Total time in computing final Ritz vectors ="
" \002,f12.6/)";
/* System generated locals */
integer v_dim1, v_offset, i__1, i__2;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe(
void), do_fio(integer *, char *, ftnlen);
/* Local variables */
integer j;
real t0, t1;
IGRAPH_F77_SAVE integer nb, ih, iq, np, iw, ldh, ldq;
integer nbx = 0;
IGRAPH_F77_SAVE integer nev0, mode;
integer ierr;
IGRAPH_F77_SAVE integer iupd, next;
integer nopx = 0;
IGRAPH_F77_SAVE integer levec;
real trvec, tmvbx;
IGRAPH_F77_SAVE integer ritzi;
extern /* Subroutine */ int igraphdvout_(integer *, integer *, doublereal *,
integer *, char *, ftnlen), igraphivout_(integer *, integer *, integer *
, integer *, char *, ftnlen);
IGRAPH_F77_SAVE integer ritzr;
extern /* Subroutine */ int igraphdnaup2_(integer *, char *, integer *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
real tnaup2, tgetv0;
extern doublereal igraphdlamch_(char *);
extern /* Subroutine */ int igraphsecond_(real *);
integer logfil, ndigit;
real tneigh;
integer mnaupd = 0;
IGRAPH_F77_SAVE integer ishift;
integer nitref;
IGRAPH_F77_SAVE integer bounds;
real tnaupd;
extern /* Subroutine */ int igraphdstatn_(void);
real titref, tnaitr;
IGRAPH_F77_SAVE integer msglvl;
real tngets, tnapps, tnconv;
IGRAPH_F77_SAVE integer mxiter;
integer nrorth = 0, nrstrt = 0;
real tmvopx;
/* Fortran I/O blocks */
static cilist io___30 = { 0, 6, 0, fmt_1000, 0 };
static cilist io___31 = { 0, 6, 0, fmt_1100, 0 };
/* %----------------------------------------------------%
| Include files for debugging and timing information |
%----------------------------------------------------%
%------------------%
| Scalar Arguments |
%------------------%
%-----------------%
| Array Arguments |
%-----------------%
%------------%
| Parameters |
%------------%
%---------------%
| Local Scalars |
%---------------%
%----------------------%
| External Subroutines |
%----------------------%
%--------------------%
| External Functions |
%--------------------%
%-----------------------%
| Executable Statements |
%-----------------------%
Parameter adjustments */
--workd;
--resid;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
if (*ido == 0) {
/* %-------------------------------%
| Initialize timing statistics |
| & message level for debugging |
%-------------------------------% */
igraphdstatn_();
igraphsecond_(&t0);
msglvl = mnaupd;
/* %----------------%
| Error checking |
%----------------% */
ierr = 0;
ishift = iparam[1];
levec = iparam[2];
mxiter = iparam[3];
nb = iparam[4];
/* %--------------------------------------------%
| Revision 2 performs only implicit restart. |
%--------------------------------------------% */
iupd = 1;
mode = iparam[7];
if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev + 1 || *ncv > *n) {
ierr = -3;
} else if (mxiter <= 0) {
ierr = -4;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(
which, "SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR",
(ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (
ftnlen)2) != 0 && s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) !=
0 && s_cmp(which, "SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat !=
'G') {
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + *ncv * 6) {
ierr = -7;
} else if (mode < 1 || mode > 5) {
ierr = -10;
} else if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
} else if (ishift < 0 || ishift > 1) {
ierr = -12;
}
}
/* %------------%
| Error Exit |
%------------% */
if (ierr != 0) {
*info = ierr;
*ido = 99;
goto L9000;
}
/* %------------------------%
| Set default parameters |
%------------------------% */
if (nb <= 0) {
nb = 1;
}
if (*tol <= 0.) {
*tol = igraphdlamch_("EpsMach");
}
/* %----------------------------------------------%
| NP is the number of additional steps to |
| extend the length NEV Lanczos factorization. |
| NEV0 is the local variable designating the |
| size of the invariant subspace desired. |
%----------------------------------------------% */
np = *ncv - *nev;
nev0 = *nev;
/* %-----------------------------%
| Zero out internal workspace |
%-----------------------------%
Computing 2nd power */
i__2 = *ncv;
i__1 = i__2 * i__2 * 3 + *ncv * 6;
for (j = 1; j <= i__1; ++j) {
workl[j] = 0.;
/* L10: */
}
/* %-------------------------------------------------------------%
| Pointer into WORKL for address of H, RITZ, BOUNDS, Q |
| etc... and the remaining workspace. |
| Also update pointer to be used on output. |
| Memory is laid out as follows: |
| workl(1:ncv*ncv) := generated Hessenberg matrix |
| workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary |
| parts of ritz values |
| workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds |
| workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q |
| workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace |
| The final workspace is needed by subroutine dneigh called |
| by dnaup2. Subroutine dneigh calls LAPACK routines for |
| calculating eigenvalues and the last row of the eigenvector |
| matrix. |
%-------------------------------------------------------------% */
ldh = *ncv;
ldq = *ncv;
ih = 1;
ritzr = ih + ldh * *ncv;
ritzi = ritzr + *ncv;
bounds = ritzi + *ncv;
iq = bounds + *ncv;
iw = iq + ldq * *ncv;
/* Computing 2nd power */
i__1 = *ncv;
next = iw + i__1 * i__1 + *ncv * 3;
ipntr[4] = next;
ipntr[5] = ih;
ipntr[6] = ritzr;
ipntr[7] = ritzi;
ipntr[8] = bounds;
ipntr[14] = iw;
}
/* %-------------------------------------------------------%
| Carry out the Implicitly restarted Arnoldi Iteration. |
%-------------------------------------------------------% */
igraphdnaup2_(ido, bmat, n, which, &nev0, &np, tol, &resid[1], &mode, &iupd, &
ishift, &mxiter, &v[v_offset], ldv, &workl[ih], &ldh, &workl[
ritzr], &workl[ritzi], &workl[bounds], &workl[iq], &ldq, &workl[
iw], &ipntr[1], &workd[1], info);
/* %--------------------------------------------------%
| ido .ne. 99 implies use of reverse communication |
| to compute operations involving OP or shifts. |
%--------------------------------------------------% */
if (*ido == 3) {
iparam[8] = np;
}
if (*ido != 99) {
goto L9000;
}
iparam[3] = mxiter;
iparam[5] = np;
iparam[9] = nopx;
iparam[10] = nbx;
iparam[11] = nrorth;
/* %------------------------------------%
| Exit if there was an informational |
| error within dnaup2. |
%------------------------------------% */
if (*info < 0) {
goto L9000;
}
if (*info == 2) {
*info = 3;
}
if (msglvl > 0) {
igraphivout_(&logfil, &c__1, &mxiter, &ndigit, "_naupd: Number of update i"
"terations taken", (ftnlen)41);
igraphivout_(&logfil, &c__1, &np, &ndigit, "_naupd: Number of wanted \"con"
"verged\" Ritz values", (ftnlen)48);
igraphdvout_(&logfil, &np, &workl[ritzr], &ndigit, "_naupd: Real part of t"
"he final Ritz values", (ftnlen)42);
igraphdvout_(&logfil, &np, &workl[ritzi], &ndigit, "_naupd: Imaginary part"
" of the final Ritz values", (ftnlen)47);
igraphdvout_(&logfil, &np, &workl[bounds], &ndigit, "_naupd: Associated Ri"
"tz estimates", (ftnlen)33);
}
igraphsecond_(&t1);
tnaupd = t1 - t0;
if (msglvl > 0) {
/* %--------------------------------------------------------%
| Version Number & Version Date are defined in version.h |
%--------------------------------------------------------% */
s_wsfe(&io___30);
e_wsfe();
s_wsfe(&io___31);
do_fio(&c__1, (char *)&mxiter, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nopx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nbx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrorth, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nitref, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrstrt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&tmvopx, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tmvbx, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tnaupd, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tnaup2, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tnaitr, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&titref, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tgetv0, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tneigh, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tngets, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tnapps, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&tnconv, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&trvec, (ftnlen)sizeof(real));
e_wsfe();
}
L9000:
return 0;
/* %---------------%
| End of dnaupd |
%---------------% */
} /* igraphdnaupd_ */
/* $Procedure WRLINE ( Write Output Line to a Device ) */
/* Subroutine */ int wrline_0_(int n__, char *device, char *line, ftnlen
device_len, ftnlen line_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
integer *, char *, ftnlen), e_wsfe(void), f_inqu(inlist *),
s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), f_open(olist *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer f_clos(cllist *);
/* Local variables */
integer unit;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
extern integer ltrim_(char *, ftnlen);
char error[240];
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
logical opened;
extern /* Subroutine */ int fndlun_(integer *);
char tmpnam[128];
integer iostat;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
logical exists;
char errstr[11];
extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 6, 0, 0, 0 };
static cilist io___7 = { 0, 6, 0, 0, 0 };
static cilist io___8 = { 0, 6, 0, 0, 0 };
static cilist io___9 = { 0, 6, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, 0, 0 };
static cilist io___11 = { 0, 6, 0, 0, 0 };
static cilist io___12 = { 0, 6, 0, 0, 0 };
static cilist io___15 = { 0, 6, 0, 0, 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___17 = { 0, 6, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Write a character string to an output device. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* TEXT */
/* FILES */
/* ERROR */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* DEVICE I A string specifying an output device. */
/* LINE I A line of text to be output. */
/* FILEN P Maximum length of a file name. */
/* $ Detailed_Input */
/* LINE is a line of text to be written to the output */
/* device specified by DEVICE. */
/* DEVICE is the output device to which the line of text */
/* will be written. */
/* Possible values and meanings of DEVICE are: */
/* a device name This may be the name of a */
/* file, or any other name that */
/* is valid in a FORTRAN OPEN */
/* statement. For example, on a */
/* VAX, a logical name may be */
/* used. */
/* The device name must not */
/* be any of the reserved strings */
/* below. */
/* 'SCREEN' The output will go to the */
/* terminal screen. */
/* 'NULL' The data will not be output. */
/* 'SCREEN' and 'NULL' can be written in mixed */
/* case. For example, the following call will work: */
/* CALL WRLINE ( 'screEn', LINE ) */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* FILEN is the maximum length of a file name. */
/* $ Exceptions */
/* This routine is a special case as far as error handling */
/* is concerned because it is called to output error */
/* messages resulting from errors detected by other routines. */
/* In such a case, calling SIGERR would constitute recursion. */
/* Therefore, this routine prints error messages rather */
/* than signalling errors via SIGERR and setting the long */
/* error message via SETMSG. */
/* The following exceptional cases are treated as errors: */
/* 1) SPICE(NOFREELOGICALUNIT) -- No logical unit number */
/* is available to refer to the device. */
/* 2) SPICE(FILEOPENFAILED) -- General file open error. */
/* 3) SPICE(FILEWRITEFAILED) -- General file write error. */
/* 4) SPICE(INQUIREFAILED) -- INQUIRE statement failed. */
/* 5) Leading blanks in (non-blank) file names are not */
/* significant. The file names */
/* 'MYFILE.DAT' */
/* ' MYFILE.DAT' */
/* are considered to name the same file. */
/* 6) If different names that indicate the same file are supplied */
/* to this routine on different calls, all output associated */
/* with these calls WILL be written to the file. For example, */
/* on a system where logical filenames are supported, if */
/* ALIAS is a logical name pointing to MYFILE, then the calls */
/* CALL WRLINE ( 'MYFILE', 'This is the first line' ) */
/* CALL WRLINE ( 'ALIAS', 'This is the second line' ) */
/* will place the lines of text */
/* 'This is the first line' */
/* 'This is the second line' */
/* in MYFILE. See $Restrictions for more information on use */
/* of logical names on VAX systems. */
/* $ Files */
/* 1) If DEVICE specifies a device other than 'SCREEN' or 'NULL', */
/* that device is opened (if it's not already open) as a NEW, */
/* SEQUENTIAL, FORMATTED file. The logical unit used is */
/* determined at run time. */
/* $ Particulars */
/* If the output device is a file that is not open, the file will */
/* be opened (if possible) as a NEW, sequential, formatted file, */
/* and the line of text will be written to the file. If the file */
/* is already opened as a sequential, formatted file, the line of */
/* text will be written to the file. */
/* Use the entry point CLLINE to close files opened by WRLINE. */
/* $ Examples */
/* 1) Write a message to the screen: */
/* CALL WRLINE ( 'SCREEN', 'Here''s a message.' ) */
/* The text */
/* Here's a message. */
/* will be written to the screen. */
/* 2) Write out all of the elements of a character string array */
/* to a file. */
/* CHARACTER*(80) STRING ( ASIZE ) */
/* . */
/* . */
/* . */
/* DO I = 1, ASIZE */
/* CALL WRLINE ( FILE, STRING(I) ) */
/* END DO */
/* 3) Set DEVICE to NULL to suppress output: */
/* C */
/* C Ask the user whether verbose program output is */
/* C desired. Set the output device accordingly. */
/* C */
/* WRITE (*,*) 'Do you want to see test results ' // */
/* . 'on the screen?' */
/* READ (*,FMT='(A)') VERBOS */
/* CALL LJUST ( VERBOS, VERBOS ) */
/* CALL UCASE ( VERBOS, VERBOS ) */
/* IF ( VERBOS(1:1) .EQ. 'Y' ) THEN */
/* DEVICE = 'SCREEN' */
/* ELSE */
/* DEVICE = 'NULL' */
/* ENDIF */
/* . */
/* . */
/* . */
/* C */
/* C Output test results. */
/* C */
/* CALL WRLINE ( DEVICE, STRING ) */
/* . */
/* . */
/* . */
/* $ Restrictions */
/* 1) File names must not exceed FILEN characters. */
/* 2) On VAX systems, caution should be exercised when using */
/* multiple logical names to point to the same file. Logical */
/* name translation supporting execution of the Fortran */
/* INQUIRE statement does not appear to work reliably in all */
/* cases, which may lead this routine to believe that different */
/* logical names indicate different files. The specific problem */
/* that has been observed is that logical names that include */
/* disk specifications are not always recognized as pointing */
/* to the file they actually name. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - SPICELIB Version 4.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 4.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 4.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 4.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 4.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 4.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 4.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 4.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 4.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 4.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 4.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 4.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 4.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 4.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 4.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 4.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 4.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 4.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 4.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 4.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 4.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 4.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 4.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 4.0.3, 16-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 4.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 4.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 4.0.0, 07-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. The */
/* write format for the case where the output device is the */
/* screen has been made system-dependent; list-directed output */
/* format is now used for systems that require a leading carriage */
/* control character; other systems use character format. The */
/* write format for the case where the output device is a file */
/* has been changed from list-directed to character. */
/* - SPICELIB Version 3.0.0, 11-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* and the appropriate OPEN statement for the Silicon */
/* Graphics, DEC Alpha-OSF/1, and NeXT platforms. The previous */
/* value of 256 for Unix platforms was changed to 255. */
/* - SPICELIB Version 2.1.0, 13-OCT-1992 (HAN) */
/* Module was updated to include the value of FILEN for the */
/* Hewlett Packard UX 9000/750 environment. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* This routine now can write to files that have been opened */
/* by other routines. */
/* The limit imposed by this routine on the number of files it */
/* can open has been removed. */
/* The output file is now opened as a normal text file on */
/* VAX systems. */
/* Improper treatment of the case where DEVICE is blank was */
/* remedied. */
/* Unneeded variable declarations and references were removed. */
/* Initialization of SAVED variables was added. */
/* All occurrences of "PRINT *" have been replaced by */
/* "WRITE (*,*)". */
/* Calls to UCASE and LJUST replace in-line code that performed */
/* these operations. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* write output line to a device */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 4.0.0, 07-APR-1998 (NJB) */
/* References to the PC-LINUX environment were added. */
/* The write format for the case where the output device is the */
/* screen has been made system-dependent; list-directed output */
/* format is now used for systems that require a leading carriage */
/* control character; other systems use character format. The */
/* write format for the case where the output device is a file */
/* has been changed from list-directed to character. */
/* - SPICELIB Version 3.0.0, 11-NOV-1993 (HAN) */
/* Module was updated to include the value for FILEN */
/* and the appropriate OPEN statement for the Silicon */
/* Graphics, DEC Alpha-OSF/1, and NeXT platforms. The previous */
/* value of 256 for Unix platforms was changed to 255. */
/* - SPICELIB Version 2.1.0, 13-OCT-1992 (HAN) */
/* Module was updated to include the value of FILEN for the */
/* Hewlett Packard UX 9000/750 environment. */
/* The code was also reformatted so that a utility program can */
/* create the source file for a specific environment given a */
/* master source file. */
/* - SPICELIB Version 2.0.0, 25-MAR-1991 (NJB) */
/* 1) This routine now can write to files that have been opened */
/* by other routines. WRLINE uses an INQUIRE statement to */
/* determine whether the file indicated by DEVICE is open, */
/* and if it is, WRLINE does not attempt to open it. This */
/* allows use of WRLINE to feed error output into a log file */
/* opened by another routine. */
/* The header has been updated accordingly. */
/* This fix also fixes a bug wherein this routine would treat */
/* different character strings naming the same file as though */
/* they indicated different files. */
/* 2) The limit imposed by this routine on the number of files it */
/* can open has been removed. The file database used in */
/* previous versions of this routine is no longer used. */
/* 3) On VAX systems, this routine now opens the output file */
/* (when required to do so) as a normal text file. */
/* 4) Improper treatment of the case where DEVICE is blank was */
/* remedied. Any value of DEVICE that is not equal to */
/* 'SCREEN' or 'NULL' after being left-justified and */
/* converted to upper case is considered to be a file name. */
/* 5) Unneeded variable declarations and references were removed. */
/* The arrays called STATUS and FILES are not needed. */
/* 6) All instances if "PRINT *" have been replaced by */
/* "WRITE (*,*)" because Language Systems Fortran on the */
/* Macintosh interprets "PRINT *" in a non-standard manner. */
/* 7) Use of the EXIST specifier was added to the INQUIRE */
/* statement used to determine whether the file named by */
/* DEVICE is open. This is a work-around for a rather */
/* peculiar behavior of at least one version of Sun Fortran: */
/* files that don't exist may be considered to be open, as */
/* indicated by the OPENED specifier of the INQUIRE statement. */
/* 8) One other thing: now that LJUST and UCASE are error-free, */
/* WRLINE uses them; this simplifies the code. */
/* - Beta Version 1.2.0, 27-FEB-1989 (NJB) */
/* Call to GETLUN replaced by call to FNDLUN, which is error-free. */
/* Call to IOERR replaced with in-line code to construct long */
/* error message indicating file open failure. Arrangement of */
/* declarations changed. Keywords added. FILEN declaration */
/* moved to "declarations" section. Parameters section added. */
/* - Beta Version 1.1.0, 06-OCT-1988 (NJB) */
/* Upper bound of written substring changed to prevent use of */
/* invalid substring bound. Specifically, LASTNB ( LINE ) was */
/* replaced by MAX ( 1, LASTNB (LINE) ). This upper bound */
/* now used in the PRINT statement as well. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Executable Code: */
switch(n__) {
case 1: goto L_clline;
}
ljust_(device, tmpnam, device_len, (ftnlen)128);
ucase_(tmpnam, tmpnam, (ftnlen)128, (ftnlen)128);
/* TMPNAM is now left justified and is in upper case. */
if (s_cmp(tmpnam, "NULL", (ftnlen)128, (ftnlen)4) == 0) {
return 0;
} else if (s_cmp(tmpnam, "SCREEN", (ftnlen)128, (ftnlen)6) == 0) {
ci__1.cierr = 1;
ci__1.ciunit = 6;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, rtrim_(line, line_len));
if (iostat != 0) {
goto L100001;
}
iostat = e_wsfe();
L100001:
return 0;
}
/* Find out whether we'll need to open the file. */
/* We use the EXIST inquiry specifier because files that don't exist */
/* may be (possibly due to a Sun compiler bug) deemed to be OPEN by */
/* Sun Fortran. */
i__1 = ltrim_(device, device_len) - 1;
ioin__1.inerr = 1;
ioin__1.infilen = device_len - i__1;
ioin__1.infile = device + i__1;
ioin__1.inex = &exists;
ioin__1.inopen = &opened;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
/* This is weird. How can an INQUIRE statement fail, */
/* if the syntax is correct? But just in case... */
s_wsle(&io___6);
do_lio(&c__9, &c__1, "SPICE(INQUIREFAILED)", (ftnlen)20);
e_wsle();
s_wsle(&io___7);
do_lio(&c__9, &c__1, "WRLINE: File = ", (ftnlen)15);
do_lio(&c__9, &c__1, device, device_len);
do_lio(&c__9, &c__1, "IOSTAT = ", (ftnlen)9);
do_lio(&c__3, &c__1, (char *)&iostat, (ftnlen)sizeof(integer));
e_wsle();
return 0;
}
if (! (opened && exists)) {
/* We will need a free logical unit. There is always the chance */
/* that no units are available. */
fndlun_(&unit);
if (unit < 1) {
s_wsle(&io___8);
do_lio(&c__9, &c__1, "SPICE(NOFREELOGICALUNIT)", (ftnlen)24);
e_wsle();
s_wsle(&io___9);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_wsle(&io___10);
do_lio(&c__9, &c__1, "WRLINE: Maximum number of logical units th"
"at can be allocated by SPICELIB has already been reached",
(ftnlen)98);
e_wsle();
return 0;
}
/* Okay, we have a unit. Open the file, and hope nothing */
/* goes awry. (On the VAX, the qualifier */
/* CARRIAGECONTROL = 'LIST' */
/* may be inserted into the OPEN statement.) */
i__1 = ltrim_(device, device_len) - 1;
o__1.oerr = 1;
o__1.ounit = unit;
o__1.ofnmlen = device_len - i__1;
o__1.ofnm = device + i__1;
o__1.orl = 0;
o__1.osta = "NEW";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
s_wsle(&io___11);
do_lio(&c__9, &c__1, "SPICE(FILEOPENFAILED)", (ftnlen)21);
e_wsle();
s_wsle(&io___12);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
s_copy(error, "WRLINE: An error occurred while attempting to open"
, (ftnlen)240, (ftnlen)50);
suffix_(device, &c__1, error, device_len, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
suffix_("The value of IOSTAT returned was", &c__2, error, (ftnlen)
32, (ftnlen)240);
suffix_(":", &c__0, error, (ftnlen)1, (ftnlen)240);
intstr_(&iostat, errstr, (ftnlen)11);
suffix_(errstr, &c__1, error, (ftnlen)11, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
s_wsle(&io___15);
do_lio(&c__9, &c__1, error, (ftnlen)240);
e_wsle();
return 0;
}
/* Whew! We're ready to write to this file. */
}
/* At this point, either we opened the file, or it was already */
/* opened by somebody else. */
/* This is the easy part. Write the next line to the file. */
ci__1.cierr = 1;
ci__1.ciunit = unit;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, line, rtrim_(line, line_len));
if (iostat != 0) {
goto L100002;
}
iostat = e_wsfe();
L100002:
/* Well, what happened? Any non-zero value for IOSTAT indicates */
/* an error. */
if (iostat != 0) {
s_copy(error, "WRLINE: An error occurred while attempting to WRITE t"
"o ", (ftnlen)240, (ftnlen)55);
suffix_(device, &c__1, error, device_len, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
suffix_("The value of IOSTAT returned was", &c__2, error, (ftnlen)32,
(ftnlen)240);
suffix_(":", &c__0, error, (ftnlen)1, (ftnlen)240);
intstr_(&iostat, errstr, (ftnlen)11);
suffix_(errstr, &c__1, error, (ftnlen)11, (ftnlen)240);
suffix_(".", &c__0, error, (ftnlen)1, (ftnlen)240);
s_wsle(&io___16);
do_lio(&c__9, &c__1, error, (ftnlen)240);
e_wsle();
return 0;
}
return 0;
/* $Procedure CLLINE ( Close a device ) */
L_clline:
/* $ Abstract */
/* Close a device. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* TEXT, FILES, ERROR */
/* $ Declarations */
/* CHARACTER*(*) DEVICE */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* DEVICE I Device to be closed. */
/* $ Detailed_Input */
/* DEVICE is the name of a device which is currently */
/* opened for reading or writing. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* This routine is called by SPICELIB error handling routines, so */
/* it cannot use the normal SPICELIB error signalling mechanism. */
/* Instead, it writes error messages to the screen if necessary. */
/* 1) If the device indicated by DEVICE was not opened by WRLINE, */
/* this routine closes it anyway. */
/* 2) If the INQUIRE performed by this routine fails, an error */
/* diagnosis is printed to the screen. */
/* $ Files */
/* This routin */
/* $ Particulars */
/* CLLINE closes a device that is currently open. */
/* $ Examples */
/* 1) Write two lines to the file, SPUD.DAT (VAX file name */
/* syntax), and then close the file. */
/* CALL WRLINE ( 'SPUD.DAT', ' This is line 1 ' ) */
/* CALL WRLINE ( 'SPUD.DAT', ' This is line 2 ' ) */
/* CALL CLLINE ( 'SPUD.DAT' ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 4.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 4.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 4.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* All occurrences of "PRINT *" have been replaced by */
/* "WRITE (*,*)". */
/* Also, this routine now closes the device named by DEVICE */
/* whether or not the device was opened by WRLINE. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* None. */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 26-MAR-1991 (NJB) */
/* All instances if "PRINT *" have been replaced by "WRITE (*,*)" */
/* because Language Systems Fortran on the Macintosh interprets */
/* "PRINT *" in a non-standard manner. */
/* This routine no longer has to maintain the file database, since */
/* WRLINE does not use it any more. */
/* Also, this routine now closes the device named by DEVICE, */
/* whether or not the device was opened by WRLINE. */
/* - Beta Version 1.0.1, 08-NOV-1988 (NJB) */
/* Keywords added. */
/* -& */
/* Find the unit connected to DEVICE. */
i__1 = ltrim_(device, device_len) - 1;
ioin__1.inerr = 1;
ioin__1.infilen = device_len - i__1;
ioin__1.infile = device + i__1;
ioin__1.inex = 0;
ioin__1.inopen = 0;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
/* This is weird. How can an INQUIRE statement fail, */
/* if the syntax is correct? But just in case... */
s_wsle(&io___17);
do_lio(&c__9, &c__1, "SPICE(INQUIREFAILED)", (ftnlen)20);
e_wsle();
s_wsle(&io___18);
do_lio(&c__9, &c__1, "CLLINE: File = ", (ftnlen)16);
do_lio(&c__9, &c__1, device, device_len);
do_lio(&c__9, &c__1, "IOSTAT = ", (ftnlen)9);
do_lio(&c__3, &c__1, (char *)&iostat, (ftnlen)sizeof(integer));
e_wsle();
return 0;
}
cl__1.cerr = 0;
cl__1.cunit = unit;
cl__1.csta = 0;
f_clos(&cl__1);
return 0;
} /* wrline_ */
shortlogical hl_le(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
return(s_cmp(a,b,la,lb) <= 0);
}
/* $ Procedure TIMECN (Convert and round times) */
/* Subroutine */ int timecn_(doublereal *tconv, integer *ids, char *tout,
char *linet, ftnlen tout_len, ftnlen linet_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int sct2e_(integer *, doublereal *, doublereal *),
dpfmt_(doublereal *, char *, char *, ftnlen, ftnlen), reset_(
void);
extern logical failed_(void);
extern /* Subroutine */ int scdecd_(integer *, doublereal *, char *,
ftnlen);
integer sc;
logical ok;
extern /* Subroutine */ int ckmeta_(integer *, char *, integer *, ftnlen),
erract_(char *, char *, ftnlen, ftnlen);
doublereal ettime;
extern /* Subroutine */ int fixuni_(void), errprt_(char *, char *, ftnlen,
ftnlen), timout_(doublereal *, char *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* This is internal subroutine for CKBRIEF program. It converts */
/* time between encoded SCLK, SCLK string, ET, UTC or UTC/DOY. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Keywords */
/* SUMMARY */
/* C KERNEL */
/* $ Declarations */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Author_and_Institution */
/* Y.K. Zaiko (BERC) */
/* B.V. Semenov (NAIF) */
/* $ Version */
/* - Toolkit Version 6.1.0, 27-JUN-2014 (BVS) */
/* BUG FIX: changed logic to make a combination of -a and an ID */
/* specified on the command line work in all cases. */
/* - CKBRIEF Version 6.0.0, 2014-04-28 (BVS) (NJB) */
/* Modified to treat all files as a single file (-a). */
/* Changed SCLKD display format to include 6 decimal */
/* places. */
/* Increased MAXBOD to 1,000,000 (from 100,000) and CMDSIZ to */
/* 50,000 (from 25,000). */
/* Added support for CK type 6. */
/* - CKBRIEF Version 5.0.0, 2009-02-11 (BVS) */
/* Updated version. */
/* - CKBRIEF Version 4.0.0, 2008-01-13 (BVS) */
/* Increased MAXBOD to 100,000 (from 10,000). */
/* Increased CMDSIZ to 25,000 (from 4,000). */
/* Updated version string and changed its format to */
/* '#.#.#, Month DD, YYYY' (from '#.#.#, YYYY-MM-DD'). */
/* - CKBRIEF Version 3.2.0, 2006-11-02 (BVS) */
/* Updated version string. */
/* - CKBRIEF Version 3.1.0, 2005-11-08 (BVS) */
/* Updated version string. */
/* - CKBRIEF Version 2.0.0, 2001-05-16 (BVS) */
/* Increased MAXBOD to 10000 (from 4000). Set LRGWIN to be */
/* MAXBOD*2 (was MAXBOD). Changed version string. */
/* - CKBRIEF Version 1.1.2, 2001-04-09 (BVS) */
/* Changed version parameter. */
/* - CKBRIEF Version 1.0.0 beta, 1999-02-17 (YKZ)(BVS) */
/* Initial release. */
/* -& */
/* The Version is stored as a string. */
/* The maximum number of segments or interpolation intervals */
/* that can be summarized is stored in the parameter MAXBOD. */
/* This is THE LIMIT that should be increased if window */
/* routines called by CKBRIEF fail. */
/* The largest expected window -- must be twice the size of */
/* MAXBOD for consistency. */
/* The longest command line that can be accommodated is */
/* given by CMDSIZ. */
/* MAXUSE is the maximum number of objects that can be explicitly */
/* specified on the command line for ckbrief summaries. */
/* Generic line size for all modules. */
/* Time type keys. */
/* Output time format pictures. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TCONV I Encoded SCLK time */
/* IDS I NAIF ID code of object */
/* TOUT I Form of time representation on output */
/* LINET O Text presentation of time */
/* $ Detailed Input */
/* TCONV Encoded SCLK time to be converted, rounded */
/* and decoded to character string */
/* IDS Integer NAIF ID code found in summary from which */
/* TCONV was obtained. */
/* TOUT Key specifying time presentation on output: */
/* SCLK string, encoded SCLK, ET, UTC or DOY UTC. */
/* $ Detailed Output */
/* LINET Character string which contains time converted */
/* to requested representation or NOTIME flag if */
/* conversion was not possible. */
/* $ Parameters */
/* None. */
/* $ Files */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* Y.K. Zaiko (BERC) */
/* B.V. Semenov (NAIF) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - CKBRIEF Beta Version 1.0.0, 17-FEB-1999 (YKZ)(BVS) */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Reset output time string. */
s_copy(linet, " ", linet_len, (ftnlen)1);
/* It is necessary to use real spacecraft ID in SCLK<->ET */
/* conversion routines. CKMETA is providing it. */
ckmeta_(ids, "SCLK", &sc, (ftnlen)4);
/* TIMECN is the special routine to be used in CKBRIEF */
/* utility to convert times in accordance to user request. If user */
/* haven't provided ancillary files to perform this conversion, the */
/* program shouldn't stop. To achieve this we'll forbid TIMECN to */
/* be aborted by SPICELIB standard error processing if it can't */
/* convert times. On the exit from TIMECN, SPICE error handling */
/* is restored to its original state. */
erract_("SET", "RETURN", (ftnlen)3, (ftnlen)6);
errprt_("SET", "NONE", (ftnlen)3, (ftnlen)4);
/* We do appropriate conversion depending on the requested output */
/* time representation. If SCLK for the s/c of interest and(!) */
/* LSK file weren't loaded, conversions to string SCLK, ET, UTC */
/* and UTC/DOY are not possible. The output time set to NOTIME */
/* flag. */
if (s_cmp(tout, "TICKS", tout_len, (ftnlen)5) == 0) {
/* DP SLCKs should be simply converted to string. */
dpfmt_(tconv, "xxxxxxxxxxxxxx.xxxxxx", linet, (ftnlen)21, linet_len);
} else if (s_cmp(tout, "SCLK", tout_len, (ftnlen)4) == 0) {
/* SCLK string is computed from DP SCLK if it's possible. */
scdecd_(&sc, tconv, linet, linet_len);
if (failed_()) {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)23);
}
} else if (s_cmp(tout, "ET", tout_len, (ftnlen)2) == 0) {
/* Calendar ET is computed by converting DP SCLK to ET seconds */
/* and converting them further to ET calendar string */
sct2e_(&sc, tconv, &ettime);
if (! failed_()) {
timout_(&ettime, "YYYY-MON-DD HR:MN:SC.### ::TDB", linet, (ftnlen)
30, linet_len);
if (failed_()) {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)
23);
}
} else {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)23);
}
} else if (s_cmp(tout, "UTC", tout_len, (ftnlen)3) == 0) {
/* UTC time is computed by converting DP SCLK to ET seconds, */
/* which after that converted to UTC string. */
sct2e_(&sc, tconv, &ettime);
if (! failed_()) {
timout_(&ettime, "YYYY-MON-DD HR:MN:SC.###", linet, (ftnlen)24,
linet_len);
if (failed_()) {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)
23);
}
} else {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)23);
}
} else if (s_cmp(tout, "UTC/DOY", tout_len, (ftnlen)7) == 0) {
/* UTCDOY time is computed by converting DP SCLK to ET seconds, */
/* which after that converted to UTC string. */
sct2e_(&sc, tconv, &ettime);
if (! failed_()) {
timout_(&ettime, "YYYY-DOY // HR:MN:SC.###", linet, (ftnlen)24,
linet_len);
if (failed_()) {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)
23);
}
} else {
s_copy(linet, "NEED LSK AND SCLK FILES", linet_len, (ftnlen)23);
}
}
ok = ! failed_();
/* Now we can reset SPICE error handling mechanism back to its */
/* original state. */
reset_();
erract_("SET", "ABORT", (ftnlen)3, (ftnlen)5);
errprt_("SET", "DEFAULT", (ftnlen)3, (ftnlen)7);
/* There is a bug in UNITIM (trace: SCT2E --> SCTE01 --> UNITIM) */
/* that has to be temporarily fixed before UNITIM officially fixed */
/* in N0049 delivery. Call to a specially written routine FIXUNI */
/* does that. */
if (! ok) {
fixuni_();
}
return 0;
} /* timecn_ */
/* Subroutine */ int matout_(doublereal *a, doublereal *b, integer *nc,
integer *nnr, integer *ndim)
{
/* Initialized data */
static char atorbs[2*9] = " S" "PX" "PY" "PZ" "X2" "XZ" "Z2" "YZ" "XY";
/* Format strings */
static char fmt_100[] = "(////,3x,\002 ROOT NO.\002,i5,9i12)";
static char fmt_110[] = "(/8x,10f12.5)";
static char fmt_120[] = "(\002 \002)";
static char fmt_130[] = "(2(1x,a2),i4,f10.5,10f12.5)";
static char fmt_140[] = "(\0021\002)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer i__, j, k, l, ka, kb, kc, la, lc, lb, nr, jhi, jlo, natom[
420];
static char itext[2*420], jtext[2*420];
/* Fortran I/O blocks */
static cilist io___15 = { 0, 6, 0, fmt_100, 0 };
static cilist io___16 = { 0, 6, 0, fmt_110, 0 };
static cilist io___17 = { 0, 6, 0, fmt_120, 0 };
static cilist io___21 = { 0, 6, 0, fmt_120, 0 };
static cilist io___22 = { 0, 6, 0, fmt_130, 0 };
static cilist io___23 = { 0, 6, 0, fmt_140, 0 };
static cilist io___24 = { 0, 6, 0, fmt_140, 0 };
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
/* ********************************************************************** */
/* MATOUT PRINTS A SQUARE MATRIX OF EIGENVECTORS AND EIGENVALUES */
/* ON INPUT A CONTAINS THE MATRIX TO BE PRINTED. */
/* B CONTAINS THE EIGENVALUES. */
/* NC NUMBER OF MOLECULAR ORBITALS TO BE PRINTED. */
/* NR IS THE SIZE OF THE SQUARE ARRAY TO BE PRINTED. */
/* NDIM IS THE ACTUAL SIZE OF THE SQUARE ARRAY "A". */
/* NFIRST AND NLAST CONTAIN ATOM ORBITAL COUNTERS. */
/* NAT = ARRAY OF ATOMIC NUMBERS OF ATOMS. */
/* *********************************************************************** */
/* Parameter adjustments */
--b;
a_dim1 = *ndim;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
nr = *nnr;
if (molkst_1.numat == 0) {
goto L30;
}
if (molkst_1.nlast[molkst_1.numat - 1] != nr) {
goto L30;
}
i__1 = molkst_1.numat;
for (i__ = 1; i__ <= i__1; ++i__) {
jlo = molkst_1.nfirst[i__ - 1];
jhi = molkst_1.nlast[i__ - 1];
l = molkst_1.nat[i__ - 1];
k = 0;
i__2 = jhi;
for (j = jlo; j <= i__2; ++j) {
++k;
s_copy(itext + (j - 1 << 1), atorbs + (k - 1 << 1), (ftnlen)2, (
ftnlen)2);
s_copy(jtext + (j - 1 << 1), elemts_1.elemnt + (l - 1 << 1), (
ftnlen)2, (ftnlen)2);
natom[j - 1] = i__;
/* L10: */
}
/* L20: */
}
goto L50;
L30:
nr = abs(nr);
i__1 = nr;
for (i__ = 1; i__ <= i__1; ++i__) {
s_copy(itext + (i__ - 1 << 1), " ", (ftnlen)2, (ftnlen)2);
s_copy(jtext + (i__ - 1 << 1), " ", (ftnlen)2, (ftnlen)2);
/* L40: */
natom[i__ - 1] = i__;
}
L50:
ka = 1;
kc = 6;
L60:
kb = min(kc,*nc);
s_wsfe(&io___15);
i__1 = kb;
for (i__ = ka; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
if (b[1] != 0.) {
s_wsfe(&io___16);
i__1 = kb;
for (i__ = ka; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&b[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
}
s_wsfe(&io___17);
e_wsfe();
la = 1;
lc = 40;
L70:
lb = min(lc,nr);
i__1 = lb;
for (i__ = la; i__ <= i__1; ++i__) {
if (s_cmp(itext + (i__ - 1 << 1), " S", (ftnlen)2, (ftnlen)2) == 0) {
s_wsfe(&io___21);
e_wsfe();
}
s_wsfe(&io___22);
do_fio(&c__1, itext + (i__ - 1 << 1), (ftnlen)2);
do_fio(&c__1, jtext + (i__ - 1 << 1), (ftnlen)2);
do_fio(&c__1, (char *)&natom[i__ - 1], (ftnlen)sizeof(integer));
i__2 = kb;
for (j = ka; j <= i__2; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L80: */
}
if (lb == nr) {
goto L90;
}
la = lc + 1;
lc += 40;
s_wsfe(&io___23);
e_wsfe();
goto L70;
L90:
if (kb == *nc) {
return 0;
}
ka = kc + 1;
kc += 6;
if (nr > 25) {
s_wsfe(&io___24);
e_wsfe();
}
goto L60;
} /* matout_ */
/* $Procedure FRSTNB ( First non-blank character ) */
integer frstnb_(char *string, ftnlen string_len)
{
/* System generated locals */
integer ret_val, i__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), i_len(char *, ftnlen);
/* Local variables */
integer i__;
/* $ Abstract */
/* Return the index of the first non-blank character in */
/* a character string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* ASCII, CHARACTER, SEARCH */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STRING I Input character string. */
/* FRSTNB O Index of the first non-blank character in STRING. */
/* $ Detailed_Input */
/* STRING is the input character string. */
/* $ Detailed_Output */
/* FRSTNB is the index if the first non-blank character */
/* in the input string. If there are no non-blank */
/* characters in the string, FRSTNB is zero. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* If the string is blank, return zero. Otherwise, step through */
/* the string one character at a time until something other than */
/* a blank is found. Return the index of that something within */
/* the string. */
/* $ Examples */
/* The following examples illustrate the use of FRSTNB. */
/* FRSTNB ( 'ABCDE' ) = 1 */
/* FRSTNB ( 'AN EXAMPLE' ) = 1 */
/* FRSTNB ( ' AN EXAMPLE' ) = 4 */
/* FRSTNB ( ' ' ) = 0 */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.0.0, 12-MAR-1996 (KRG) */
/* Modified the comparison to use integer values and the ICHAR() */
/* function. This improves the performance of the subroutine. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* first non-blank character */
/* -& */
/* Local parameters */
/* Local variables */
/* Just like it says in the header. */
if (s_cmp(string, " ", string_len, (ftnlen)1) == 0) {
ret_val = 0;
} else {
i__1 = i_len(string, string_len);
for (i__ = 1; i__ <= i__1; ++i__) {
if (*(unsigned char *)&string[i__ - 1] != 32) {
ret_val = i__;
return ret_val;
}
}
}
return ret_val;
} /* frstnb_ */
/* $Procedure HX2INT ( Signed hexadecimal string to integer ) */
/* Subroutine */ int hx2int_(char *string, integer *number, logical *error,
char *errmsg, ftnlen string_len, ftnlen errmsg_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
char ch__1[1];
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen);
/* Local variables */
static integer mini, maxi;
logical more;
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
static integer iplus, lccbeg, digbeg, lccend, uccbeg, digend, uccend,
ispace;
integer idigit;
static integer minmod, maxmod;
integer strbeg;
logical negtiv;
extern integer intmin_(void), intmax_(void);
integer letter, strend;
static integer iminus;
integer tmpnum, pos;
/* $ Abstract */
/* Convert a signed hexadecimal string representation of an integer */
/* to its equivalent integer. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* ALPHANUMERIC */
/* CONVERSION */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STRING I Hexadecimal string to be converted to an integer. */
/* NUMBER O Integer value to be returned. */
/* ERROR O A logical flag which is .TRUE. on error. */
/* ERRMSG O A descriptive error message. */
/* $ Detailed_Input */
/* STRING The hexadecimal string to be converted to an integer. */
/* The following table describes the character set used */
/* to represent the hexadecimal digits and their */
/* corresponding values. */
/* Character Value Character Value */
/* --------- ----- --------- ----- */
/* '0' 0 '8' 8 */
/* '1' 1 '9' 9 */
/* '2' 2 'A','a' 10 */
/* '3' 3 'B','b' 11 */
/* '4' 4 'C','c' 12 */
/* '5' 5 'D','d' 13 */
/* '6' 6 'E','e' 14 */
/* '7' 7 'F','f' 15 */
/* The plus sign, '+', and the minus sign, '-', are used as */
/* well, and they have their usual meanings. */
/* A hexadecimal character string parsed by this routine */
/* should consist of a sign, '+' or '-' (the plus sign is */
/* optional for nonnegative numbers), followed immediately */
/* by a contiguous sequence of hexadecimal digits, e.g.: */
/* (1) +h h ... h */
/* 1 2 n */
/* (2) -h h ... h */
/* 1 2 n */
/* (3) h h ... h */
/* 1 2 n */
/* where h represents an hexadecimal digit. */
/* i */
/* STRING may have leading and trailing blanks, but blanks */
/* embedded within the signficant portion of the character */
/* string are not allowed. This includes any blanks which */
/* appear between the sign character and the first */
/* hexadecimal digit. */
/* $ Detailed_Output */
/* NUMBER The integer value to be returned. The value of this */
/* variable is not changed if an error occurs while parsing */
/* the hexadecimal character string. */
/* ERROR A logical flag which indicates whether an error occurred */
/* while attempting to parse NUMBER from the hexadecimal */
/* character string STRING. ERROR will have the value */
/* .TRUE. if an error occurs. It will have the value */
/* .FALSE. otherwise. */
/* ERRMSG Contains a descriptive error message if an error */
/* occurs while attempting to parse NUMBER from the */
/* hexadecimal character string STRING, blank otherwise. */
/* The error message will be left justified. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* 1) If an unexpected character is encountered while parsing the */
/* hexadecimal character string, an appropriate error message */
/* will be set, and the routine will exit. The value of NUMBER */
/* will be unchanged. */
/* 2) If the string represents a number that is larger than */
/* the maximum representable integer an appropriate error */
/* message will be set, and the routine will exit. The value */
/* of NUMBER will be unchanged. */
/* 3) If the string represents a number that is smaller than */
/* the minimum representable integer, an appropriate error */
/* message will be set, and the routine will exit. The value */
/* of NUMBER will be unchanged. */
/* 4) If the input string is blank, an appropriate error message */
/* will be set, and the routine will exit. The value of NUMBER */
/* will be unchanged. */
/* 5) If the error message string is not long enough to contain */
/* the entire error message, the error message will be */
/* truncated on the right. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine will convert a signed hexadecimal character string */
/* representation of an integer into its equivalent integer. This */
/* provides a machine independent mechanism for storing or porting */
/* integer values. This routine is used by the routine HX2DP which */
/* converts a character string representation of a double precision */
/* into its equivalent double precision value. */
/* This routine is one of a pair of routines which are used to */
/* perform conversions between integers and equivalent signed */
/* hexadecimal character strings: */
/* INT2HX -- Convert an integer into a signed hexadecimal */
/* character string. */
/* HX2INT -- Convert a signed hexadecimal character string */
/* into an integer. */
/* $ Examples */
/* All of the values shown are for a two's complement 32 bit */
/* representation for signed integers. */
/* The following argument values illustrate the action of HX2INT for */
/* various input values. */
/* STRING NUMBER ERROR ERRMSG */
/* --------------------- ------------ ------ ------ */
/* '1' 1 .FALSE. ' ' */
/* '-1' -1 .FALSE. ' ' */
/* 'DF' 223 .FALSE. ' ' */
/* 'Df' 223 .FALSE. ' ' */
/* '+3ABC' 15036 .FALSE. ' ' */
/* 'ff' 255 .FALSE. ' ' */
/* '-20' -32 .FALSE. ' ' */
/* '0' 0 .FALSE. ' ' */
/* '7FFFFFFF' 2147483647 .FALSE. ' ' */
/* (Maximum 32 bit integer) */
/* '-7FFFFFFF' -2147483647 .FALSE. ' ' */
/* (Minimum 32 bit integer + 1) */
/* '-80000000' -2147483648 .FALSE. ' ' */
/* (Minimum 32 bit integer) */
/* STRING = ' ' */
/* NUMBER = ( Not defined ) */
/* ERROR = .TRUE. */
/* ERRMSG = 'ERROR: A blank input string is not allowed.' */
/* STRING = '-AB238Q' */
/* NUMBER = ( Not defined ) */
/* ERROR = .TRUE. */
/* ERRMSG = 'ERROR: Illegal character ''Q'' encountered.' */
/* STRING = '- AAA' */
/* NUMBER = ( Not defined ) */
/* ERROR = .TRUE. */
/* ERRMSG = 'ERROR: Illegal character '' '' encountered.' */
/* STRING = '80000000' */
/* NUMBER = ( Not defined ) */
/* ERROR = .TRUE. */
/* ERRMSG = 'ERROR: Integer too large to be represented.' */
/* STRING = '-800F0000' */
/* NUMBER = ( Not defined ) */
/* ERROR = .TRUE. */
/* ERRMSG = 'ERROR: Integer too small to be represented.' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.1.0, 10-MAR-1994 (KRG) */
/* Changed an IF test operand from .LE. to .LT. so that */
/* the ELSE IF clause could be reached. This change has */
/* NO effect on the execution of the routine because it */
/* makes use of a base that is a power of 2 (16), so the */
/* ELSE IF clause never needs to be reached. The algorithm */
/* was meant to be as general as possible, however, so that */
/* only the base and digits would need to be changed in order to */
/* implement a different number base. */
/* - SPICELIB Version 1.0.0, 22-OCT-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* convert signed hexadecimal string to integer */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 10-MAR-1994 (KRG) */
/* Changed an IF test operand from .LE. to .LT. so that */
/* the ELSE IF clause could be reached. This change has */
/* NO effect on the execution of the routine because it */
/* makes use of a base that is a power of 2 (16), so the */
/* ELSE IF clause never needs to be reached. The algorithm */
/* was meant to be as general as possible, however, so that */
/* only the base and digits would need to be changed in order to */
/* implement a different number base. */
/* Old code was: */
/* IF ( TMPNUM .LE. MAXI ) THEN */
/* TMPNUM = TMPNUM * BASE + IDIGIT */
/* POS = POS + 1 */
/* ELSE IF ( ( TMPNUM .EQ. MAXI ) .AND. */
/* . ( IDIGIT .LE. MAXMOD ) ) THEN */
/* TMPNUM = TMPNUM * BASE + IDIGIT */
/* POS = POS + 1 */
/* ELSE ... */
/* New code: */
/* IF ( TMPNUM .LT. MAXI ) THEN */
/* TMPNUM = TMPNUM * BASE + IDIGIT */
/* POS = POS + 1 */
/* ELSE IF ( ( TMPNUM .EQ. MAXI ) .AND. */
/* . ( IDIGIT .LE. MAXMOD ) ) THEN */
/* TMPNUM = TMPNUM * BASE + IDIGIT */
/* POS = POS + 1 */
/* ELSE ... */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* The input hexadecimal string is scanned from left to right, and */
/* the integer is generated by repeated multiplications and additions */
/* or subtractions. */
/* If this is the first time that this routine has been called, */
/* we need to do some setup stuff. */
if (first) {
first = FALSE_;
/* Initialize the upper and lower bounds for the decimal digits, */
/* the upper and lower bounds for the uppercase hexadecimal */
/* digits, the upper and lower bounds for the lowercase */
/* hexadecimal digits, the space, the plus sign, and the minus */
/* sign in the character sequence. */
digbeg = '0';
digend = '9';
uccbeg = 'A';
uccend = 'F';
lccbeg = 'a';
lccend = 'f';
iminus = '-';
iplus = '+';
ispace = ' ';
/* Initialize some boundary values for error checking while */
/* constructing the desired integer. These are used to help */
/* determine integer overflow or integer underflow errors. */
mini = intmin_() / 16;
minmod = (mini << 4) - intmin_();
maxi = intmax_() / 16;
maxmod = intmax_() - (maxi << 4);
}
/* There are no errors initially, so set the error flag to */
/* .FALSE. */
*error = FALSE_;
/* If the string is blank, set the error flag and return immediately. */
if (s_cmp(string, " ", string_len, (ftnlen)1) == 0) {
*error = TRUE_;
s_copy(errmsg, "ERROR: A blank input string is not allowed.",
errmsg_len, (ftnlen)43);
return 0;
}
/* Initialize a few other things. */
s_copy(errmsg, " ", errmsg_len, (ftnlen)1);
tmpnum = 0;
/* Assume that the number is nonnegative. */
negtiv = FALSE_;
/* Skip any leading white space. We know that there is at least */
/* one nonblank character at this point, so we will not loop */
/* off the end of the string. */
strbeg = 1;
while(*(unsigned char *)&string[strbeg - 1] == ispace) {
++strbeg;
}
/* Now, we want to find the end of the significant portion of */
/* the input string. */
strend = strbeg + 1;
more = TRUE_;
while(more) {
if (strend <= i_len(string, string_len)) {
if (s_cmp(string + (strend - 1), " ", string_len - (strend - 1), (
ftnlen)1) != 0) {
++strend;
} else {
more = FALSE_;
}
} else {
more = FALSE_;
}
}
/* At this point, STREND is one larger than the length of the */
/* significant portion of the string because we incremented */
/* its value after the test. We will subtract one from the */
/* value of STREND so that it exactly represents the position */
/* of the last significant character in the string. */
--strend;
/* Set the position pointer to the beginning of the significant */
/* part, i.e., the nonblank part, of the string, because we are */
/* now ready to try and parse the number. */
pos = strbeg;
/* The first character should be a plus sign, '+', a minus sign, */
/* '-', or a digit, '0' - '9', 'A' - 'F', or 'a' - 'f'. Anything */
/* else is bogus, and we will catch it in the main loop below. */
/* If the character is a minus sign, we want to set the value of */
/* NEGTIV to .TRUE. and increment the position. */
/* If the character is a plus sign, we want to increment the */
/* position. */
if (*(unsigned char *)&string[pos - 1] == iminus) {
negtiv = TRUE_;
++pos;
} else if (*(unsigned char *)&string[pos - 1] == iplus) {
++pos;
}
/* When we build up the number from the hexadecimal string we */
/* need to treat nonnegative numbers differently from negative */
/* numbers. This is because on many computers the minimum */
/* integer is one less than the negation of the maximum integer. */
/* Negative numbers are the ones which truly might cause */
/* problems, because ABS(minimum integer) may equal ABS(maximum */
/* integer) + 1, on some machines. For example, on many machines */
/* with 32 bit numbers, INTMIN = -2147483648 and INTMAX = */
/* 2147483647. */
/* Build up the number from the hexadecimal character string. */
if (negtiv) {
while(pos <= strend) {
letter = *(unsigned char *)&string[pos - 1];
if (letter >= digbeg && letter <= digend) {
idigit = letter - digbeg;
} else if (letter >= uccbeg && letter <= uccend) {
idigit = letter + 10 - uccbeg;
} else if (letter >= lccbeg && letter <= lccend) {
idigit = letter + 10 - lccbeg;
} else {
*error = TRUE_;
s_copy(errmsg, "ERROR: Illegal character '#' encountered.",
errmsg_len, (ftnlen)41);
*(unsigned char *)&ch__1[0] = letter;
repmc_(errmsg, "#", ch__1, errmsg, errmsg_len, (ftnlen)1, (
ftnlen)1, errmsg_len);
return 0;
}
if (tmpnum > mini) {
tmpnum = (tmpnum << 4) - idigit;
++pos;
} else if (tmpnum == mini && idigit <= minmod) {
tmpnum = (tmpnum << 4) - idigit;
++pos;
} else {
*error = TRUE_;
s_copy(errmsg, "ERROR: Integer too small to be represented.",
errmsg_len, (ftnlen)43);
return 0;
}
}
} else {
while(pos <= strend) {
letter = *(unsigned char *)&string[pos - 1];
if (letter >= digbeg && letter <= digend) {
idigit = letter - digbeg;
} else if (letter >= uccbeg && letter <= uccend) {
idigit = letter + 10 - uccbeg;
} else if (letter >= lccbeg && letter <= lccend) {
idigit = letter + 10 - lccbeg;
} else {
*error = TRUE_;
s_copy(errmsg, "ERROR: Illegal character '#' encountered.",
errmsg_len, (ftnlen)41);
*(unsigned char *)&ch__1[0] = letter;
repmc_(errmsg, "#", ch__1, errmsg, errmsg_len, (ftnlen)1, (
ftnlen)1, errmsg_len);
return 0;
}
if (tmpnum < maxi) {
tmpnum = (tmpnum << 4) + idigit;
++pos;
} else if (tmpnum == maxi && idigit <= maxmod) {
tmpnum = (tmpnum << 4) + idigit;
++pos;
} else {
*error = TRUE_;
s_copy(errmsg, "ERROR: Integer too large to be represented.",
errmsg_len, (ftnlen)43);
return 0;
}
}
}
/* If we got to here, we have successfully parsed the hexadecimal */
/* string into an integer. Set the value and return. */
*number = tmpnum;
return 0;
} /* hx2int_ */
/*< >*/
integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen
opts_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__;
char c1[1], c2[2], c3[3], c4[2];
integer ic, nb, iz, nx;
logical cname, sname;
integer nbmin;
extern integer ieeeck_(integer *, real *, real *);
char subnam[6];
(void)opts;
(void)n3;
(void)opts_len;
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/*< CHARACTER*( * ) NAME, OPTS >*/
/*< INTEGER ISPEC, N1, N2, N3, N4 >*/
/* .. */
/* Purpose */
/* ======= */
/* ILAENV is called from the LAPACK routines to choose problem-dependent */
/* parameters for the local environment. See ISPEC for a description of */
/* the parameters. */
/* This version provides a set of parameters which should give good, */
/* but not optimal, performance on many of the currently available */
/* computers. Users are encouraged to modify this subroutine to set */
/* the tuning parameters for their particular machine using the option */
/* and problem size information in the arguments. */
/* This routine will not function correctly if it is converted to all */
/* lower case. Converting it to all upper case is allowed. */
/* Arguments */
/* ========= */
/* ISPEC (input) INTEGER */
/* Specifies the parameter to be returned as the value of */
/* ILAENV. */
/* = 1: the optimal blocksize; if this value is 1, an unblocked */
/* algorithm will give the best performance. */
/* = 2: the minimum block size for which the block routine */
/* should be used; if the usable block size is less than */
/* this value, an unblocked routine should be used. */
/* = 3: the crossover point (in a block routine, for N less */
/* than this value, an unblocked routine should be used) */
/* = 4: the number of shifts, used in the nonsymmetric */
/* eigenvalue routines */
/* = 5: the minimum column dimension for blocking to be used; */
/* rectangular blocks must have dimension at least k by m, */
/* where k is given by ILAENV(2,...) and m by ILAENV(5,...) */
/* = 6: the crossover point for the SVD (when reducing an m by n */
/* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds */
/* this value, a QR factorization is used first to reduce */
/* the matrix to a triangular form.) */
/* = 7: the number of processors */
/* = 8: the crossover point for the multishift QR and QZ methods */
/* for nonsymmetric eigenvalue problems. */
/* = 9: maximum size of the subproblems at the bottom of the */
/* computation tree in the divide-and-conquer algorithm */
/* (used by xGELSD and xGESDD) */
/* =10: ieee NaN arithmetic can be trusted not to trap */
/* =11: infinity arithmetic can be trusted not to trap */
/* NAME (input) CHARACTER*(*) */
/* The name of the calling subroutine, in either upper case or */
/* lower case. */
/* OPTS (input) CHARACTER*(*) */
/* The character options to the subroutine NAME, concatenated */
/* into a single character string. For example, UPLO = 'U', */
/* TRANS = 'T', and DIAG = 'N' for a triangular routine would */
/* be specified as OPTS = 'UTN'. */
/* N1 (input) INTEGER */
/* N2 (input) INTEGER */
/* N3 (input) INTEGER */
/* N4 (input) INTEGER */
/* Problem dimensions for the subroutine NAME; these may not all */
/* be required. */
/* (ILAENV) (output) INTEGER */
/* >= 0: the value of the parameter specified by ISPEC */
/* < 0: if ILAENV = -k, the k-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The following conventions have been used when calling ILAENV from the */
/* LAPACK routines: */
/* 1) OPTS is a concatenation of all of the character options to */
/* subroutine NAME, in the same order that they appear in the */
/* argument list for NAME, even if they are not used in determining */
/* the value of the parameter specified by ISPEC. */
/* 2) The problem dimensions N1, N2, N3, N4 are specified in the order */
/* that they appear in the argument list for NAME. N1 is used */
/* first, N2 second, and so on, and unused problem dimensions are */
/* passed a value of -1. */
/* 3) The parameter value returned by ILAENV is checked for validity in */
/* the calling subroutine. For example, ILAENV is used to retrieve */
/* the optimal blocksize for STRTRI as follows: */
/* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) */
/* IF( NB.LE.1 ) NB = MAX( 1, N ) */
/* ===================================================================== */
/* .. Local Scalars .. */
/*< LOGICAL CNAME, SNAME >*/
/*< CHARACTER*1 C1 >*/
/*< CHARACTER*2 C2, C4 >*/
/*< CHARACTER*3 C3 >*/
/*< CHARACTER*6 SUBNAM >*/
/*< INTEGER I, IC, IZ, NB, NBMIN, NX >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC CHAR, ICHAR, INT, MIN, REAL >*/
/* .. */
/* .. External Functions .. */
/*< INTEGER IEEECK >*/
/*< EXTERNAL IEEECK >*/
/* .. */
/* .. Executable Statements .. */
/*< >*/
switch (*ispec) {
case 1: goto L100;
case 2: goto L100;
case 3: goto L100;
case 4: goto L400;
case 5: goto L500;
case 6: goto L600;
case 7: goto L700;
case 8: goto L800;
case 9: goto L900;
case 10: goto L1000;
case 11: goto L1100;
}
/* Invalid value for ISPEC */
/*< ILAENV = -1 >*/
ret_val = -1;
/*< RETURN >*/
return ret_val;
/*< 100 CONTINUE >*/
L100:
/* Convert NAME to upper case if the first character is lower case. */
/*< ILAENV = 1 >*/
ret_val = 1;
/*< SUBNAM = NAME >*/
s_copy(subnam, name__, (ftnlen)6, name_len);
/*< IC = ICHAR( SUBNAM( 1:1 ) ) >*/
ic = *(unsigned char *)subnam;
/*< IZ = ICHAR( 'Z' ) >*/
iz = 'Z';
/*< IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN >*/
if (iz == 90 || iz == 122) {
/* ASCII character set */
/*< IF( IC.GE.97 .AND. IC.LE.122 ) THEN >*/
if (ic >= 97 && ic <= 122) {
/*< SUBNAM( 1:1 ) = CHAR( IC-32 ) >*/
*(unsigned char *)subnam = (char) (ic - 32);
/*< DO 10 I = 2, 6 >*/
for (i__ = 2; i__ <= 6; ++i__) {
/*< IC = ICHAR( SUBNAM( I:I ) ) >*/
ic = *(unsigned char *)&subnam[i__ - 1];
/*< >*/
if (ic >= 97 && ic <= 122) {
*(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
}
/*< 10 CONTINUE >*/
/* L10: */
}
/*< END IF >*/
}
/*< ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN >*/
} else if (iz == 233 || iz == 169) {
/* EBCDIC character set */
/*< >*/
if ((ic >= 129 && ic <= 137) || (ic >= 145 && ic <= 153) || (ic >= 162 &&
ic <= 169)) {
/*< SUBNAM( 1:1 ) = CHAR( IC+64 ) >*/
*(unsigned char *)subnam = (char) (ic + 64);
/*< DO 20 I = 2, 6 >*/
for (i__ = 2; i__ <= 6; ++i__) {
/*< IC = ICHAR( SUBNAM( I:I ) ) >*/
ic = *(unsigned char *)&subnam[i__ - 1];
/*< >*/
if ((ic >= 129 && ic <= 137) || (ic >= 145 && ic <= 153) || (ic >=
162 && ic <= 169)) {
*(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64);
}
/*< 20 CONTINUE >*/
/* L20: */
}
/*< END IF >*/
}
/*< ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN >*/
} else if (iz == 218 || iz == 250) {
/* Prime machines: ASCII+128 */
/*< IF( IC.GE.225 .AND. IC.LE.250 ) THEN >*/
if (ic >= 225 && ic <= 250) {
/*< SUBNAM( 1:1 ) = CHAR( IC-32 ) >*/
*(unsigned char *)subnam = (char) (ic - 32);
/*< DO 30 I = 2, 6 >*/
for (i__ = 2; i__ <= 6; ++i__) {
/*< IC = ICHAR( SUBNAM( I:I ) ) >*/
ic = *(unsigned char *)&subnam[i__ - 1];
/*< >*/
if (ic >= 225 && ic <= 250) {
*(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
}
/*< 30 CONTINUE >*/
/* L30: */
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< C1 = SUBNAM( 1:1 ) >*/
*(unsigned char *)c1 = *(unsigned char *)subnam;
/*< SNAME = C1.EQ.'S' .OR. C1.EQ.'D' >*/
sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D';
/*< CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' >*/
cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z';
/*< >*/
if (! (cname || sname)) {
return ret_val;
}
/*< C2 = SUBNAM( 2:3 ) >*/
s_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2);
/*< C3 = SUBNAM( 4:6 ) >*/
s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3);
/*< C4 = C3( 2:3 ) >*/
s_copy(c4, c3 + 1, (ftnlen)2, (ftnlen)2);
/*< GO TO ( 110, 200, 300 ) ISPEC >*/
switch (*ispec) {
case 1: goto L110;
case 2: goto L200;
case 3: goto L300;
}
/*< 110 CONTINUE >*/
L110:
/* ISPEC = 1: block size */
/* In these examples, separate code is provided for setting NB for */
/* real and complex. We assume that NB will take the same value in */
/* single or double precision. */
/*< NB = 1 >*/
nb = 1;
/*< IF( C2.EQ.'GE' ) THEN >*/
if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'TRF' ) THEN >*/
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NB = 64 >*/
nb = 64;
/*< ELSE >*/
} else {
/*< NB = 64 >*/
nb = 64;
/*< END IF >*/
}
/*< >*/
} else if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3,
"RQF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)
3, (ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3)
== 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NB = 32 >*/
nb = 32;
/*< ELSE >*/
} else {
/*< NB = 32 >*/
nb = 32;
/*< END IF >*/
}
/*< ELSE IF( C3.EQ.'HRD' ) THEN >*/
} else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NB = 32 >*/
nb = 32;
/*< ELSE >*/
} else {
/*< NB = 32 >*/
nb = 32;
/*< END IF >*/
}
/*< ELSE IF( C3.EQ.'BRD' ) THEN >*/
} else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NB = 32 >*/
nb = 32;
/*< ELSE >*/
} else {
/*< NB = 32 >*/
nb = 32;
/*< END IF >*/
}
/*< ELSE IF( C3.EQ.'TRI' ) THEN >*/
} else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NB = 64 >*/
nb = 64;
/*< ELSE >*/
} else {
/*< NB = 64 >*/
nb = 64;
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( C2.EQ.'PO' ) THEN >*/
} else if (s_cmp(c2, "PO", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'TRF' ) THEN >*/
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NB = 64 >*/
nb = 64;
/*< ELSE >*/
} else {
/*< NB = 64 >*/
nb = 64;
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( C2.EQ.'SY' ) THEN >*/
} else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'TRF' ) THEN >*/
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NB = 64 >*/
nb = 64;
/*< ELSE >*/
} else {
/*< NB = 64 >*/
nb = 64;
/*< END IF >*/
}
/*< ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN >*/
} else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< NB = 32 >*/
nb = 32;
/*< ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN >*/
} else if (sname && s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
/*< NB = 64 >*/
nb = 64;
/*< END IF >*/
}
/*< ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN >*/
} else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'TRF' ) THEN >*/
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
/*< NB = 64 >*/
nb = 64;
/*< ELSE IF( C3.EQ.'TRD' ) THEN >*/
} else if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< NB = 32 >*/
nb = 32;
/*< ELSE IF( C3.EQ.'GST' ) THEN >*/
} else if (s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
/*< NB = 64 >*/
nb = 64;
/*< END IF >*/
}
/*< ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN >*/
} else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3( 1:1 ).EQ.'G' ) THEN >*/
if (*(unsigned char *)c3 == 'G') {
/*< >*/
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
/*< NB = 32 >*/
nb = 32;
/*< END IF >*/
}
/*< ELSE IF( C3( 1:1 ).EQ.'M' ) THEN >*/
} else if (*(unsigned char *)c3 == 'M') {
/*< >*/
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
/*< NB = 32 >*/
nb = 32;
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN >*/
} else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3( 1:1 ).EQ.'G' ) THEN >*/
if (*(unsigned char *)c3 == 'G') {
/*< >*/
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
/*< NB = 32 >*/
nb = 32;
/*< END IF >*/
}
/*< ELSE IF( C3( 1:1 ).EQ.'M' ) THEN >*/
} else if (*(unsigned char *)c3 == 'M') {
/*< >*/
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
/*< NB = 32 >*/
nb = 32;
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( C2.EQ.'GB' ) THEN >*/
} else if (s_cmp(c2, "GB", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'TRF' ) THEN >*/
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< IF( N4.LE.64 ) THEN >*/
if (*n4 <= 64) {
/*< NB = 1 >*/
nb = 1;
/*< ELSE >*/
} else {
/*< NB = 32 >*/
nb = 32;
/*< END IF >*/
}
/*< ELSE >*/
} else {
/*< IF( N4.LE.64 ) THEN >*/
if (*n4 <= 64) {
/*< NB = 1 >*/
nb = 1;
/*< ELSE >*/
} else {
/*< NB = 32 >*/
nb = 32;
/*< END IF >*/
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( C2.EQ.'PB' ) THEN >*/
} else if (s_cmp(c2, "PB", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'TRF' ) THEN >*/
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< IF( N2.LE.64 ) THEN >*/
if (*n2 <= 64) {
/*< NB = 1 >*/
nb = 1;
/*< ELSE >*/
} else {
/*< NB = 32 >*/
nb = 32;
/*< END IF >*/
}
/*< ELSE >*/
} else {
/*< IF( N2.LE.64 ) THEN >*/
if (*n2 <= 64) {
/*< NB = 1 >*/
nb = 1;
/*< ELSE >*/
} else {
/*< NB = 32 >*/
nb = 32;
/*< END IF >*/
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( C2.EQ.'TR' ) THEN >*/
} else if (s_cmp(c2, "TR", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'TRI' ) THEN >*/
if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NB = 64 >*/
nb = 64;
/*< ELSE >*/
} else {
/*< NB = 64 >*/
nb = 64;
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( C2.EQ.'LA' ) THEN >*/
} else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'UUM' ) THEN >*/
if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NB = 64 >*/
nb = 64;
/*< ELSE >*/
} else {
/*< NB = 64 >*/
nb = 64;
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN >*/
} else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'EBZ' ) THEN >*/
if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) {
/*< NB = 1 >*/
nb = 1;
/*< END IF >*/
}
/*< END IF >*/
}
/*< ILAENV = NB >*/
ret_val = nb;
/*< RETURN >*/
return ret_val;
/*< 200 CONTINUE >*/
L200:
/* ISPEC = 2: minimum block size */
/*< NBMIN = 2 >*/
nbmin = 2;
/*< IF( C2.EQ.'GE' ) THEN >*/
if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
/*< >*/
if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
{
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< ELSE >*/
} else {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< END IF >*/
}
/*< ELSE IF( C3.EQ.'HRD' ) THEN >*/
} else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< ELSE >*/
} else {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< END IF >*/
}
/*< ELSE IF( C3.EQ.'BRD' ) THEN >*/
} else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< ELSE >*/
} else {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< END IF >*/
}
/*< ELSE IF( C3.EQ.'TRI' ) THEN >*/
} else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< ELSE >*/
} else {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( C2.EQ.'SY' ) THEN >*/
} else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'TRF' ) THEN >*/
if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NBMIN = 8 >*/
nbmin = 8;
/*< ELSE >*/
} else {
/*< NBMIN = 8 >*/
nbmin = 8;
/*< END IF >*/
}
/*< ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN >*/
} else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< END IF >*/
}
/*< ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN >*/
} else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'TRD' ) THEN >*/
if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< END IF >*/
}
/*< ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN >*/
} else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3( 1:1 ).EQ.'G' ) THEN >*/
if (*(unsigned char *)c3 == 'G') {
/*< >*/
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< END IF >*/
}
/*< ELSE IF( C3( 1:1 ).EQ.'M' ) THEN >*/
} else if (*(unsigned char *)c3 == 'M') {
/*< >*/
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN >*/
} else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3( 1:1 ).EQ.'G' ) THEN >*/
if (*(unsigned char *)c3 == 'G') {
/*< >*/
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< END IF >*/
}
/*< ELSE IF( C3( 1:1 ).EQ.'M' ) THEN >*/
} else if (*(unsigned char *)c3 == 'M') {
/*< >*/
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
/*< NBMIN = 2 >*/
nbmin = 2;
/*< END IF >*/
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< ILAENV = NBMIN >*/
ret_val = nbmin;
/*< RETURN >*/
return ret_val;
/*< 300 CONTINUE >*/
L300:
/* ISPEC = 3: crossover point */
/*< NX = 0 >*/
nx = 0;
/*< IF( C2.EQ.'GE' ) THEN >*/
if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
/*< >*/
if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
{
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NX = 128 >*/
nx = 128;
/*< ELSE >*/
} else {
/*< NX = 128 >*/
nx = 128;
/*< END IF >*/
}
/*< ELSE IF( C3.EQ.'HRD' ) THEN >*/
} else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NX = 128 >*/
nx = 128;
/*< ELSE >*/
} else {
/*< NX = 128 >*/
nx = 128;
/*< END IF >*/
}
/*< ELSE IF( C3.EQ.'BRD' ) THEN >*/
} else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< IF( SNAME ) THEN >*/
if (sname) {
/*< NX = 128 >*/
nx = 128;
/*< ELSE >*/
} else {
/*< NX = 128 >*/
nx = 128;
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( C2.EQ.'SY' ) THEN >*/
} else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( SNAME .AND. C3.EQ.'TRD' ) THEN >*/
if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< NX = 32 >*/
nx = 32;
/*< END IF >*/
}
/*< ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN >*/
} else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3.EQ.'TRD' ) THEN >*/
if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
/*< NX = 32 >*/
nx = 32;
/*< END IF >*/
}
/*< ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN >*/
} else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3( 1:1 ).EQ.'G' ) THEN >*/
if (*(unsigned char *)c3 == 'G') {
/*< >*/
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
/*< NX = 128 >*/
nx = 128;
/*< END IF >*/
}
/*< END IF >*/
}
/*< ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN >*/
} else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
/*< IF( C3( 1:1 ).EQ.'G' ) THEN >*/
if (*(unsigned char *)c3 == 'G') {
/*< >*/
if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
(ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
ftnlen)2, (ftnlen)2) == 0) {
/*< NX = 128 >*/
nx = 128;
/*< END IF >*/
}
/*< END IF >*/
}
/*< END IF >*/
}
/*< ILAENV = NX >*/
ret_val = nx;
/*< RETURN >*/
return ret_val;
/*< 400 CONTINUE >*/
L400:
/* ISPEC = 4: number of shifts (used by xHSEQR) */
/*< ILAENV = 6 >*/
ret_val = 6;
/*< RETURN >*/
return ret_val;
/*< 500 CONTINUE >*/
L500:
/* ISPEC = 5: minimum column dimension (not used) */
/*< ILAENV = 2 >*/
ret_val = 2;
/*< RETURN >*/
return ret_val;
/*< 600 CONTINUE >*/
L600:
/* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */
/*< ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) >*/
ret_val = (integer) ((real) min(*n1,*n2) * (float)1.6);
/*< RETURN >*/
return ret_val;
/*< 700 CONTINUE >*/
L700:
/* ISPEC = 7: number of processors (not used) */
/*< ILAENV = 1 >*/
ret_val = 1;
/*< RETURN >*/
return ret_val;
/*< 800 CONTINUE >*/
L800:
/* ISPEC = 8: crossover point for multishift (used by xHSEQR) */
/*< ILAENV = 50 >*/
ret_val = 50;
/*< RETURN >*/
return ret_val;
/*< 900 CONTINUE >*/
L900:
/* ISPEC = 9: maximum size of the subproblems at the bottom of the */
/* computation tree in the divide-and-conquer algorithm */
/* (used by xGELSD and xGESDD) */
/*< ILAENV = 25 >*/
ret_val = 25;
/*< RETURN >*/
return ret_val;
/*< 1000 CONTINUE >*/
L1000:
/* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap */
/* ILAENV = 0 */
/*< ILAENV = 1 >*/
ret_val = 1;
/*< IF( ILAENV.EQ.1 ) THEN >*/
if (ret_val == 1) {
/*< ILAENV = IEEECK( 0, 0.0, 1.0 ) >*/
ret_val = ieeeck_(&c__0, &c_b162, &c_b163);
/*< END IF >*/
}
/*< RETURN >*/
return ret_val;
/*< 1100 CONTINUE >*/
L1100:
/* ISPEC = 11: infinity arithmetic can be trusted not to trap */
/* ILAENV = 0 */
/*< ILAENV = 1 >*/
ret_val = 1;
/*< IF( ILAENV.EQ.1 ) THEN >*/
if (ret_val == 1) {
/*< ILAENV = IEEECK( 1, 0.0, 1.0 ) >*/
ret_val = ieeeck_(&c__1, &c_b162, &c_b163);
/*< END IF >*/
}
/*< RETURN >*/
return ret_val;
/* End of ILAENV */
/*< END >*/
} /* ilaenv_ */
logical l_ge(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
return(s_cmp(a,b,la,lb) >= 0);
}
/* $Procedure LBUILD ( Build a list in a character string ) */
/* Subroutine */ int lbuild_(char *items, integer *n, char *delim, char *list,
ftnlen items_len, ftnlen delim_len, ftnlen list_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer dlen, ilen, llen, last, lpos, i__, first;
extern integer lastnb_(char *, ftnlen), frstnb_(char *, ftnlen);
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen);
/* $ Abstract */
/* Build a list of items delimited by a character. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CHARACTER, LIST, STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* ITEMS I Items in the list. */
/* N I Number of items in the list. */
/* DELIM I String used to delimit items. */
/* LIST O List of items delimited by DELIM. */
/* $ Detailed_Input */
/* ITEMS are the items to be combined to make the output */
/* list. Leading and trailing blanks are ignored. */
/* (Only the non-blank parts of the items are used.) */
/* N is the number of items. */
/* DELIM is the string used to delimit the items in the */
/* output list. DELIM may contain any number of */
/* characters, including blanks. */
/* $ Detailed_Output */
/* LIST is the output list, containing the N elements of */
/* ITEMS delimited by DELIM. If LIST is not long enough */
/* to contain the output list, it is truncated on the */
/* right. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* The non-blank parts of the elements of the ITEMS array are */
/* appended to the list, one at a time, separated by DELIM. */
/* $ Examples */
/* The following examples illustrate the operation of LBUILD. */
/* 1) Let */
/* DELIM = ' ' */
/* ITEMS(1) = 'A' */
/* ITEMS(2) = ' number' */
/* ITEMS(3) = 'of' */
/* ITEMS(4) = ' words' */
/* ITEMS(5) = 'separated' */
/* ITEMS(6) = ' by' */
/* ITEMS(7) = 'spaces' */
/* Then */
/* LIST = 'A number of words separated by spaces' */
/* 2) Let */
/* DELIM = '/' */
/* ITEMS(1) = ' ' */
/* ITEMS(2) = ' ' */
/* ITEMS(3) = 'option1' */
/* ITEMS(4) = ' ' */
/* ITEMS(5) = 'option2' */
/* ITEMS(6) = ' ' */
/* ITEMS(7) = ' ' */
/* ITEMS(8) = ' ' */
/* Then */
/* LIST = '//option1//option2///' */
/* 3) Let */
/* DELIM = ' and ' */
/* ITEMS(1) = 'Bob' */
/* ITEMS(2) = 'Carol' */
/* ITEMS(3) = 'Ted' */
/* ITEMS(4) = 'Alice' */
/* Then */
/* LIST = 'Bob and Carol and Ted and Alice' */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* build a list in a character_string */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Find the non-blank part of each item. Move it to the */
/* end of the list, followed by a delimiter. If the item is */
/* blank, don't move anything but the delimiter. */
/* LPOS is the next position in the output list to be filled. */
/* LLEN is the length of the output list. */
/* DLEN is the length of DELIM. */
/* ILEN is the length of the next item in the list. */
s_copy(list, " ", list_len, (ftnlen)1);
lpos = 1;
llen = i_len(list, list_len);
dlen = i_len(delim, delim_len);
if (*n > 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (lpos <= llen) {
if (s_cmp(items + (i__ - 1) * items_len, " ", items_len, (
ftnlen)1) == 0) {
s_copy(list + (lpos - 1), delim, list_len - (lpos - 1),
delim_len);
lpos += dlen;
} else {
first = frstnb_(items + (i__ - 1) * items_len, items_len);
last = lastnb_(items + (i__ - 1) * items_len, items_len);
ilen = last - first + 1;
s_copy(list + (lpos - 1), items + ((i__ - 1) * items_len
+ (first - 1)), list_len - (lpos - 1), last - (
first - 1));
suffix_(delim, &c__0, list, delim_len, list_len);
lpos = lpos + ilen + dlen;
}
}
}
/* We're at the end of the list. Right now, the list ends in */
/* a delimiter. Drop it. */
if (lpos - dlen <= llen) {
i__1 = lpos - dlen - 1;
s_copy(list + i__1, " ", list_len - i__1, (ftnlen)1);
}
}
return 0;
} /* lbuild_ */
/* $Procedure ZZSPKAP1 ( S/P Kernel, apparent state ) */
/* Subroutine */ int zzspkap1_(integer *targ, doublereal *et, char *ref,
doublereal *sobs, char *abcorr, doublereal *starg, doublereal *lt,
ftnlen ref_len, ftnlen abcorr_len)
{
/* Initialized data */
static logical first = TRUE_;
static char flags[5*9] = "NONE " "LT " "LT+S " "CN " "CN+S " "XLT "
"XLT+S" "XCN " "XCN+S";
static char prvcor[5] = " ";
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char corr[5];
extern /* Subroutine */ int zzspksb1_(integer *, doublereal *, char *,
doublereal *, ftnlen);
static logical xmit;
extern /* Subroutine */ int vequ_(doublereal *, doublereal *);
integer i__, refid;
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), moved_(doublereal *, integer *, doublereal *);
static logical usecn;
doublereal sapos[3];
extern /* Subroutine */ int vsubg_(doublereal *, doublereal *, integer *,
doublereal *);
static logical uselt;
extern doublereal vnorm_(doublereal *), clight_(void);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int stelab_(doublereal *, doublereal *,
doublereal *), sigerr_(char *, ftnlen), chkout_(char *, ftnlen),
stlabx_(doublereal *, doublereal *, doublereal *);
integer ltsign;
extern /* Subroutine */ int ljucrs_(integer *, char *, char *, ftnlen,
ftnlen), setmsg_(char *, ftnlen);
doublereal tstate[6];
integer maxitr;
extern /* Subroutine */ int irfnum_(char *, integer *, ftnlen);
extern logical return_(void);
static logical usestl;
extern logical odd_(integer *);
/* $ Abstract */
/* Deprecated: This routine has been superseded by SPKAPS. This */
/* routine is supported for purposes of backward compatibility only. */
/* Return the state (position and velocity) of a target body */
/* relative to an observer, optionally corrected for light time and */
/* stellar aberration. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* SPK */
/* $ Keywords */
/* EPHEMERIS */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TARG I Target body. */
/* ET I Observer epoch. */
/* REF I Inertial reference frame of observer's state. */
/* SOBS I State of observer wrt. solar system barycenter. */
/* ABCORR I Aberration correction flag. */
/* STARG O State of target. */
/* LT O One way light time between observer and target. */
/* $ Detailed_Input */
/* TARG is the NAIF ID code for a target body. The target */
/* and observer define a state vector whose position */
/* component points from the observer to the target. */
/* ET is the ephemeris time, expressed as seconds past J2000 */
/* TDB, at which the state of the target body relative to */
/* the observer is to be computed. ET refers to time at */
/* the observer's location. */
/* REF is the inertial reference frame with respect to which */
/* the observer's state SOBS is expressed. REF must be */
/* recognized by the SPICE Toolkit. The acceptable */
/* frames are listed in the Frames Required Reading, as */
/* well as in the SPICELIB routine CHGIRF. */
/* Case and blanks are not significant in the string REF. */
/* SOBS is the geometric (uncorrected) state of the observer */
/* relative to the solar system barycenter at epoch ET. */
/* SOBS is a 6-vector: the first three components of */
/* SOBS represent a Cartesian position vector; the last */
/* three components represent the corresponding velocity */
/* vector. SOBS is expressed relative to the inertial */
/* reference frame designated by REF. */
/* Units are always km and km/sec. */
/* ABCORR indicates the aberration corrections to be applied */
/* to the state of the target body to account for one-way */
/* light time and stellar aberration. See the discussion */
/* in the Particulars section for recommendations on */
/* how to choose aberration corrections. */
/* ABCORR may be any of the following: */
/* 'NONE' Apply no correction. Return the */
/* geometric state of the target body */
/* relative to the observer. */
/* The following values of ABCORR apply to the */
/* "reception" case in which photons depart from the */
/* target's location at the light-time corrected epoch */
/* ET-LT and *arrive* at the observer's location at ET: */
/* 'LT' Correct for one-way light time (also */
/* called "planetary aberration") using a */
/* Newtonian formulation. This correction */
/* yields the state of the target at the */
/* moment it emitted photons arriving at */
/* the observer at ET. */
/* The light time correction involves */
/* iterative solution of the light time */
/* equation (see Particulars for details). */
/* The solution invoked by the 'LT' option */
/* uses one iteration. */
/* 'LT+S' Correct for one-way light time and */
/* stellar aberration using a Newtonian */
/* formulation. This option modifies the */
/* state obtained with the 'LT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The result is the apparent */
/* state of the target---the position and */
/* velocity of the target as seen by the */
/* observer. */
/* 'CN' Converged Newtonian light time */
/* correction. In solving the light time */
/* equation, the 'CN' correction iterates */
/* until the solution converges (three */
/* iterations on all supported platforms). */
/* Whether the 'CN+S' solution is */
/* substantially more accurate than the */
/* 'LT' solution depends on the geometry */
/* of the participating objects and on the */
/* accuracy of the input data. In all */
/* cases this routine will execute more */
/* slowly when a converged solution is */
/* computed. See the Particulars section */
/* of SPKEZR for a discussion of precision */
/* of light time corrections. */
/* 'CN+S' Converged Newtonian light time */
/* correction and stellar aberration */
/* correction. */
/* The following values of ABCORR apply to the */
/* "transmission" case in which photons *depart* from */
/* the observer's location at ET and arrive at the */
/* target's location at the light-time corrected epoch */
/* ET+LT: */
/* 'XLT' "Transmission" case: correct for */
/* one-way light time using a Newtonian */
/* formulation. This correction yields the */
/* state of the target at the moment it */
/* receives photons emitted from the */
/* observer's location at ET. */
/* 'XLT+S' "Transmission" case: correct for */
/* one-way light time and stellar */
/* aberration using a Newtonian */
/* formulation This option modifies the */
/* state obtained with the 'XLT' option to */
/* account for the observer's velocity */
/* relative to the solar system */
/* barycenter. The position component of */
/* the computed target state indicates the */
/* direction that photons emitted from the */
/* observer's location must be "aimed" to */
/* hit the target. */
/* 'XCN' "Transmission" case: converged */
/* Newtonian light time correction. */
/* 'XCN+S' "Transmission" case: converged */
/* Newtonian light time correction and */
/* stellar aberration correction. */
/* Neither special nor general relativistic effects are */
/* accounted for in the aberration corrections applied */
/* by this routine. */
/* Case and blanks are not significant in the string */
/* ABCORR. */
/* $ Detailed_Output */
/* STARG is a Cartesian state vector representing the position */
/* and velocity of the target body relative to the */
/* specified observer. STARG is corrected for the */
/* specified aberrations, and is expressed with respect */
/* to the specified inertial reference frame. The first */
/* three components of STARG represent the x-, y- and */
/* z-components of the target's position; last three */
/* components form the corresponding velocity vector. */
/* The position component of STARG points from the */
/* observer's location at ET to the aberration-corrected */
/* location of the target. Note that the sense of the */
/* position vector is independent of the direction of */
/* radiation travel implied by the aberration */
/* correction. */
/* The velocity component of STARG is obtained by */
/* evaluating the target's geometric state at the light */
/* time corrected epoch, so for aberration-corrected */
/* states, the velocity is not precisely equal to the */
/* time derivative of the position. */
/* Units are always km and km/sec. */
/* LT is the one-way light time between the observer and */
/* target in seconds. If the target state is corrected */
/* for aberrations, then LT is the one-way light time */
/* between the observer and the light time corrected */
/* target location. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the value of ABCORR is not recognized, the error */
/* 'SPICE(SPKINVALIDOPTION)' is signaled. */
/* 2) If the reference frame requested is not a recognized */
/* inertial reference frame, the error 'SPICE(BADFRAME)' */
/* is signaled. */
/* 3) If the state of the target relative to the solar system */
/* barycenter cannot be computed, the error will be diagnosed */
/* by routines in the call tree of this routine. */
/* $ Files */
/* This routine computes states using SPK files that have been */
/* loaded into the SPICE system, normally via the kernel loading */
/* interface routine FURNSH. Application programs typically load */
/* kernels once before this routine is called, for example during */
/* program initialization; kernels need not be loaded repeatedly. */
/* See the routine FURNSH and the SPK and KERNEL Required Reading */
/* for further information on loading (and unloading) kernels. */
/* If any of the ephemeris data used to compute STARG are expressed */
/* relative to a non-inertial frame in the SPK files providing those */
/* data, additional kernels may be needed to enable the reference */
/* frame transformations required to compute the state. Normally */
/* these additional kernels are PCK files or frame kernels. Any */
/* such kernels must already be loaded at the time this routine is */
/* called. */
/* $ Particulars */
/* In space science or engineering applications one frequently */
/* wishes to know where to point a remote sensing instrument, such */
/* as an optical camera or radio antenna, in order to observe or */
/* otherwise receive radiation from a target. This pointing problem */
/* is complicated by the finite speed of light: one needs to point */
/* to where the target appears to be as opposed to where it actually */
/* is at the epoch of observation. We use the adjectives */
/* "geometric," "uncorrected," or "true" to refer to an actual */
/* position or state of a target at a specified epoch. When a */
/* geometric position or state vector is modified to reflect how it */
/* appears to an observer, we describe that vector by any of the */
/* terms "apparent," "corrected," "aberration corrected," or "light */
/* time and stellar aberration corrected." */
/* The SPICE Toolkit can correct for two phenomena affecting the */
/* apparent location of an object: one-way light time (also called */
/* "planetary aberration") and stellar aberration. Correcting for */
/* one-way light time is done by computing, given an observer and */
/* observation epoch, where a target was when the observed photons */
/* departed the target's location. The vector from the observer to */
/* this computed target location is called a "light time corrected" */
/* vector. The light time correction depends on the motion of the */
/* target, but it is independent of the velocity of the observer */
/* relative to the solar system barycenter. Relativistic effects */
/* such as light bending and gravitational delay are not accounted */
/* for in the light time correction performed by this routine. */
/* The velocity of the observer also affects the apparent location */
/* of a target: photons arriving at the observer are subject to a */
/* "raindrop effect" whereby their velocity relative to the observer */
/* is, using a Newtonian approximation, the photons' velocity */
/* relative to the solar system barycenter minus the velocity of the */
/* observer relative to the solar system barycenter. This effect is */
/* called "stellar aberration." Stellar aberration is independent */
/* of the velocity of the target. The stellar aberration formula */
/* used by this routine is non-relativistic. */
/* Stellar aberration corrections are applied after light time */
/* corrections: the light time corrected target position vector is */
/* used as an input to the stellar aberration correction. */
/* When light time and stellar aberration corrections are both */
/* applied to a geometric position vector, the resulting position */
/* vector indicates where the target "appears to be" from the */
/* observer's location. */
/* As opposed to computing the apparent position of a target, one */
/* may wish to compute the pointing direction required for */
/* transmission of photons to the target. This requires correction */
/* of the geometric target position for the effects of light time and */
/* stellar aberration, but in this case the corrections are computed */
/* for radiation traveling from the observer to the target. */
/* The "transmission" light time correction yields the target's */
/* location as it will be when photons emitted from the observer's */
/* location at ET arrive at the target. The transmission stellar */
/* aberration correction is the inverse of the traditional stellar */
/* aberration correction: it indicates the direction in which */
/* radiation should be emitted so that, using a Newtonian */
/* approximation, the sum of the velocity of the radiation relative */
/* to the observer and of the observer's velocity, relative to the */
/* solar system barycenter, yields a velocity vector that points in */
/* the direction of the light time corrected position of the target. */
/* The traditional aberration corrections applicable to observation */
/* and those applicable to transmission are related in a simple way: */
/* one may picture the geometry of the "transmission" case by */
/* imagining the "observation" case running in reverse time order, */
/* and vice versa. */
/* One may reasonably object to using the term "observer" in the */
/* transmission case, in which radiation is emitted from the */
/* observer's location. The terminology was retained for */
/* consistency with earlier documentation. */
/* Below, we indicate the aberration corrections to use for some */
/* common applications: */
/* 1) Find the apparent direction of a target for a remote-sensing */
/* observation. */
/* Use 'LT+S' or 'CN+S: apply both light time and stellar */
/* aberration corrections. */
/* Note that using light time corrections alone ('LT' or 'CN') */
/* is generally not a good way to obtain an approximation to */
/* an apparent target vector: since light time and stellar */
/* aberration corrections often partially cancel each other, */
/* it may be more accurate to use no correction at all than to */
/* use light time alone. */
/* 2) Find the corrected pointing direction to radiate a signal */
/* to a target. This computation is often applicable for */
/* implementing communications sessions. */
/* Use 'XLT+S' or 'XCN+S: apply both light time and stellar */
/* aberration corrections for transmission. */
/* 3) Compute the apparent position of a target body relative */
/* to a star or other distant object. */
/* Use 'LT', 'CN', 'LT+S', or 'CN+S' as needed to match the */
/* correction applied to the position of the distant */
/* object. For example, if a star position is obtained from */
/* a catalog, the position vector may not be corrected for */
/* stellar aberration. In this case, to find the angular */
/* separation of the star and the limb of a planet, the */
/* vector from the observer to the planet should be */
/* corrected for light time but not stellar aberration. */
/* 4) Obtain an uncorrected state vector derived directly from */
/* data in an SPK file. */
/* Use 'NONE'. */
/* C */
/* 5) Use a geometric state vector as a low-accuracy estimate */
/* of the apparent state for an application where execution */
/* speed is critical: */
/* Use 'NONE'. */
/* 6) While this routine cannot perform the relativistic */
/* aberration corrections required to compute states */
/* with the highest possible accuracy, it can supply the */
/* geometric states required as inputs to these computations: */
/* Use 'NONE', then apply high-accuracy aberration */
/* corrections (not available in the SPICE Toolkit). */
/* Below, we discuss in more detail how the aberration corrections */
/* applied by this routine are computed. */
/* Geometric case */
/* ============== */
/* SPKAPP begins by computing the geometric position T(ET) of the */
/* target body relative to the solar system barycenter (SSB). */
/* Subtracting the geometric position of the observer O(ET) gives */
/* the geometric position of the target body relative to the */
/* observer. The one-way light time, LT, is given by */
/* | T(ET) - O(ET) | */
/* LT = ------------------- */
/* c */
/* The geometric relationship between the observer, target, and */
/* solar system barycenter is as shown: */
/* SSB ---> O(ET) */
/* | / */
/* | / */
/* | / */
/* | / T(ET) - O(ET) */
/* V V */
/* T(ET) */
/* The returned state consists of the position vector */
/* T(ET) - O(ET) */
/* and a velocity obtained by taking the difference of the */
/* corresponding velocities. In the geometric case, the */
/* returned velocity is actually the time derivative of the */
/* position. */
/* Reception case */
/* ============== */
/* When any of the options 'LT', 'CN', 'LT+S', 'CN+S' is */
/* selected, SPKAPP computes the position of the target body at */
/* epoch ET-LT, where LT is the one-way light time. Let T(t) and */
/* O(t) represent the positions of the target and observer */
/* relative to the solar system barycenter at time t; then LT is */
/* the solution of the light-time equation */
/* | T(ET-LT) - O(ET) | */
/* LT = ------------------------ (1) */
/* c */
/* The ratio */
/* | T(ET) - O(ET) | */
/* --------------------- (2) */
/* c */
/* is used as a first approximation to LT; inserting (2) into the */
/* RHS of the light-time equation (1) yields the "one-iteration" */
/* estimate of the one-way light time. Repeating the process */
/* until the estimates of LT converge yields the "converged */
/* Newtonian" light time estimate. */
/* Subtracting the geometric position of the observer O(ET) gives */
/* the position of the target body relative to the observer: */
/* T(ET-LT) - O(ET). */
/* SSB ---> O(ET) */
/* | \ | */
/* | \ | */
/* | \ | T(ET-LT) - O(ET) */
/* | \ | */
/* V V V */
/* T(ET) T(ET-LT) */
/* The position component of the light-time corrected state */
/* is the vector */
/* T(ET-LT) - O(ET) */
/* The velocity component of the light-time corrected state */
/* is the difference */
/* T_vel(ET-LT) - O_vel(ET) */
/* where T_vel and O_vel are, respectively, the velocities of */
/* the target and observer relative to the solar system */
/* barycenter at the epochs ET-LT and ET. */
/* If correction for stellar aberration is requested, the target */
/* position is rotated toward the solar system barycenter- */
/* relative velocity vector of the observer. The rotation is */
/* computed as follows: */
/* Let r be the light time corrected vector from the observer */
/* to the object, and v be the velocity of the observer with */
/* respect to the solar system barycenter. Let w be the angle */
/* between them. The aberration angle phi is given by */
/* sin(phi) = v sin(w) / c */
/* Let h be the vector given by the cross product */
/* h = r X v */
/* Rotate r by phi radians about h to obtain the apparent */
/* position of the object. */
/* The velocity component of the output state STARG is */
/* not corrected for stellar aberration. */
/* Transmission case */
/* ================== */
/* When any of the options 'XLT', 'XCN', 'XLT+S', 'XCN+S' are */
/* selected, SPKAPP computes the position of the target body T at */
/* epoch ET+LT, where LT is the one-way light time. LT is the */
/* solution of the light-time equation */
/* | T(ET+LT) - O(ET) | */
/* LT = ------------------------ (3) */
/* c */
/* Subtracting the geometric position of the observer, O(ET), */
/* gives the position of the target body relative to the */
/* observer: T(ET-LT) - O(ET). */
/* SSB --> O(ET) */
/* / | * */
/* / | * T(ET+LT) - O(ET) */
/* / |* */
/* / *| */
/* V V V */
/* T(ET+LT) T(ET) */
/* The position component of the light-time corrected state */
/* is the vector */
/* T(ET+LT) - O(ET) */
/* The velocity component of the light-time corrected state */
/* is the difference */
/* T_vel(ET+LT) - O_vel(ET) */
/* where T_vel and O_vel are, respectively, the velocities of */
/* the target and observer relative to the solar system */
/* barycenter at the epochs ET+LT and ET. */
/* If correction for stellar aberration is requested, the target */
/* position is rotated away from the solar system barycenter- */
/* relative velocity vector of the observer. The rotation is */
/* computed as in the reception case, but the sign of the */
/* rotation angle is negated. */
/* The velocity component of the output state STARG is */
/* not corrected for stellar aberration. */
/* Neither special nor general relativistic effects are accounted */
/* for in the aberration corrections performed by this routine. */
/* $ Examples */
/* In the following code fragment, SPKSSB and SPKAPP are used */
/* to display the position of Io (body 501) as seen from the */
/* Voyager 2 spacecraft (Body -32) at a series of epochs. */
/* Normally, one would call the high-level reader SPKEZR to obtain */
/* state vectors. The example below illustrates the interface */
/* of this routine but is not intended as a recommendation on */
/* how to use the SPICE SPK subsystem. */
/* The use of integer ID codes is necessitated by the low-level */
/* interface of this routine. */
/* IO = 501 */
/* VGR2 = -32 */
/* DO WHILE ( EPOCH .LE. END ) */
/* CALL SPKSSB ( VGR2, EPOCH, 'J2000', STVGR2 ) */
/* CALL SPKAPP ( IO, EPOCH, 'J2000', STVGR2, */
/* . 'LT+S', STIO, LT ) */
/* CALL RECRAD ( STIO, RANGE, RA, DEC ) */
/* WRITE (*,*) RA * DPR(), DEC * DPR() */
/* EPOCH = EPOCH + DELTA */
/* END DO */
/* $ Restrictions */
/* 1) The kernel files to be used by SPKAPP must be loaded */
/* (normally by the SPICELIB kernel loader FURNSH) before */
/* this routine is called. */
/* 2) Unlike most other SPK state computation routines, this */
/* routine requires that the input state be relative to an */
/* inertial reference frame. Non-inertial frames are not */
/* supported by this routine. */
/* 3) In a future version of this routine, the implementation */
/* of the aberration corrections may be enhanced to improve */
/* accuracy. */
/* $ Literature_References */
/* SPK Required Reading. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* B.V. Semenov (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 3.1.0, 04-JUL-2014 (NJB) (BVS) */
/* Discussion of light time corrections was updated. Assertions */
/* that converged light time corrections are unlikely to be */
/* useful were removed. */
/* Last update was 21-SEP-2013 (BVS) */
/* Updated to call LJUCRS instead of CMPRSS/UCASE. */
/* - SPICELIB Version 3.0.3, 18-MAY-2010 (BVS) */
/* Index lines now state that this routine is deprecated. */
/* - SPICELIB Version 3.0.2, 08-JAN-2008 (NJB) */
/* The Abstract section of the header was updated to */
/* indicate that this routine has been deprecated. */
/* - SPICELIB Version 3.0.1, 20-OCT-2003 (EDW) */
/* Added mention that LT returns in seconds. */
/* Corrected spelling errors. */
/* - SPICELIB Version 3.0.0, 18-DEC-2001 (NJB) */
/* Updated to handle aberration corrections for transmission */
/* of radiation. Formerly, only the reception case was */
/* supported. The header was revised and expanded to explain */
/* the functionality of this routine in more detail. */
/* - SPICELIB Version 2.1.0, 09-JUL-1996 (WLT) */
/* Corrected the description of LT in the Detailed Output */
/* section of the header. */
/* - SPICELIB Version 2.0.0, 22-MAY-1995 (WLT) */
/* The routine was modified to support the options 'CN' and */
/* 'CN+S' aberration corrections. Moreover, diagnostics were */
/* added to check for reference frames that are not recognized */
/* inertial frames. */
/* - SPICELIB Version 1.1.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.1.1, 06-MAR-1991 (JML) */
/* In the example program, the calling sequence of SPKAPP */
/* was corrected. */
/* - SPICELIB Version 1.1.0, 25-MAY-1990 (HAN) */
/* The local variable CORR was added to eliminate a */
/* run-time error that occurred when SPKAPP was determining */
/* what corrections to apply to the state. */
/* - SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */
/* Literature references added to the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* DEPRECATED low-level aberration correction */
/* DEPRECATED apparent state from spk file */
/* DEPRECATED get apparent state */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.0.0, 22-MAY-1995 (WLT) */
/* The routine was modified to support the options 'CN' and */
/* 'CN+S' aberration corrections. Moreover, diagnostics were */
/* added to check for reference frames that are not recognized */
/* inertial frames. */
/* - SPICELIB Version 1.1.1, 06-MAR-1991 (JML) */
/* In the example program, the calling sequence of SPKAPP */
/* was corrected. */
/* - SPICELIB Version 1.1.0, 25-MAY-1990 (HAN) */
/* The local variable CORR was added to eliminate a run-time */
/* error that occurred when SPKAPP was determining what */
/* corrections to apply to the state. If the literal string */
/* 'LT' was assigned to ABCORR, SPKAPP attempted to look at */
/* ABCORR(3:4). Because ABCORR is a passed length argument, its */
/* length is not guaranteed, and those positions may not exist. */
/* Searching beyond the bounds of a string resulted in a */
/* run-time error at NAIF because NAIF compiles SPICELIB using the */
/* CHECK=BOUNDS option for the DEC VAX/VMX DCL FORTRAN command. */
/* Also, without the local variable CORR, SPKAPP would have to */
/* modify the value of a passed argument, ABCORR. That's a no no. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Indices of flags in the FLAGS array: */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZSPKAP1", (ftnlen)8);
}
if (first || s_cmp(abcorr, prvcor, abcorr_len, (ftnlen)5) != 0) {
/* The aberration correction flag differs from the value it */
/* had on the previous call, if any. Analyze the new flag. */
/* Remove leading and embedded white space from the aberration */
/* correction flag and convert to upper case. */
ljucrs_(&c__0, abcorr, corr, abcorr_len, (ftnlen)5);
/* Locate the flag in our list of flags. */
i__ = isrchc_(corr, &c__9, flags, (ftnlen)5, (ftnlen)5);
if (i__ == 0) {
setmsg_("Requested aberration correction # is not supported.", (
ftnlen)51);
errch_("#", abcorr, (ftnlen)1, abcorr_len);
sigerr_("SPICE(SPKINVALIDOPTION)", (ftnlen)23);
chkout_("ZZSPKAP1", (ftnlen)8);
return 0;
}
/* The aberration correction flag is recognized; save it. */
s_copy(prvcor, abcorr, (ftnlen)5, abcorr_len);
/* Set logical flags indicating the attributes of the requested */
/* correction. */
xmit = i__ > 5;
uselt = i__ == 2 || i__ == 3 || i__ == 6 || i__ == 7;
usestl = i__ > 1 && odd_(&i__);
usecn = i__ == 4 || i__ == 5 || i__ == 8 || i__ == 9;
first = FALSE_;
}
/* See if the reference frame is a recognized inertial frame. */
irfnum_(ref, &refid, ref_len);
if (refid == 0) {
setmsg_("The requested frame '#' is not a recognized inertial frame. "
, (ftnlen)60);
errch_("#", ref, (ftnlen)1, ref_len);
sigerr_("SPICE(BADFRAME)", (ftnlen)15);
chkout_("ZZSPKAP1", (ftnlen)8);
return 0;
}
/* Determine the sign of the light time offset. */
if (xmit) {
ltsign = 1;
} else {
ltsign = -1;
}
/* Find the geometric state of the target body with respect to the */
/* solar system barycenter. Subtract the state of the observer */
/* to get the relative state. Use this to compute the one-way */
/* light time. */
zzspksb1_(targ, et, ref, starg, ref_len);
vsubg_(starg, sobs, &c__6, tstate);
moved_(tstate, &c__6, starg);
*lt = vnorm_(starg) / clight_();
/* To correct for light time, find the state of the target body */
/* at the current epoch minus the one-way light time. Note that */
/* the observer remains where he is. */
if (uselt) {
maxitr = 1;
} else if (usecn) {
maxitr = 3;
} else {
maxitr = 0;
}
i__1 = maxitr;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = *et + ltsign * *lt;
zzspksb1_(targ, &d__1, ref, starg, ref_len);
vsubg_(starg, sobs, &c__6, tstate);
moved_(tstate, &c__6, starg);
*lt = vnorm_(starg) / clight_();
}
/* At this point, STARG contains the light time corrected */
/* state of the target relative to the observer. */
/* If stellar aberration correction is requested, perform it now. */
/* Stellar aberration corrections are not applied to the target's */
/* velocity. */
if (usestl) {
if (xmit) {
/* This is the transmission case. */
/* Compute the position vector obtained by applying */
/* "reception" stellar aberration to STARG. */
stlabx_(starg, &sobs[3], sapos);
vequ_(sapos, starg);
} else {
/* This is the reception case. */
/* Compute the position vector obtained by applying */
/* "reception" stellar aberration to STARG. */
stelab_(starg, &sobs[3], sapos);
vequ_(sapos, starg);
}
}
chkout_("ZZSPKAP1", (ftnlen)8);
return 0;
} /* zzspkap1_ */
logical l_lt(char *a, char *b, ftnlen la, ftnlen lb)
#endif
{
return(s_cmp(a,b,la,lb) < 0);
}
