コード例 #1
0
ファイル: zzholdd.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure ZZHOLDD ( Private --- hold a scalar DP ) */
/* Subroutine */ int zzholdd_(integer *op, integer *id, logical *ok, 
	doublereal *value)
{
    /* Initialized data */

    static logical init = TRUE_;

    /* System generated locals */
    integer i__1;

    /* Builtin functions */
    integer s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer i__;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    static logical first[4];
    extern integer brckti_(integer *, integer *, integer *);
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen);
    static doublereal svalue[4];
    extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *, 
	    integer *, ftnlen);
    extern logical return_(void);

/* $ 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. */

/*     Persistently store double precision values or retrieve stored */
/*     double precision values. That's it, not really rocket science. */

/* $ 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 */

/*     STORE DP VALUE */

/* $ Declarations */
/* $ 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 file contains parameter declarations for the ZZHOLDD */
/*     routine. */

/* $ 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 */

/*     None. */

/* $ Declarations */

/*     None. */

/* $ Brief_I/O */

/*     None. */

/* $ Detailed_Input */

/*     None. */

/* $ Detailed_Output */

/*     None. */

/* $ Parameters */

/*     GEN       general value, primarily for testing. */

/*     GF_REF    user defined GF reference value. */

/*     GF_TOL    user defined GF convergence tolerance. */

/*     GF_DT     user defined GF step for numeric differentiation. */

/* $ Exceptions */

/*     None. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     None. */

/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     E.D. Wright    (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.0  03-DEC-2013 (EDW) */

/* -& */

/*     OP codes. The values exist in the integer domain */
/*     [ -ZZNOP, -1], */


/*     Current number of OP codes. */


/*     ID codes. The values exist in the integer domain */
/*     [ 1, NID], */


/*     General use, primarily testing. */


/*     The user defined GF reference value. */


/*     The user defined GF convergence tolerance. */


/*     The user defined GF step for numeric differentiation. */


/*     Current number of ID codes, dimension of array */
/*     in ZZHOLDD. Bad things can happen if this parameter */
/*     does not have the proper value. */


/*     End of file zzholdd.inc. */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     OP         I   Key for operation to execute. */
/*     ID         I   The ID for the item to apply OP. */
/*     OK         O   Boolean indicating success of get operation. */
/*     VALUE     I-O  Double precision value returned or to store. */

/* $ Detailed_Input */

/*     OP          The scalar integer key for the operation to execute. */
/*                 Proper values of OP: */

/*                    ZZPUT     store a double precision value for */
/*                              later use (put). */

/*                    ZZGET     retrieve a stored double precision */
/*                              value (get). */

/*                    ZZRESET   reset function to require a ZZPUT prior */
/*                              to a subsequent ZZGET (clear). */

/*     ID          The scalar integer ID for the item to get/put etc. */
/*                 Proper values of ID: */

/*                    GEN       general value, primarily for testing. */

/*                    GF_REF    user defined GF reference value. */

/*                    GF_TOL    user defined GF convergence tolerance. */

/*                    GF_DT     user defined GF step for numeric */
/*                              differentiation. */

/*     VALUE       The scalar double precision value to store (put). */

/*     The include file "zzholdd.inc" lists all accepted values for */
/*     ID and OP. */

/* $ Detailed_Output */

/*     OK          The logical flag indicating if a get operation */
/*                 returned a valid value for ID. OK returns false if a */
/*                 get operation occurs before a put. */

/*                 This argument has no meaning except when performing */
/*                 a get operation. */

/*     VALUE       The scalar double precision value retrieved (get). */

/* $ Parameters */

/*    None. */

/* $ Exceptions */

/*     1)  The error SPICE(UNKNOWNID) signals if the value of ID is */
/*         not one of those coded in zzholdd.inc. */

/*     2)  The error SPICE(UNKNOWNOP) signals if the value of OP is */
/*         not one of those coded in zzholdd.inc. */

/* $ Files */

/*    zzholdd.inc */

/* $ Particulars */

/*     This routine simply stores double precision values for later */
/*     retrieval. */

/*     A get operation may succeed or fail based on whether */
/*     a put operation preceded the put. */

/*        A ZZHOLDD get operation for an ID called before a put operation */
/*        for that ID returns with OK as false, VALUE as 0. */

/*        A ZZHOLDD get operation for an ID called after a put operation */
/*        for that ID returns with OK as true, VALUE as the value */
/*        assigned by the put. */

/* $ Examples */

/*     The numerical results shown for these examples may differ across */
/*     platforms. The results depend on the SPICE kernels used as */
/*     input, the compiler and supporting libraries, and the machine */
/*     specific arithmetic implementation. */

/*     Store values using ZZHOLDD then attempt to retrieve the values. */

/*           PROGRAM ZZHOLDD_T */
/*           IMPLICIT NONE */

/*           INCLUDE 'zzholdd.inc' */

/*           DOUBLE PRECISION     VALUE */
/*           DOUBLE PRECISION     X */
/*           DOUBLE PRECISION     Y */
/*           DOUBLE PRECISION     Z */
/*           LOGICAL              OK */

/*           X = -11.D0 */
/*           Y =  22.D0 */
/*           Z = -33.D0 */

/*     C */
/*     C     Perform a put then get. */
/*     C */
/*           VALUE = 0.D0 */
/*           OK    = .FALSE. */
/*           CALL ZZHOLDD ( ZZPUT, GEN, OK, X) */
/*           CALL ZZHOLDD ( ZZGET, GEN, OK, VALUE ) */

/*           IF (OK) THEN */
/*              WRITE(*,*) 'Check 1 ', VALUE */
/*           ELSE */
/*              WRITE(*,*) 'Error 1 ' */
/*           END IF */

/*     C */
/*     C     Reset then get without put. */
/*     C */
/*           VALUE = 0.D0 */
/*           OK    = .FALSE. */

/*           CALL ZZHOLDD ( ZZRESET,   GEN, OK, VALUE ) */
/*           CALL ZZHOLDD ( ZZGET,     GEN, OK, VALUE ) */

/*           IF (OK) THEN */
/*              WRITE(*,*) 'Error 2 ' */
/*           ELSE */
/*              WRITE(*,*) 'Check 2 ', VALUE */
/*           END IF */

/*     C */
/*     C     Now put. */
/*     C */
/*           CALL ZZHOLDD ( ZZPUT, GEN, OK, Y) */
/*           CALL ZZHOLDD ( ZZGET, GEN, OK, VALUE ) */

/*           IF (OK) THEN */
/*              WRITE(*,*) 'Check 3 ', VALUE */
/*           ELSE */
/*              WRITE(*,*) 'Error 3 ' */
/*           END IF */


/*     C */
/*     C     Now another put with a different value. */
/*     C */
/*           CALL ZZHOLDD ( ZZPUT, GEN, OK, Z) */
/*           CALL ZZHOLDD ( ZZGET, GEN, OK, VALUE ) */

/*           IF (OK) THEN */
/*              WRITE(*,*) 'Check 4 ', VALUE */
/*           ELSE */
/*              WRITE(*,*) 'Error 4 ' */
/*           END IF */

/*           END */

/*   The program outputs: */

/*      Check 1   -11.000000000000000 */
/*      Check 2    0.0000000000000000 */
/*      Check 3    22.000000000000000 */
/*      Check 4   -33.000000000000000 */

/*    As expected. */

/* $ Restrictions */

/*    None. */

/* $ Literature_References */

/*    None. */

/* $ Author_and_Institution */

/*    E.D. Wright    (JPL) */

/* $ Version */

/* -   SPICELIB Version 1.1.0  03-DEC-2013 (EDW) */

/*       Added ID and OK arguments to routine, generalizing use. */

/*       Added RETURN() check. */

/* -   SPICELIB Version 1.0.0  16-FEB-2010 (EDW) */

/* -& */
/* $ Index_Entries */

/*    store a double precision value */
/*    retrieve a stored double precision value */

/* -& */

/*     SPICELIB functions */


/*     Local variables. */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    }

/*     Confirm a proper ID value. */

    if (brckti_(id, &c__1, &c__4) != *id) {
	*value = 0.;
	*ok = FALSE_;
	chkin_("ZZHOLDD", (ftnlen)7);
	setmsg_("ID value unknown. ID value #1 not an element of [1, #2]. Co"
		"nfirmthe ID value exists in the zzholdd.inc parameter file.", 
		(ftnlen)118);
	errint_("#1", id, (ftnlen)2);
	errint_("#2", &c__4, (ftnlen)2);
	sigerr_("SPICE(UNKNOWNID)", (ftnlen)16);
	chkout_("ZZHOLDD", (ftnlen)7);
	return 0;
    }

/*     Initialize the FIRST array; perform once per program run. */

    if (init) {
	for (i__ = 1; i__ <= 4; ++i__) {
	    first[(i__1 = i__ - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge("first", 
		    i__1, "zzholdd_", (ftnlen)318)] = TRUE_;
	}
	init = FALSE_;
    }

/*     Perform the operation as described by OP. */

    if (*op == -1) {

/*        Attempt to retrieve a stored double precision value for ID. */

/*          - Return the value stored by a put operation and OK */
/*            as true. */

/*          - If no previous set to this ID, return value as zero and */
/*            OK as false. */

	if (first[(i__1 = *id - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge("first", 
		i__1, "zzholdd_", (ftnlen)341)]) {
	    *value = 0.;
	    *ok = FALSE_;
	} else {

/*           Return the stored value. */

	    *value = svalue[(i__1 = *id - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge(
		    "svalue", i__1, "zzholdd_", (ftnlen)351)];
	    *ok = TRUE_;
	}
    } else if (*op == -2) {

/*        Store a value for later use. Set FIRST to false */
/*        so subsequent get calls will work. */

	if (first[(i__1 = *id - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge("first", 
		i__1, "zzholdd_", (ftnlen)363)]) {
	    first[(i__1 = *id - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge("first", 
		    i__1, "zzholdd_", (ftnlen)365)] = FALSE_;
	}
	svalue[(i__1 = *id - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge("svalue", 
		i__1, "zzholdd_", (ftnlen)369)] = *value;
    } else if (*op == -3) {

/*        Reset FIRST( ID ) forcing a put before a get. */

	first[(i__1 = *id - 1) < 4 && 0 <= i__1 ? i__1 : s_rnge("first", i__1,
		 "zzholdd_", (ftnlen)376)] = TRUE_;
    } else {

/*        Unknown value for 'OP'. Signal an error. */

	*value = 0.;
	*ok = FALSE_;
	chkin_("ZZHOLDD", (ftnlen)7);
	setmsg_("Unknown operation. Confirm the OP value # exists in the zzh"
		"oldd.inc parameter file.", (ftnlen)83);
	errint_("#", op, (ftnlen)1);
	sigerr_("SPICE(UNKNOWNOP)", (ftnlen)16);
	chkout_("ZZHOLDD", (ftnlen)7);
	return 0;
    }
    return 0;
} /* zzholdd_ */
コード例 #2
0
ファイル: zzspkas1.c プロジェクト: TomCrowley-ME/me_sim_test
/* $Procedure ZZSPKAS1 ( SPK, apparent state ) */
/* Subroutine */ int zzspkas1_(integer *targ, doublereal *et, char *ref, char 
	*abcorr, doublereal *stobs, doublereal *accobs, doublereal *starg, 
	doublereal *lt, doublereal *dlt, ftnlen ref_len, ftnlen abcorr_len)
{
    /* Initialized data */

    static logical first = TRUE_;
    static char prvcor[5] = "     ";

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

    /* Local variables */
    extern /* Subroutine */ int vadd_(doublereal *, doublereal *, doublereal *
	    ), vequ_(doublereal *, doublereal *);
    static logical xmit;
    extern /* Subroutine */ int zzspklt1_(integer *, doublereal *, char *, 
	    char *, doublereal *, doublereal *, doublereal *, doublereal *, 
	    ftnlen, ftnlen), zzstelab_(logical *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *), zzprscor_(char *, 
	    logical *, ftnlen);
    integer refid;
    extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
	     ftnlen, ftnlen);
    doublereal pcorr[3];
    static logical uselt;
    extern logical failed_(void);
    logical attblk[15];
    doublereal dpcorr[3], corvel[3];
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), irfnum_(char *, integer *, ftnlen), setmsg_(char *, 
	    ftnlen);
    doublereal corpos[3];
    extern logical return_(void);
    static logical usestl;

/* $ Abstract */

/*     Given the state and acceleration of an observer relative to the */
/*     solar system barycenter, return the state (position and velocity) */
/*     of a target body relative to the observer, optionally corrected */
/*     for light time and stellar aberration. All input and output */
/*     vectors are expressed relative to an inertial reference frame. */

/*     This routine supersedes SPKAPP. */

/*     SPICE users normally should call the high-level API routines */
/*     SPKEZR or SPKEZ rather than this routine. */

/* $ 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 */
/* $ Abstract */

/*     Include file zzabcorr.inc */

/*     SPICE private file intended solely for the support of SPICE */
/*     routines.  Users should not include this file directly due */
/*     to the volatile nature of this file */

/*     The parameters below define the structure of an aberration */
/*     correction attribute block. */

/* $ 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. */

/* $ Parameters */

/*     An aberration correction attribute block is an array of logical */
/*     flags indicating the attributes of the aberration correction */
/*     specified by an aberration correction string.  The attributes */
/*     are: */

/*        - Is the correction "geometric"? */

/*        - Is light time correction indicated? */

/*        - Is stellar aberration correction indicated? */

/*        - Is the light time correction of the "converged */
/*          Newtonian" variety? */

/*        - Is the correction for the transmission case? */

/*        - Is the correction relativistic? */

/*    The parameters defining the structure of the block are as */
/*    follows: */

/*       NABCOR    Number of aberration correction choices. */

/*       ABATSZ    Number of elements in the aberration correction */
/*                 block. */

/*       GEOIDX    Index in block of geometric correction flag. */

/*       LTIDX     Index of light time flag. */

/*       STLIDX    Index of stellar aberration flag. */

/*       CNVIDX    Index of converged Newtonian flag. */

/*       XMTIDX    Index of transmission flag. */

/*       RELIDX    Index of relativistic flag. */

/*    The following parameter is not required to define the block */
/*    structure, but it is convenient to include it here: */

/*       CORLEN    The maximum string length required by any aberration */
/*                 correction string */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 18-DEC-2004 (NJB) */

/* -& */
/*     Number of aberration correction choices: */


/*     Aberration correction attribute block size */
/*     (number of aberration correction attributes): */


/*     Indices of attributes within an aberration correction */
/*     attribute block: */


/*     Maximum length of an aberration correction string: */


/*     End of include file zzabcorr.inc */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     TARG       I   Target body. */
/*     ET         I   Observer epoch. */
/*     REF        I   Inertial reference frame of output state. */
/*     ABCORR     I   Aberration correction flag. */
/*     STOBS      I   State of the observer relative to the SSB. */
/*     ACCOBS     I   Acceleration of the observer relative to the SSB. */
/*     STARG      O   State of target. */
/*     LT         O   One way light time between observer and target. */
/*     DLT        O   Derivative of light time with respect to time. */

/* $ 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 input state STOBS, the input acceleration ACCOBS, */
/*                 and the output state STARG are 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. */

/*     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 header of SPKEZR 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 uses an */
/*                               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). */

/*                               The 'CN' correction typically does not */
/*                               substantially improve accuracy because */
/*                               the errors made by ignoring */
/*                               relativistic effects may be larger than */
/*                               the improvement afforded by obtaining */
/*                               convergence of the light time solution. */
/*                               The 'CN' correction computation also */
/*                               requires a significantly greater number */
/*                               of CPU cycles than does the */
/*                               one-iteration light time correction. */

/*                    'CN+S'     Converged Newtonian light time */
/*                               and stellar aberration corrections. */


/*                 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 and stellar */
/*                               aberration corrections. */


/*                 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. */


/*     STOBS       is the geometric state of the observer relative to */
/*                 the solar system barycenter at ET. STOBS is expressed */
/*                 relative to the reference frame designated by REF. */
/*                 The target and observer define a state vector whose */
/*                 position component points from the observer to the */
/*                 target. */

/*     ACCOBS      is the geometric acceleration of the observer */
/*                 relative to the solar system barycenter at ET. This */
/*                 is the derivative with respect to time of the */
/*                 velocity portion of STOBS. ACCOBS is expressed */
/*                 relative to the reference frame designated by REF. */

/*                 ACCOBS is used for computing stellar aberration */
/*                 corrected velocity. If stellar aberration corrections */
/*                 are not specified by ABCORR, ACCOBS is ignored; the */
/*                 caller need not provide a valid input value in this */
/*                 case. */

/* $ 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 inertial reference frame designated by REF. */
/*                 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. */

/*                 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 light time, then LT is the one-way light time */
/*                 between the observer and the light time-corrected */
/*                 target location. */

/*     DLT         is the derivative with respect to barycentric */
/*                 dynamical time of the one way light time between */
/*                 target and observer: */

/*                    DLT = d(LT)/d(ET) */

/*                 DLT can also be described as the rate of change of */
/*                 one way light time. DLT is unitless, since LT and */
/*                 ET both have units of TDB seconds. */

/*                 If the observer and target are at the same position, */
/*                 then DLT is set to zero. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1) If the value of ABCORR is not recognized, the error */
/*        is diagnosed by a routine in the call tree of this */
/*        routine. */

/*     2) If ABCORR calls for stellar aberration but not light */
/*        time corrections, the error SPICE(NOTSUPPORTED) is */
/*        signaled. */

/*     3) If ABCORR calls for relativistic light time corrections, the */
/*        error SPICE(NOTSUPPORTED) is signaled. */

/*     4) If the reference frame requested is not a recognized */
/*        inertial reference frame, the error SPICE(BADFRAME) */
/*        is signaled. */

/*     5) 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. */

/*     6) If the observer and target are at the same position, */
/*        then DLT is set to zero. This situation could arise, */
/*        for example, when the observer is Mars and the target */
/*        is the Mars barycenter. */

/* $ 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 */

/*     This routine supports higher-level SPK API routines that can */
/*     perform both light time and stellar aberration corrections. */

/*     User applications normally will not need to call this routine */
/*     directly. However, this routine can improve run-time efficiency */
/*     in situations where many targets are observed from the same */
/*     location at the same time. In such cases, the state and */
/*     acceleration of the observer relative to the solar system */
/*     barycenter need be computed only once per look-up epoch. */

/*     When apparent positions, rather than apparent states, are */
/*     required, consider using the high-level position-only API */
/*     routines */

/*        SPKPOS */
/*        SPKEZP */

/*     or the low-level, position-only analog of this routine */

/*        SPKAPO */

/*     In general, the position-only routines are more efficient. */

/*     See the header of the routine SPKEZR for a detailed discussion */
/*     of aberration corrections. */

/* $ Examples */

/*    1) Look up a sequence of states of the Moon as seen from the */
/*       Earth. Use light time and stellar aberration corrections. */
/*       Compute the first state for the epoch 2000 JAN 1 12:00:00 TDB; */
/*       compute subsequent states at intervals of 1 hour. For each */
/*       epoch, display the states, the one way light time between */
/*       target and observer, and the rate of change of the one way */
/*       light time. */

/*       Use the following meta-kernel to specify the kernels to */
/*       load: */

/*          KPL/MK */

/*          This meta-kernel is intended to support operation of SPICE */
/*          example programs. The kernels shown here should not be */
/*          assumed to contain adequate or correct versions of data */
/*          required by SPICE-based user applications. */

/*          In order for an application to use this meta-kernel, the */
/*          kernels referenced here must be present in the user's */
/*          current working directory. */


/*          \begindata */

/*             KERNELS_TO_LOAD = ( 'de418.bsp', */
/*                                 'pck00008.tpc', */
/*                                 'naif0008.tls'  ) */

/*          \begintext */


/*       The code example follows: */

/*           PROGRAM EX1 */
/*           IMPLICIT NONE */
/*     C */
/*     C     Local constants */
/*     C */
/*     C     The meta-kernel name shown here refers to a file whose */
/*     C     contents are those shown above. This file and the kernels */
/*     C     it references must exist in your current working directory. */
/*     C */
/*           CHARACTER*(*)         META */
/*           PARAMETER           ( META   = 'example.mk' ) */
/*     C */
/*     C     Use a time step of 1 hour; look up 5 states. */
/*     C */
/*           DOUBLE PRECISION      STEP */
/*           PARAMETER           ( STEP   = 3600.0D0 ) */

/*           INTEGER               MAXITR */
/*           PARAMETER           ( MAXITR = 5 ) */
/*     C */
/*     C     Local variables */
/*     C */
/*           DOUBLE PRECISION      ACC    ( 3 ) */
/*           DOUBLE PRECISION      DLT */
/*           DOUBLE PRECISION      ET */
/*           DOUBLE PRECISION      ET0 */
/*           DOUBLE PRECISION      LT */
/*           DOUBLE PRECISION      STATE  ( 6 ) */
/*           DOUBLE PRECISION      STATE0 ( 6 ) */
/*           DOUBLE PRECISION      STATE2 ( 6 ) */
/*           DOUBLE PRECISION      STOBS  ( 6 ) */
/*           DOUBLE PRECISION      TDELTA */
/*           INTEGER               I */

/*     C */
/*     C     Load the SPK and LSK kernels via the meta-kernel. */
/*     C */
/*           CALL FURNSH ( META ) */
/*     C */
/*     C     Convert the start time to seconds past J2000 TDB. */
/*     C */
/*           CALL STR2ET ( '2000 JAN 1 12:00:00 TDB', ET0 ) */
/*     C */
/*     C     Step through a series of epochs, looking up a */
/*     C     state vector at each one. */
/*     C */
/*           DO I = 1, MAXITR */

/*              ET = ET0 + (I-1)*STEP */

/*     C */
/*     C        Look up a state vector at epoch ET using the */
/*     C        following inputs: */
/*     C */
/*     C           Target:                 Moon (NAIF ID code 301) */
/*     C           Reference frame:        J2000 */
/*     C           Aberration correction:  Light time and stellar */
/*     C                                   aberration ('LT+S') */
/*     C           Observer:               Earth (NAIF ID code 399) */
/*     C */
/*     C        Before we can execute this computation, we'll need the */
/*     C        geometric state and accleration of the observer relative */
/*     C        to the solar system barycenter at ET, expressed */
/*     C        relative to the J2000 reference frame. First find */
/*     C        the state: */
/*     C */
/*              CALL SPKSSB ( 399, ET, 'J2000', STOBS ) */
/*     C */
/*     C        Next compute the acceleration. We numerically */
/*     C        differentiate the velocity using a quadratic */
/*     C        approximation: */
/*     C */
/*              TDELTA = 1.D0 */

/*              CALL SPKSSB ( 399, ET-TDELTA, 'J2000', STATE0 ) */
/*              CALL SPKSSB ( 399, ET+TDELTA, 'J2000', STATE2 ) */

/*              CALL QDERIV ( 3, STATE0(4), STATE2(4), TDELTA, ACC ) */
/*     C */
/*     C        Now compute the desired state vector: */
/*     C */
/*              CALL SPKAPS ( 301,   ET,  'J2000', 'LT+S', */
/*          .                 STOBS, ACC, STATE,    LT,   DLT ) */

/*              WRITE (*,*) 'ET = ', ET */
/*              WRITE (*,*) 'J2000 x-position (km):   ', STATE(1) */
/*              WRITE (*,*) 'J2000 y-position (km):   ', STATE(2) */
/*              WRITE (*,*) 'J2000 z-position (km):   ', STATE(3) */
/*              WRITE (*,*) 'J2000 x-velocity (km/s): ', STATE(4) */
/*              WRITE (*,*) 'J2000 y-velocity (km/s): ', STATE(5) */
/*              WRITE (*,*) 'J2000 z-velocity (km/s): ', STATE(6) */
/*              WRITE (*,*) 'One-way light time (s):  ', LT */
/*              WRITE (*,*) 'Light time rate:         ', DLT */
/*              WRITE (*,*) ' ' */

/*           END DO */

/*           END */


/*     The output produced by this program will vary somewhat as */
/*     a function of the platform on which the program is built and */
/*     executed. On a PC/Linux/g77 platform, the following output */
/*     was produced: */

/*        ET =   0. */
/*        J2000 x-position (km):    -291584.614 */
/*        J2000 y-position (km):    -266693.406 */
/*        J2000 z-position (km):    -76095.6532 */
/*        J2000 x-velocity (km/s):   0.643439157 */
/*        J2000 y-velocity (km/s):  -0.666065874 */
/*        J2000 z-velocity (km/s):  -0.301310063 */
/*        One-way light time (s):    1.34231061 */
/*        Light time rate:           1.07316909E-07 */

/*        ET =   3600. */
/*        J2000 x-position (km):    -289256.459 */
/*        J2000 y-position (km):    -269080.605 */
/*        J2000 z-position (km):    -77177.3528 */
/*        J2000 x-velocity (km/s):   0.64997032 */
/*        J2000 y-velocity (km/s):  -0.660148253 */
/*        J2000 z-velocity (km/s):  -0.299630418 */
/*        One-way light time (s):    1.34269395 */
/*        Light time rate:           1.05652599E-07 */

/*        ET =   7200. */
/*        J2000 x-position (km):    -286904.897 */
/*        J2000 y-position (km):    -271446.417 */
/*        J2000 z-position (km):    -78252.9655 */
/*        J2000 x-velocity (km/s):   0.656443883 */
/*        J2000 y-velocity (km/s):  -0.654183552 */
/*        J2000 z-velocity (km/s):  -0.297928533 */
/*        One-way light time (s):    1.34307131 */
/*        Light time rate:           1.03990457E-07 */

/*        ET =   10800. */
/*        J2000 x-position (km):    -284530.133 */
/*        J2000 y-position (km):    -273790.671 */
/*        J2000 z-position (km):    -79322.4117 */
/*        J2000 x-velocity (km/s):   0.662859505 */
/*        J2000 y-velocity (km/s):  -0.648172247 */
/*        J2000 z-velocity (km/s):  -0.296204558 */
/*        One-way light time (s):    1.34344269 */
/*        Light time rate:           1.02330665E-07 */

/*        ET =   14400. */
/*        J2000 x-position (km):    -282132.378 */
/*        J2000 y-position (km):    -276113.202 */
/*        J2000 z-position (km):    -80385.612 */
/*        J2000 x-velocity (km/s):   0.669216846 */
/*        J2000 y-velocity (km/s):  -0.642114815 */
/*        J2000 z-velocity (km/s):  -0.294458645 */
/*        One-way light time (s):    1.3438081 */
/*        Light time rate:           1.00673404E-07 */


/* $ Restrictions */

/*     1) This routine should not be used to compute geometric states. */
/*        Instead, use SPKEZR, SPKEZ, or SPKGEO. SPKGEO, which is called */
/*        by SPKEZR and SPKEZ, introduces less round-off error when the */
/*        observer and target have a common center that is closer to */
/*        both objects than is the solar system barycenter. */

/*     2) The kernel files to be used by SPKAPS must be loaded */
/*        (normally by the SPICELIB kernel loader FURNSH) before */
/*        this routine is called. */

/*     3) Unlike most other SPK state computation routines, this */
/*        routine requires that the output state be relative to an */
/*        inertial reference frame. */

/* $ Literature_References */

/*     SPK Required Reading. */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 11-JAN-2008 (NJB) */

/* -& */
/* $ Index_Entries */

/*     low-level aberration-corrected state computation */
/*     low-level light time and stellar aberration correction */

/* -& */
/* $ Revisions */

/*     None. */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     Local variables */


/*     Saved variables */


/*     Initial values */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("ZZSPKAS1", (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. */

	zzprscor_(abcorr, attblk, abcorr_len);
	if (failed_()) {
	    chkout_("ZZSPKAS1", (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 is .TRUE. when the correction is for transmitted */
/*           radiation. */

/*           USELT is .TRUE. when any type of light time correction */
/*           (normal or converged Newtonian) is specified. */

/*           USECN indicates converged Newtonian light time correction. */

/*        The above definitions are consistent with those used by */
/*        ZZPRSCOR. */

	xmit = attblk[4];
	uselt = attblk[1];
	usestl = attblk[2];
	if (usestl && ! uselt) {
	    setmsg_("Aberration correction flag # calls for stellar aberrati"
		    "on but not light time corrections. This combination is n"
		    "ot expected.", (ftnlen)123);
	    errch_("#", abcorr, (ftnlen)1, abcorr_len);
	    sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
	    chkout_("ZZSPKAS1", (ftnlen)8);
	    return 0;
	} else if (attblk[5]) {
	    setmsg_("Aberration correction flag # calls for relativistic lig"
		    "ht time correction.", (ftnlen)74);
	    errch_("#", abcorr, (ftnlen)1, abcorr_len);
	    sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
	    chkout_("ZZSPKAS1", (ftnlen)8);
	    return 0;
	}
	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_("ZZSPKAS1", (ftnlen)8);
	return 0;
    }

/*     Get the state of the target relative to the observer, */
/*     optionally corrected for light time. */

    zzspklt1_(targ, et, ref, abcorr, stobs, starg, lt, dlt, ref_len, 
	    abcorr_len);

/*     If stellar aberration corrections are not needed, we're */
/*     already done. */

    if (! usestl) {
	chkout_("ZZSPKAS1", (ftnlen)8);
	return 0;
    }

/*     Get the stellar aberration correction and its time derivative. */

    zzstelab_(&xmit, accobs, &stobs[3], starg, pcorr, dpcorr);

/*     Adding the stellar aberration correction to the light */
/*     time-corrected target position yields the position corrected for */
/*     both light time and stellar aberration. */

    vadd_(pcorr, starg, corpos);
    vequ_(corpos, starg);

/*     Velocity is treated in an analogous manner. */

    vadd_(dpcorr, &starg[3], corvel);
    vequ_(corvel, &starg[3]);
    chkout_("ZZSPKAS1", (ftnlen)8);
    return 0;
} /* zzspkas1_ */
コード例 #3
0
ファイル: getfat.c プロジェクト: Dbelsa/coft
/* $Procedure GETFAT ( Get file architecture and type ) */
/* Subroutine */ int getfat_(char *file, char *arch, char *kertyp, ftnlen 
	file_len, ftnlen arch_len, ftnlen kertyp_len)
{
    /* System generated locals */
    integer i__1;
    cilist ci__1;
    olist o__1;
    cllist cl__1;
    inlist ioin__1;

    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    integer s_cmp(char *, char *, ftnlen, ftnlen), f_inqu(inlist *), s_rnge(
	    char *, integer, char *, integer), f_open(olist *), s_rdue(cilist 
	    *), do_uio(integer *, char *, ftnlen), e_rdue(void), f_clos(
	    cllist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), 
	    e_rsfe(void);

    /* Local variables */
    integer unit;
    extern /* Subroutine */ int zzddhfnh_(char *, integer *, logical *, 
	    ftnlen), zzddhgsd_(char *, integer *, char *, ftnlen, ftnlen), 
	    zzddhnfo_(integer *, char *, integer *, integer *, integer *, 
	    logical *, ftnlen), zzddhhlu_(integer *, char *, logical *, 
	    integer *, ftnlen);
    integer i__;
    extern integer cardi_(integer *);
    char fname[255];
    extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
	     ftnlen, ftnlen);
    integer which;
    extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
    logical found, exist;
    extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen), 
	    idw2at_(char *, char *, char *, ftnlen, ftnlen, ftnlen);
    integer handle;
    extern /* Subroutine */ int dafcls_(integer *);
    char filarc[32];
    extern /* Subroutine */ int dashof_(integer *);
    integer intbff;
    logical opened;
    extern /* Subroutine */ int dafopr_(char *, integer *, ftnlen);
    integer intarc;
    extern /* Subroutine */ int dashlu_(integer *, integer *);
    char idword[12];
    integer intamn, number;
    logical diropn, notdas;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), getlun_(integer *), setmsg_(char *, ftnlen);
    integer iostat;
    extern /* Subroutine */ int errint_(char *, integer *, ftnlen), ssizei_(
	    integer *, integer *), nextwd_(char *, char *, char *, ftnlen, 
	    ftnlen, ftnlen);
    char tmpwrd[12];
    extern logical return_(void);
    integer myunit, handles[106];
    extern /* Subroutine */ int zzckspk_(integer *, char *, ftnlen);

    /* Fortran I/O blocks */
    static cilist io___19 = { 1, 0, 1, 0, 1 };


/* $ Abstract */

/*     Determine the architecture and type of SPICE kernels. */

/* $ 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 */

/*     KERNEL */
/*     UTILITY */

/* $ Declarations */

/* $ Abstract */

/*     Parameter declarations for the DAF/DAS handle manager. */

/* $ 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 */

/*     DAF, DAS */

/* $ Keywords */

/*     PRIVATE */

/* $ Particulars */

/*     This include file contains parameters defining limits and */
/*     integer codes that are utilized in the DAF/DAS handle manager */
/*     routines. */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     F.S. Turner       (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 2.5.0, 10-MAR-2014 (BVS) */

/*        Updated for SUN-SOLARIS-64BIT-INTEL. */

/* -    SPICELIB Version 2.4.0, 10-MAR-2014 (BVS) */

/*        Updated for PC-LINUX-64BIT-IFORT. */

/* -    SPICELIB Version 2.3.0, 10-MAR-2014 (BVS) */

/*        Updated for PC-CYGWIN-GFORTRAN. */

/* -    SPICELIB Version 2.2.0, 10-MAR-2014 (BVS) */

/*        Updated for PC-CYGWIN-64BIT-GFORTRAN. */

/* -    SPICELIB Version 2.1.0, 10-MAR-2014 (BVS) */

/*        Updated for PC-CYGWIN-64BIT-GCC_C. */

/* -    SPICELIB Version 2.0.0, 12-APR-2012 (BVS) */

/*        Increased FTSIZE (from 1000 to 5000). */

/* -    SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */

/*        Updated for SUN-SOLARIS-INTEL. */

/* -    SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */

/*        Updated for SUN-SOLARIS-INTEL-CC_C. */

/* -    SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */

/*        Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */

/* -    SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */

/*        Updated for SUN-SOLARIS-64BIT-NATIVE_C. */

/* -    SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */

/*        Updated for PC-WINDOWS-64BIT-IFORT. */

/* -    SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */

/*        Updated for PC-LINUX-64BIT-GFORTRAN. */

/* -    SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */

/*        Updated for PC-64BIT-MS_C. */

/* -    SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */

/*        Updated for MAC-OSX-64BIT-INTEL_C. */

/* -    SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */

/*        Updated for MAC-OSX-64BIT-IFORT. */

/* -    SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */

/*        Updated for MAC-OSX-64BIT-GFORTRAN. */

/* -    SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */

/*        Updated for PC-LINUX-GFORTRAN. */

/* -    SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */

/*        Updated for MAC-OSX-GFORTRAN. */

/* -    SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */

/*        Updated for PC-LINUX-IFORT. */

/* -    SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */

/*        Updated for PC-LINUX-64BIT-GCC_C. */

/* -    SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */

/*        Updated for MAC-OSX-INTEL_C. */

/* -    SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */

/*        Updated for MAC-OSX-IFORT. */

/* -    SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */

/*        Updated for PC-WINDOWS-IFORT. */

/* -    SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */

/*        Updated for SUN-SOLARIS-64BIT-GCC_C. */

/* -    SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */

/*        Updated for PC-CYGWIN_C. */

/* -    SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */

/*        Updated for PC-CYGWIN. */

/* -    SPICELIB Version 1.0.1, 17-JUL-2002 */

/*        Added MAC-OSX environments. */

/* -    SPICELIB Version 1.0.0, 07-NOV-2001 */

/* -& */

/*     Unit and file table size parameters. */

/*     FTSIZE     is the maximum number of files (DAS and DAF) that a */
/*                user may have open simultaneously. */


/*     RSVUNT     is the number of units protected from being locked */
/*                to a particular handle by ZZDDHHLU. */


/*     SCRUNT     is the number of units protected for use by scratch */
/*                files. */


/*     UTSIZE     is the maximum number of logical units this manager */
/*                will utilize at one time. */


/*     Access method enumeration.  These parameters are used to */
/*     identify which access method is associated with a particular */
/*     handle.  They need to be synchronized with the STRAMH array */
/*     defined in ZZDDHGSD in the following fashion: */

/*        STRAMH ( READ   ) = 'READ' */
/*        STRAMH ( WRITE  ) = 'WRITE' */
/*        STRAMH ( SCRTCH ) = 'SCRATCH' */
/*        STRAMH ( NEW    ) = 'NEW' */

/*     These values are used in the file table variable FTAMH. */


/*     Binary file format enumeration.  These parameters are used to */
/*     identify which binary file format is associated with a */
/*     particular handle.  They need to be synchronized with the STRBFF */
/*     array defined in ZZDDHGSD in the following fashion: */

/*        STRBFF ( BIGI3E ) = 'BIG-IEEE' */
/*        STRBFF ( LTLI3E ) = 'LTL-IEEE' */
/*        STRBFF ( VAXGFL ) = 'VAX-GFLT' */
/*        STRBFF ( VAXDFL ) = 'VAX-DFLT' */

/*     These values are used in the file table variable FTBFF. */


/*     Some random string lengths... more documentation required. */
/*     For now this will have to suffice. */


/*     Architecture enumeration.  These parameters are used to identify */
/*     which file architecture is associated with a particular handle. */
/*     They need to be synchronized with the STRARC array defined in */
/*     ZZDDHGSD in the following fashion: */

/*        STRARC ( DAF ) = 'DAF' */
/*        STRARC ( DAS ) = 'DAS' */

/*     These values will be used in the file table variable FTARC. */


/*     For the following environments, record length is measured in */
/*     characters (bytes) with eight characters per double precision */
/*     number. */

/*     Environment: Sun, Sun FORTRAN */
/*     Source:      Sun Fortran Programmer's Guide */

/*     Environment: PC, MS FORTRAN */
/*     Source:      Microsoft Fortran Optimizing Compiler User's Guide */

/*     Environment: Macintosh, Language Systems FORTRAN */
/*     Source:      Language Systems FORTRAN Reference Manual, */
/*                  Version 1.2, page 12-7 */

/*     Environment: PC/Linux, g77 */
/*     Source:      Determined by experiment. */

/*     Environment: PC, Lahey F77 EM/32 Version 4.0 */
/*     Source:      Lahey F77 EM/32 Language Reference Manual, */
/*                  page 144 */

/*     Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */
/*     Source:      FORTRAN/9000 Reference-Series 700 Computers, */
/*                  page 5-110 */

/*     Environment: NeXT Mach OS (Black Hardware), */
/*                  Absoft Fortran Version 3.2 */
/*     Source:      NAIF Program */


/*     The following parameter defines the size of a string used */
/*     to store a filenames on this target platform. */


/*     The following parameter controls the size of the character record */
/*     buffer used to read data from non-native files. */

/* $ Brief_I/O */

/*      VARIABLE  I/O  DESCRIPTION */
/*      --------  ---  -------------------------------------------------- */
/*      FILE       I   The name of a file to be examined. */
/*      ARCH       O   The architecture of the kernel file. */
/*      KERTYP     O   The type of the kernel file. */

/* $ Detailed_Input */

/*     FILE        is the name of a SPICE kernel file whose architecture */
/*                 and type are desired. */

/* $ Detailed_Output */

/*     ARCH        is the file architecture of the SPICE kernel file */
/*                 specified be FILE. If the architecture cannot be */
/*                 determined or is not recognized the value '?' is */
/*                 returned. */

/*                 Architectures currently recognized are: */

/*                    DAF - The file is based on the DAF architecture. */
/*                    DAS - The file is based on the DAS architecture. */
/*                    XFR - The file is in a SPICE transfer file format. */
/*                    DEC - The file is an old SPICE decimal text file. */
/*                    ASC -- An ASCII text file. */
/*                    KPL -- Kernel Pool File (i.e., a text kernel) */
/*                    TXT -- An ASCII text file. */
/*                    TE1 -- Text E-Kernel type 1. */
/*                     ?  - The architecture could not be determined. */

/*                 This variable must be at least 3 characters long. */

/*     KERTYP      is the type of the SPICE kernel file. If the type */
/*                 can not be determined the value '?' is returned. */

/*                 Kernel file types may be any sequence of at most four */
/*                 printing characters. NAIF has reserved for its use */
/*                 types which contain all upper case letters. */

/*                 A file type of 'PRE' means that the file is a */
/*                 pre-release file. */

/*                 This variable may be at most 4 characters long. */

/* $ Parameters */

/*     RECL        is the record length of a binary kernel file. Each */
/*                 record must be large enough to hold 128 double */
/*                 precision numbers. The units in which the record */
/*                 length must be specified vary from environment to */
/*                 environment. For example, VAX Fortran requires */
/*                 record lengths to be specified in longwords, */
/*                 where two longwords equal one double precision */
/*                 number. */

/* $ Exceptions */

/*      1) If the filename specified is blank, then the error */
/*         SPICE(BLANKFILENAME) is signaled. */

/*      2) If any inquire on the filename specified by FILE fails for */
/*         some reason, the error SPICE(INQUIREERROR) is signaled. */

/*      3) If the file specified by FILE does not exist, the error */
/*         SPICE(FILENOTFOUND) is signaled. */

/*      4) If the file specified by FILE is already open but not through */
/*         SPICE interfaces, the error SPICE(EXTERNALOPEN) is signaled. */

/*      5) If an attempt to open the file specified by FILE fails when */
/*         this routine requires that it succeed, the error */
/*         SPICE(FILEOPENFAILED) is signaled. */

/*      6) If an attempt to read the file specified by FILE fails when */
/*         this routine requires that it succeed, the error */
/*         SPICE(FILEREADFAILED) is signaled. */

/*      7) Routines in the call tree of this routine may trap and */
/*         signal errors. */

/*      8) If the ID word in a DAF based kernel is NAIF/DAF, then the */
/*         algorithm GETFAT uses to distinguish between CK and SPK */
/*         kernels may result in an indeterminate KERTYP if the SPK or */
/*         CK files have invalid first segments. */

/* $ Files */

/*     The SPICE kernel file specified by FILE is examined by this */
/*     routine to determine its architecture and type.  If the file */
/*     named by FILE is not connected to a logical unit or loaded */
/*     in the handle manager, this routine will OPEN and CLOSE it. */

/* $ Particulars */

/*     This subroutine is a support utility routine that determines the */
/*     architecture and type of a SPICE kernel file. */

/* $ Examples */

/*     Suppose you wish to write a single routine for loading binary */
/*     kernels. You can use this routine to determine the type of the */
/*     file and  then pass the file to the appropriate low level file */
/*     loader to handle the actual loading of the file. */

/*        CALL GETFAT ( FILE, ARCH, KERTYP ) */

/*        IF ( KERTYP .EQ. 'SPK' ) THEN */

/*           CALL SPKLEF ( FILE, HANDLE ) */

/*        ELSE IF ( KERTYP .EQ. 'CK' ) THEN */

/*           CALL CKLPF ( FILE, HANDLE ) */

/*        ELSE IF ( KERTYP .EQ. 'EK' ) THEN */

/*           CALL EKLEF ( FILE, HANDLE ) */

/*        ELSE */

/*           WRITE (*,*) 'The file could not be identified as a known' */
/*           WRITE (*,*) 'kernel type.  Did you load the wrong file' */
/*           WRITE (*,*) 'by mistake?' */

/*        END IF */


/* $ Restrictions */

/*     1) In order to properly determine the type of DAF based binary */
/*        kernels, the routine requires that their first segments and */
/*        the meta data necessary to address them are valid. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     K.R. Gehringer  (JPL) */
/*     H.A. Neilan     (JPL) */
/*     W.L. Taber      (JPL) */
/*     F.S. Turner     (JPL) */
/*     E.D. Wright     (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.2, 24-APR-2003 (EDW) */

/*        Added MAC-OSX-F77 to the list of platforms */
/*        that require READONLY to read write protected */
/*        kernels. */

/* -    SPICELIB Version 4.0.1, 17-JUL-2002 (BVS) */

/*        Added MAC-OSX environments. */

/* -    SPICELIB Version 4.0.0, 22-AUG-2001 (WLT) (FST) (EDW) */

/*        Added code so that the architecture and type of open binary */
/*        SPICE kernels can be determined. */

/*        Added exception for MACPPC_C (CodeWarrior Mac classic). */
/*        Reduced RECL value to 12 to prevent expression of */
/*        the fseek bug. */

/* -    SPICELIB Version 3.2.0, 06-DEC-1999 (WLT) */

/*        The heuristics for distinguishing between CK and SPK have */
/*        been enhanced so that the routine is no longer requires */
/*        that TICKS in C-kernels be positive or integral. */

/* -    SPICELIB Version 3.1.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 3.1.3, 22-SEP-1999 (NJB) */

/*        CSPICE environments were added.  Some typos were corrected. */

/* -    SPICELIB Version 3.1.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 3.1.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 3.1.0, 11-FEB-1999 (FST) */

/*        Added an integrality check to Test 3. If LASTDP is not */
/*        an integral value, then GETFAT simply returns KERTYP = '?', */
/*        since it is of an indeterminate type. */

/* -    SPICELIB Version 3.0.0, 07-APR-1998 (NJB) */

/*        Module was updated for the PC-LINUX platform. */

/* -     SPICELIB Version 2.0.0, 19-DEC-1995 (KRG) */

/*         Added several new features to the subroutine: */

/*         - Error handling has been enhanced. */
/*         - Several new file architectures have been added. */

/*         Removed the mention of 1000 characters as a candidate for the */
/*         record length of a file. */

/*         Added the exception for a blank filename to the header. The */
/*         error is signalled, but it was not listed in the header. */

/*         Added IOSTAT values to the appropriate error messages. */

/*         Non-printing characters are replaced with blanks in the ID */
/*         word when it is read. This deals with the case where a */
/*         platform allows a text file to be opened as an unformatted */
/*         file and the ID word does not completely fill 8 characters. */

/* -    SPICELIB Version 1.4.0, 5-JAN-1995 (HAN) */

/*        Removed ENV11 since it is now the same as ENV2. */
/*        Removed ENV10 since it is the same as the VAX environment. */

/* -    SPICELIB Version 1.3.0, 30-AUG-1994 (HAN) */

/*        Added two new environments, DEC Alpha/OpenVMS and */
/*        Sun/Solaris, to the source master file. */

/* -     SPICELIB Version 1.2.0, 25-MAR-1994 (HAN) */

/*         Added two new environments, DEC Alpha/OpenVMS and */
/*         Sun/Solaris, to the source master file. */

/* -     SPICELIB Version 1.1.0, 25-MAR-1994 (HAN) */

/*         Modified master source code file to use READONLY on platforms */
/*         that support it. Also, changed some local declaration comment */
/*         lines to match the standard NAIF template. */

/* -     SPICELIB Version 1.0.0, 24-JUL-1993 (WLT) (HAN) (KRG) */

/* -& */
/* $ Index_Entries */

/*     determine the architecture and type of a kernel file */

/* -& */
/* $ Revisions */

/* -    SPICELIB Version 4.0.0, 22-AUG-2001 (WLT) (FST) */

/*        Added code so that the architecture and type of open binary */
/*        SPICE kernels can be determined.  This uses the new DAF/DAS */
/*        handle manager as well as examination of handles of open DAS */
/*        files.  Currently the handle manager deals only with DAF */
/*        files. This routine should be updated again when the DAS */
/*        system is integrated with the handle manager. */

/*        Some slight changes were required to support ZZDDHFNH on */
/*        the VAX environment.  This resulted in the addition of */
/*        the logical USEFNH that is set to true in most */
/*        environments, and never used again other than to allow */
/*        the invocation of the ZZDDHFNH module. */

/* -     SPICELIB Version 2.0.0, 19-DEC-1995 (KRG) */

/*         Added several new features to the subroutine: */

/*         - Error handling has been enhanced. */
/*         - Several new file architectures have been added. */

/*         Removed the mention of 1000 characters as a candidate for the */
/*         record length of a file. It seems unlikely that we will */
/*         encounter an environment where 1000 characters of storage is */
/*         larger than the storage necessary for 128 double precision */
/*         numbers; typically there are 8 characters per double precision */
/*         number, yeilding 1024 characters. */

/*         Added the exception for a blank filename to the header. The */
/*         error is signalled, but it was not listed in the header. */

/*         Added IOSTAT values to the appropriate error messages. */

/*         Non-printing characters are replaced with blanks in the ID */
/*         word when it is read. This deals with the case where a */
/*         platform allows a text file to be opened as an unformatted */
/*         file and the ID word does not completely fill 8 characters. */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     Set the length of a SPICE kernel file ID word. */


/*     Set minimum and maximum values for the range of ASCII printing */
/*     characters. */


/*     Local Variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("GETFAT", (ftnlen)6);
    }

/*     Initialize the temporary storage variables that we use. */

    s_copy(idword, " ", (ftnlen)12, (ftnlen)1);

/*     If the filename we have is blank, signal an error and return. */

    if (s_cmp(file, " ", file_len, (ftnlen)1) == 0) {
	setmsg_("The file name is blank.", (ftnlen)23);
	sigerr_("SPICE(BLANKFILENAME)", (ftnlen)20);
	chkout_("GETFAT", (ftnlen)6);
	return 0;
    }

/*     See if this is a binary file that is currently open */
/*     within the SPICE binary file management subsystem.  At */
/*     the moment, as far as we know, the file is not opened. */

    opened = FALSE_;
    zzddhfnh_(file, &handle, &found, file_len);
    if (found) {

/*        If the file was recognized, we need to get the unit number */
/*        associated with it. */

	zzddhnfo_(&handle, fname, &intarc, &intbff, &intamn, &found, (ftnlen)
		255);

/*        Translate the architecture ID to a string and retrieve the */
/*        logical unit to use with this file. */

	zzddhgsd_("ARCH", &intarc, filarc, (ftnlen)4, (ftnlen)32);
	zzddhhlu_(&handle, filarc, &c_false, &number, (ftnlen)32);
	opened = TRUE_;
    } else {

/*        We'll do a bit of inquiring before we try opening anything. */

	ioin__1.inerr = 1;
	ioin__1.infilen = file_len;
	ioin__1.infile = file;
	ioin__1.inex = &exist;
	ioin__1.inopen = &opened;
	ioin__1.innum = 0;
	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);

/*        Not too likely, but if the INQUIRE statement fails... */

	if (iostat != 0) {
	    setmsg_("IOSTAT error in INQUIRE statement. IOSTAT = #.", (ftnlen)
		    46);
	    errint_("#", &iostat, (ftnlen)1);
	    sigerr_("SPICE(INQUIREERROR)", (ftnlen)19);
	    chkout_("GETFAT", (ftnlen)6);
	    return 0;
	}

/*        Note: the following two tests MUST be performed in the order */
/*        in which they appear, since in some environments files that do */
/*        not exist are considered to be open. */

	if (! exist) {
	    setmsg_("The kernel file '#' does not exist.", (ftnlen)35);
	    errch_("#", file, (ftnlen)1, file_len);
	    sigerr_("SPICE(FILENOTFOUND)", (ftnlen)19);
	    chkout_("GETFAT", (ftnlen)6);
	    return 0;
	}

/*        If the file is already open, it may be a DAS file. */

	if (opened) {

/*           At the moment, the handle manager doesn't manage DAS */
/*           handles.  As a result we need to treat the case of an open */
/*           DAS separately. When the Handle Manager is hooked in with */
/*           DAS as well as DAF, we should remove the block below. */

/*           =================================================== */
/*           DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS */
/*           vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv */

/*           This file may or may not be a DAS file.  Until we */
/*           have determined otherwise, we assume it is not */
/*           a DAS file. */

	    notdas = TRUE_;
	    ioin__1.inerr = 1;
	    ioin__1.infilen = file_len;
	    ioin__1.infile = file;
	    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) {
		setmsg_("IOSTAT error in INQUIRE statement. IOSTAT = #.", (
			ftnlen)46);
		errint_("#", &iostat, (ftnlen)1);
		sigerr_("SPICE(INQUIREERROR)", (ftnlen)19);
		chkout_("GETFAT", (ftnlen)6);
		return 0;
	    }

/*           Get the set of handles of open DAS files.  We will */
/*           translate each of these handles to the associated */
/*           logical unit.  If the tranlation matches the result */
/*           of the inquire, this must be a DAS file and we */
/*           can proceed to determine the type. */

	    ssizei_(&c__100, handles);
	    dashof_(handles);
	    which = cardi_(handles);
	    while(which > 0) {
		dashlu_(&handles[(i__1 = which + 5) < 106 && 0 <= i__1 ? i__1 
			: s_rnge("handles", i__1, "getfat_", (ftnlen)654)], &
			myunit);
		if (unit == myunit) {
		    number = myunit;
		    which = 0;
		    notdas = FALSE_;
		} else {
		    --which;
		}
	    }

/*           If we reach this point and do not have a DAS, there */
/*           is no point in going on.  The user has opened this */
/*           file outside the SPICE system.  We shall not attempt */
/*           to determine its type. */

	    if (notdas) {
		setmsg_("The file '#' is already open.", (ftnlen)29);
		errch_("#", file, (ftnlen)1, file_len);
		sigerr_("SPICE(EXTERNALOPEN)", (ftnlen)19);
		chkout_("GETFAT", (ftnlen)6);
		return 0;
	    }
/*           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ */
/*           DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS */
/*           =================================================== */

	}
    }

/*     Open the file with a record length of RECL (the length of the */
/*     DAF and DAS records). We assume, for now, that opening the file as */
/*     a direct access file will work. */

    diropn = TRUE_;

/*     If the file is not already open (probably the case that */
/*     happens most frequently) we try opening it for direct access */
/*     and see if we can locate the idword. */

    if (! opened) {
	getlun_(&number);
	o__1.oerr = 1;
	o__1.ounit = number;
	o__1.ofnmlen = file_len;
	o__1.ofnm = file;
	o__1.orl = 1024;
	o__1.osta = "OLD";
	o__1.oacc = "DIRECT";
	o__1.ofm = 0;
	o__1.oblnk = 0;
	iostat = f_open(&o__1);

/*     If we had trouble opening the file, try opening it as a */
/*     sequential file. */

	if (iostat != 0) {
	    diropn = FALSE_;
	    o__1.oerr = 1;
	    o__1.ounit = number;
	    o__1.ofnmlen = file_len;
	    o__1.ofnm = file;
	    o__1.orl = 0;
	    o__1.osta = "OLD";
	    o__1.oacc = "SEQUENTIAL";
	    o__1.ofm = 0;
	    o__1.oblnk = 0;
	    iostat = f_open(&o__1);

/*        If we still have problems opening the file, we don't have a */
/*        clue about the file architecture and type. */

	    if (iostat != 0) {
		s_copy(arch, "?", arch_len, (ftnlen)1);
		s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
		setmsg_("Attempt to open the file '#' failed. IOSTAT = #.", (
			ftnlen)48);
		errch_("#", file, (ftnlen)1, file_len);
		errint_("#", &iostat, (ftnlen)1);
		sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21);
		chkout_("GETFAT", (ftnlen)6);
		return 0;
	    }
	}
    }

/*     We opened the file successfully, so let's try to read from the */
/*     file. We need to be sure to use the correct form of the read */
/*     statement, depending on whether the file was opened with direct */
/*     acces or sequential access. */

    if (diropn) {
	io___19.ciunit = number;
	iostat = s_rdue(&io___19);
	if (iostat != 0) {
	    goto L100001;
	}
	iostat = do_uio(&c__1, tmpwrd, (ftnlen)12);
	if (iostat != 0) {
	    goto L100001;
	}
	iostat = e_rdue();
L100001:

/*        If we couldn't read from the file as a direct access file with */
/*        a fixed record length, then try to open the file as a */
/*        sequential file and read from it. */

	if (iostat != 0) {
	    if (opened) {

/*              Something has gone wrong here.  The file was opened */
/*              as either a DAF or DAS prior to the call to GETFAT. */
/*              We retrieved the unit number maintained by the */
/*              underlying binary file management system, but we */
/*              were unable to read the file as direct access. */
/*              There's nothing we can do but abandon our quest to */
/*              determine the type of the file. */

		setmsg_("The file '#' is opened as a binary SPICE kernel.  B"
			"ut it cannot be read using a direct access read. The"
			" value of IOSTAT returned by the attempted READ is #"
			". ", (ftnlen)157);
		errch_("#", file, (ftnlen)1, file_len);
		errint_("#", &iostat, (ftnlen)1);
		sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
		chkout_("GETFAT", (ftnlen)6);
		return 0;
	    }

/*           If we reach this point, the file was opened locally */
/*           as a direct access file.  We could not read it that */
/*           way, so we'll try using a sequential read.   However, */
/*           we first need to close the file and then reopen it */
/*           for sequential reading. */

	    cl__1.cerr = 0;
	    cl__1.cunit = number;
	    cl__1.csta = 0;
	    f_clos(&cl__1);
	    o__1.oerr = 1;
	    o__1.ounit = number;
	    o__1.ofnmlen = file_len;
	    o__1.ofnm = file;
	    o__1.orl = 0;
	    o__1.osta = "OLD";
	    o__1.oacc = "SEQUENTIAL";
	    o__1.ofm = 0;
	    o__1.oblnk = 0;
	    iostat = f_open(&o__1);

/*           If we could not open the file, we don't have a clue about */
/*           the file architecture and type. */

	    if (iostat != 0) {
		s_copy(arch, "?", arch_len, (ftnlen)1);
		s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
		setmsg_("Attempt to open the file '#' failed. IOSTAT = #.", (
			ftnlen)48);
		errch_("#", file, (ftnlen)1, file_len);
		errint_("#", &iostat, (ftnlen)1);
		sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21);
		chkout_("GETFAT", (ftnlen)6);
		return 0;
	    }

/*           Try to read from the file. */

	    ci__1.cierr = 1;
	    ci__1.ciend = 1;
	    ci__1.ciunit = number;
	    ci__1.cifmt = "(A)";
	    iostat = s_rsfe(&ci__1);
	    if (iostat != 0) {
		goto L100002;
	    }
	    iostat = do_fio(&c__1, tmpwrd, (ftnlen)12);
	    if (iostat != 0) {
		goto L100002;
	    }
	    iostat = e_rsfe();
L100002:
	    ;
	}
    } else {
	ci__1.cierr = 1;
	ci__1.ciend = 1;
	ci__1.ciunit = number;
	ci__1.cifmt = "(A)";
	iostat = s_rsfe(&ci__1);
	if (iostat != 0) {
	    goto L100003;
	}
	iostat = do_fio(&c__1, tmpwrd, (ftnlen)12);
	if (iostat != 0) {
	    goto L100003;
	}
	iostat = e_rsfe();
L100003:
	;
    }

/*     If we had an error while reading, we don't recognize this file. */

    if (iostat != 0) {
	s_copy(arch, "?", arch_len, (ftnlen)1);
	s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
	cl__1.cerr = 0;
	cl__1.cunit = number;
	cl__1.csta = 0;
	f_clos(&cl__1);
	setmsg_("Attempt to read from file '#' failed. IOSTAT = #.", (ftnlen)
		49);
	errch_("#", file, (ftnlen)1, file_len);
	errint_("#", &iostat, (ftnlen)1);
	sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
	chkout_("GETFAT", (ftnlen)6);
	return 0;
    }

/*     Close the file (if we opened it here), as we do not need it */
/*     to be open any more. */

    if (! opened) {
	cl__1.cerr = 0;
	cl__1.cunit = number;
	cl__1.csta = 0;
	f_clos(&cl__1);
    }

/*     At this point, we have a candidate for an ID word. To avoid */
/*     difficulties with Fortran I/O and other things, we will now */
/*     replace any non printing ASCII characters with blanks. */

    for (i__ = 1; i__ <= 12; ++i__) {
	if (*(unsigned char *)&tmpwrd[i__ - 1] < 32 || *(unsigned char *)&
		tmpwrd[i__ - 1] > 126) {
	    *(unsigned char *)&tmpwrd[i__ - 1] = ' ';
	}
    }

/*     Identify the architecture and type, if we can. */

    ljust_(tmpwrd, tmpwrd, (ftnlen)12, (ftnlen)12);
    ucase_(tmpwrd, tmpwrd, (ftnlen)12, (ftnlen)12);
    nextwd_(tmpwrd, idword, tmpwrd, (ftnlen)12, (ftnlen)12, (ftnlen)12);
    if (s_cmp(idword, "DAFETF", (ftnlen)12, (ftnlen)6) == 0) {

/*        We have a DAF encoded transfer file. */

	s_copy(arch, "XFR", arch_len, (ftnlen)3);
	s_copy(kertyp, "DAF", kertyp_len, (ftnlen)3);
    } else if (s_cmp(idword, "DASETF", (ftnlen)12, (ftnlen)6) == 0) {

/*        We have a DAS encoded transfer file. */

	s_copy(arch, "XFR", arch_len, (ftnlen)3);
	s_copy(kertyp, "DAS", kertyp_len, (ftnlen)3);
    } else if (s_cmp(idword, "'NAIF/DAF'", (ftnlen)10, (ftnlen)10) == 0) {

/*        We have an old DAF decimal text file. */

	s_copy(arch, "DEC", arch_len, (ftnlen)3);
	s_copy(kertyp, "DAF", kertyp_len, (ftnlen)3);
    } else if (s_cmp(idword, "NAIF/DAS", (ftnlen)8, (ftnlen)8) == 0) {

/*        We have a pre release DAS binary file. */

	s_copy(arch, "DAS", arch_len, (ftnlen)3);
	s_copy(kertyp, "PRE", kertyp_len, (ftnlen)3);
    } else {

/*        Get the architecture and type from the ID word, if we can. */

	idw2at_(idword, arch, kertyp, (ftnlen)8, arch_len, kertyp_len);
    }

/*     If the architecture is DAF and the type is unknown, '?', then we */
/*     have either an SPK file, a CK file, or something we don't */
/*     understand. Let's check it out. */

    if (s_cmp(arch, "DAF", arch_len, (ftnlen)3) == 0 && s_cmp(kertyp, "?", 
	    kertyp_len, (ftnlen)1) == 0) {

/*        We have a DAF file and we do not know what the type is. This */
/*        situation can occur for older SPK and CK files, before the ID */
/*        word was used to store type information. */

/*        We use Bill's (WLT'S) magic heuristics to determine the type */
/*        of the file. */

/*        Open the file and pass the handle to the private routine */
/*        that deals with the dirty work. */

	dafopr_(file, &handle, file_len);
	zzckspk_(&handle, kertyp, kertyp_len);
	dafcls_(&handle);
    }
    chkout_("GETFAT", (ftnlen)6);
    return 0;
} /* getfat_ */
コード例 #4
0
ファイル: chunk.c プロジェクト: Rileybrains/NASA_Intern_SPICE
/* Subroutine */ int chunk_(char *buffer, integer *first, integer *last, 
	ftnlen buffer_len)
{
    /* Initialized data */

    static char terms[32*24] = "|endliteral                     " "!endliter"
	    "al                     " "@chapter                        " "@se"
	    "ction                        " "@setvarsize                     " 
	    "@var                            " "@setparamsize               "
	    "    " "@param                          " "@literal              "
	    "          " "@literalitem                    " "@literalparam   "
	    "                " "@literalvar                     " "@exliteral"
	    "                      " "@exliteralitem                  " "@exl"
	    "iteralparam                 " "@exliteralvar                   " 
	    "@newlist                        " "@newpage                    "
	    "    " "@numitem                        " "@paritem              "
	    "          " "@symitem                        " "@moreparam      "
	    "                " "@morevar                        " "          "
	    "                      ";

    /* System generated locals */
    integer i__1, i__2;

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

    /* Local variables */
    char cseq[32];
    extern integer cpos_(char *, char *, integer *, ftnlen, ftnlen);
    integer term, i__, j;
    extern integer cardc_(char *, ftnlen);
    integer begin;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    integer index;
    extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
    integer nterm;
    extern integer ltrim_(char *, ftnlen);
    integer endbuf;
    extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen), 
	    touchi_(integer *);
    extern /* Subroutine */ int chkout_(char *, ftnlen);
    extern logical return_(void);
    integer end;


/*     Find the next `chunk' of a FORTeX source buffer. The chunk begins */
/*     sometime after BUFFER(FIRST), and ends at BUFFER(LAST). */


/* $ Revisions */

/* -    Faketex version 1.3.0 5-DEC-1995  WLT */

/*        Set I = TOUCHI( I ) in the IF ( RETURN() ) block so that buggy */
/*        compilers won't complain that it isn't used. */

/* -    Faketex version 1.2.0 17-NOV-1995 NJB */

/*        Data statement for TERMS broken up into multiple statements */
/*        to avoid violation of continuation limit on Sun. */

/* -    Faketex version 1.1.0 16-MAY-1994 NJB */

/*        Substring bounds on line 106 safeguarded to stay in range. */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Standard SPICE error handling */

    if (return_()) {
	i__ = 0;
	i__ = touchi_(&i__);
	return 0;
    } else {
	chkin_("CHUNK", (ftnlen)5);
    }

/*     Because we can safely assume that the first line of the chunk */
/*     is not inside a literal section, we can skip blank lines and */
/*     @newpage directives with impunity to find the beginning of the */
/*     chunk. */

    endbuf = cardc_(buffer, buffer_len);
    j = ltrim_(buffer + (*first + 5) * buffer_len, buffer_len);
    while(*first < endbuf && (s_cmp(buffer + (*first + 5) * buffer_len, " ", 
	    buffer_len, (ftnlen)1) == 0 || s_cmp(buffer + ((*first + 5) * 
	    buffer_len + (j - 1)), "@newpage", buffer_len - (j - 1), (ftnlen)
	    8) == 0)) {
	++(*first);
    }
    *last = *first;

/*     A literal chunk may be terminated only by an explicit end marker */
/*     (|endliteral or !endliteral) or the end of the buffer. A normal */
/*     chunk is terminated by the beginning of another chunk, a */
/*     blank line, or a @newpage. */

/* Computing MAX */
    i__1 = 1, i__2 = ncpos_(buffer + (*first + 5) * buffer_len, "  ", &c__1, 
	    buffer_len, (ftnlen)2);
    begin = max(i__1,i__2);
/* Computing MAX */
    i__1 = begin, i__2 = cpos_(buffer + (*first + 5) * buffer_len, " {", &
	    begin, buffer_len, (ftnlen)2) - 1;
    end = max(i__1,i__2);
    s_copy(cseq, buffer + ((*first + 5) * buffer_len + (begin - 1)), (ftnlen)
	    32, end - (begin - 1));
    if (s_cmp(cseq, "@literal", (ftnlen)8, (ftnlen)8) == 0) {
	term = 1;
	nterm = 1;
    } else if (s_cmp(cseq, "@exliteral", (ftnlen)10, (ftnlen)10) == 0) {
	term = 2;
	nterm = 1;
    } else {
	term = 3;
	nterm = 22;
    }

/*     Check subsequent lines until the proper terminator or the end */
/*     of the buffer is reached. */

    index = 0;
    while(index == 0 && *last < endbuf) {
	++(*last);
	if (s_cmp(buffer + (*last + 5) * buffer_len, " ", buffer_len, (ftnlen)
		1) == 0) {
	    s_copy(cseq, " ", (ftnlen)32, (ftnlen)1);
	} else {
	    begin = ncpos_(buffer + (*last + 5) * buffer_len, "  ", &c__1, 
		    buffer_len, (ftnlen)2);
/* Computing MAX */
	    i__1 = begin, i__2 = cpos_(buffer + (*last + 5) * buffer_len, 
		    " {", &begin, buffer_len, (ftnlen)2) - 1;
	    end = max(i__1,i__2);
	    s_copy(cseq, buffer + ((*last + 5) * buffer_len + (begin - 1)), (
		    ftnlen)32, end - (begin - 1));
	}
	index = isrchc_(cseq, &nterm, terms + (((i__1 = term - 1) < 24 && 0 <=
		 i__1 ? i__1 : s_rnge("terms", i__1, "chunk_", (ftnlen)193)) 
		<< 5), (ftnlen)32, (ftnlen)32);
    }

/*     Only a literal section retains the line that terminates it. */

    if (term > 2 && *last != endbuf) {
	--(*last);
    }
    chkout_("CHUNK", (ftnlen)5);
    return 0;
} /* chunk_ */
コード例 #5
0
ファイル: zzbodker.c プロジェクト: Dbelsa/coft
/* $Procedure ZZBODKER ( Private --- Process Body-Name Kernel Pool Maps ) */
/* Subroutine */ int zzbodker_(char *names, char *nornam, integer *codes, 
	integer *nvals, logical *extker, integer *bnmlst, integer *bnmpol, 
	char *bnmnms, integer *bnmidx, integer *bidlst, integer *bidpol, 
	integer *bidids, integer *bididx, ftnlen names_len, ftnlen nornam_len,
	 ftnlen bnmnms_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;

    /* Builtin functions */
    integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *, 
	    ftnlen, ftnlen);

    /* Local variables */
    char type__[1*2];
    integer nsiz[2];
    extern /* Subroutine */ int zzbodini_(char *, char *, integer *, integer *
	    , integer *, integer *, integer *, char *, integer *, integer *, 
	    integer *, integer *, integer *, ftnlen, ftnlen, ftnlen);
    integer i__;
    extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
	     ftnlen, ftnlen);
    logical found;
    extern logical failed_(void);
    logical plfind[2];
    extern /* Subroutine */ int gcpool_(char *, integer *, integer *, integer 
	    *, char *, logical *, ftnlen, ftnlen), gipool_(char *, integer *, 
	    integer *, integer *, integer *, logical *, ftnlen), chkout_(char 
	    *, ftnlen), sigerr_(char *, ftnlen), dtpool_(char *, logical *, 
	    integer *, char *, ftnlen, ftnlen), setmsg_(char *, ftnlen), 
	    errint_(char *, integer *, ftnlen), ljucrs_(integer *, char *, 
	    char *, 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 lists and hashes 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. */

/* $ Parameters */

/*     MAXL        is the maximum length of a body name. */

/*     MAXP        is the maximum number of additional names that may */
/*                 be added via the ZZBODDEF interface. */

/*     NPERM       is the count of the mapping assignments built into */
/*                 SPICE. */

/*     MAXE        is the size of the lists and hashes storing combined */
/*                 built-in and ZZBODDEF-defined name/ID mappings. To */
/*                 ensure efficient hashing this size is the set to the */
/*                 first prime number greater than ( MAXP + NPERM ). */

/*     NROOM       is the size of the lists and hashes storing the */
/*                 POOL-defined name/ID mappings. To ensure efficient */
/*                 hashing and to provide the ability to store nearly as */
/*                 many names as can fit in the POOL, this size is */
/*                 set to the first prime number less than MAXLIN */
/*                 defined in the POOL umbrella routine. */

/* $ Required_Reading */

/*     naif_ids.req */

/* $ Keywords */

/*     BODY */
/*     CONVERSION */

/* $ Author_and_Institution */

/*     B.V. Semenov (JPL) */
/*     E.D. Wright  (JPL) */

/* $ Version */

/* -    SPICELIB Version 2.0.0, 07-MAY-2014 (BVS)(EDW) */

/*        Increased NROOM to 14983. Added a comment note explaining */
/*        NROOM and MAXE */

/* -    SPICELIB Version 1.0.0, 20-MAY-2010 (EDW) */

/*        N0064 version with MAXP = 150, NPERM = 563, */
/*        MAXE = MAXP + NPERM, and NROOM = 2000. */

/*     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 */


/*     Maximum number of additional names that may be added via the */
/*     ZZBODDEF interface. */


/*     Count of default SPICE mapping assignments. */


/*     Size of the lists and hashes storing the built-in and */
/*     ZZBODDEF-defined name/ID mappings. To ensure efficient hashing */
/*     this size is the set to the first prime number greater than */
/*     ( MAXP + NPERM ). */


/*     Size of the lists and hashes storing the POOL-defined name/ID */
/*     mappings. To ensure efficient hashing and to provide the ability */
/*     to store nearly as many names as can fit in the POOL, this size */
/*     is set to the first prime number less than MAXLIN defined in */
/*     the POOL umbrella routine. */

/* $ 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, and CODES arrays. */
/*     EXTKER     O   Logical indicating presence of kernel pool names. */
/*     BNMLST     O   Body name-based hash head node pointer list */
/*     BNMPOL     O   Body name-based hash node collision list */
/*     BNMNMS     O   Body name-based hash item list */
/*     BNMIDX     O   Body name-based hash index storage array */
/*     BIDLST     O   Body ID-based hash head node pointer list */
/*     BIDPOL     O   Body ID-based hash node collision list */
/*     BIDIDS     O   Body ID-based hash item list */
/*     BIDIDX     O   Body ID-based hash index storage array */
/*     LBPOOL     P   Lower bound of hash pool arrays */
/*     MAXL       P   Maximum length of body name strings. */
/*     NROOM      P   Maximum length of kernel pool data vectors. */

/* $ Detailed_Input */

/*     None. */

/* $ Detailed_Output */

/*     NAMES     is the array of names extracted from the kernel pool */
/*               vector NAIF_BODY_NAME. This array is parallel to */
/*               NORNAM and CODES. */

/*     NORNAM    the array of 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 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, and */
/*               CODES. */

/*     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. */

/*     BNMLST */
/*     BNMPOL */
/*     BNMNMS    are the body name-based hash head node pointer, node */
/*               collision, and item lists. Together they return the */
/*               index of the element in the BNMIDX index storage array */
/*               that stores the index of the body items in the NAMES, */
/*               NORNAM, and CODES arrays. */

/*     BNMIDX    is the body name-based hash index storage array */
/*               containing at the index determined by the hash for a */
/*               given normalized name the index corresponding to this */
/*               name in the NAMES, NORNAM, and CODES arrays. */

/*     BIDLST */
/*     BIDPOL */
/*     BIDIDS    are the body ID-based hash head node pointer, node */
/*               collision, and item lists. Together they return the */
/*               index of the element in the BNMIDX index storage array */
/*               that stores the index of the body items in the */
/*               NAMES, NORNAM, and CODES arrays. */

/*     BIDIDX    is the body ID-based hash index storage array */
/*               containing at the index determined by the hash for a */
/*               given ID the index corresponding to this ID in the */
/*               NAMES, NORNAM, and CODES arrays. */

/* $ Parameters */

/*     LBPOOL    is the lower bound of the hashes' collision list array. */

/*     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. */

/* $ 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. */

/* $ Files */

/*     None. */

/* $ 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 name/code lists and hashes that ZZBODTRN requires to */
/*     resolve code to name and name to code mappings. */

/*     The NAMES and CODES arrays stored all values provided in the */
/*     corresponding POOL variables. No attempt to remove duplicates, */
/*     change order, or do any other alterations to these arrays is made */
/*     by this routine. */

/*     The order of mapping in the NAMES, NORNAM, and CODES arrays */
/*     determines the priority, with the mapping with the lowest */
/*     priority being first and the mapping with the highest priority */
/*     being last. */

/*     If more than one entry with a particular normalized name is */
/*     present in the NORNAM array, only the latest entry is registered */
/*     in the name-based hash. */

/*     If more than one entry with a particular ID is present in the */
/*     CODES array, only the latest entry that maps to a not-yet */
/*     registered normalized name is registered in the ID-based hash. */
/*     Registering IDs only for not-yet registered names achieves masking */
/*     all IDs with the lower priority in cases when a single normalized */
/*     name maps to more than one ID. */

/* $ Examples */

/*     None. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     B.V. Semenov   (JPL) */
/*     F.S. Turner    (JPL) */
/*     E.D. Wright    (JPL) */

/* $ Version */

/* -    SPICELIB Version 2.0.0, 16-SEP-2013 (BVS) */

/*        Changed routine's calling sequence by dropping name and ID */
/*        order vectors and adding name- and ID-based hashes and */
/*        modified it to initialize hashes instead of the order arrays. */

/* -    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__14983, num, names, plfind, (ftnlen)32, (ftnlen)36)
	    ;
    gipool_(nbc, &c__1, &c__14983, &num[1], codes, &plfind[1], (ftnlen)32);
    if (failed_()) {
	chkout_("ZZBODKER", (ftnlen)8);
	return 0;
    }

/*     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 (failed_()) {
	chkout_("ZZBODKER", (ftnlen)8);
	return 0;
    }
    if (nsiz[0] > 14983 || nsiz[1] > 14983) {
	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__14983, (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 upper-cases 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) < 14983 && 0 <= i__2 ? i__2 : 
		s_rnge("names", i__2, "zzbodker_", (ftnlen)403)) * 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. */

	ljucrs_(&c__1, names + ((i__2 = i__ - 1) < 14983 && 0 <= i__2 ? i__2 :
		 s_rnge("names", i__2, "zzbodker_", (ftnlen)419)) * 36, 
		nornam + ((i__3 = i__ - 1) < 14983 && 0 <= i__3 ? i__3 : 
		s_rnge("nornam", i__3, "zzbodker_", (ftnlen)419)) * 36, (
		ftnlen)36, (ftnlen)36);
    }

/*     Populate hashes required by ZZBODTRN. */

    zzbodini_(names, nornam, codes, nvals, &c__14983, bnmlst, bnmpol, bnmnms, 
	    bnmidx, bidlst, bidpol, bidids, bididx, (ftnlen)36, (ftnlen)36, (
	    ftnlen)36);
    if (failed_()) {
	chkout_("ZZBODKER", (ftnlen)8);
	return 0;
    }

/*     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_ */
コード例 #6
0
ファイル: scdecd.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure      SCDECD ( Decode spacecraft clock ) */
/* Subroutine */ int scdecd_(integer *sc, doublereal *sclkdp, char *sclkch, 
	ftnlen sclkch_len)
{
    /* System generated locals */
    integer i__1, i__2, i__3, i__4, i__5;
    doublereal d__1;

    /* Builtin functions */
    double d_nint(doublereal *);
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    integer s_rnge(char *, integer, char *, integer), i_len(char *, ftnlen);

    /* Local variables */
    integer part, i__;
    extern /* Subroutine */ int chkin_(char *, ftnlen), errdp_(char *, 
	    doublereal *, ftnlen);
    doublereal ticks;
    extern /* Subroutine */ int scfmt_(integer *, doublereal *, char *, 
	    ftnlen);
    doublereal pstop[9999];
    extern logical failed_(void);
    extern integer lastnb_(char *, ftnlen);
    integer prelen;
    extern integer lstled_(doublereal *, integer *, doublereal *);
    extern /* Subroutine */ int sigerr_(char *, ftnlen);
    integer suflen;
    extern /* Subroutine */ int scpart_(integer *, integer *, doublereal *, 
	    doublereal *), chkout_(char *, ftnlen), prefix_(char *, integer *,
	     char *, ftnlen, ftnlen), setmsg_(char *, ftnlen), errint_(char *,
	     integer *, ftnlen), suffix_(char *, integer *, char *, ftnlen, 
	    ftnlen);
    integer nparts;
    doublereal pstart[9999];
    extern logical return_(void);
    extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
    doublereal ptotls[9999];
    char prtstr[5];

/* $ Abstract */

/*     Convert double precision encoding of spacecraft clock time into */
/*     a character representation. */

/* $ 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 */

/*     SCLK */

/* $ Keywords */

/*     CONVERSION */
/*     TIME */

/* $ Declarations */
/* $ Abstract */

/*     Include file sclk.inc */

/*     SPICE private file intended solely for the support of SPICE */
/*     routines.  Users should not include this file directly due */
/*     to the volatile nature of this file */

/*     The parameters below define sizes and limits used by */
/*     the SCLK system. */

/* $ 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. */

/* $ Parameters */

/*     See the declaration section below. */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 2.0.0, 24-MAY-2010 (NJB) */

/*        Increased value of maximum coefficient record count */
/*        parameter MXCOEF from 10K to 50K. */

/* -    SPICELIB Version 1.0.0, 11-FEB-2008 (NJB) */

/* -& */

/*     Number of supported SCLK field delimiters: */


/*     Supported SCLK string field delimiters: */


/*     Maximum number of partitions: */


/*     Partition string length. */

/*     Since the maximum number of partitions is given by MXPART is */
/*     9999, PRTSTR needs at most 4 characters for the partition number */
/*     and one character for the slash. */


/*     Maximum number of coefficient records: */


/*     Maximum number of fields in an SCLK string: */


/*     Length of strings used to represent D.P. */
/*     numbers: */


/*     Maximum number of supported parallel time systems: */


/*     End of include file sclk.inc */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     SC         I   NAIF spacecraft identification code. */
/*     SCLKDP     I   Encoded representation of a spacecraft clock count. */
/*     SCLKCH     O   Character representation of a clock count. */
/*     MXPART     P   Maximum number of spacecraft clock partitions. */

/* $ Detailed_Input */

/*     SC         is the NAIF integer code of the spacecraft whose */
/*                clock's time is being decoded. */

/*     SCLKDP     is the double precision encoding of a clock time in */
/*                units of ticks since the spacecraft clock start time. */
/*                This value does reflect partition information. */

/*                An analogy may be drawn between a spacecraft clock */
/*                and a standard wall clock. The number of ticks */
/*                corresponding to the wall clock string */

/*                                hh:mm:ss */

/*                would be the number of seconds represented by that */
/*                time. */

/*                For example: */

/*                      Clock string      Number of ticks */
/*                      ------------      --------------- */
/*                        00:00:10              10 */
/*                        00:01:00              60 */
/*                        00:10:00             600 */
/*                        01:00:00            3600 */

/*                If SCLKDP contains a fractional part the result */
/*                is the same as if SCLKDP had been rounded to the */
/*                nearest whole number. */

/* $ Detailed_Output */

/*     SCLKCH     is the character representation of the clock count. */
/*                The exact form that SCLKCH takes depends on the */
/*                spacecraft. */

/*                Nevertheless, SCLKCH will have the following general */
/*                format: */

/*                             'pp/sclk_string' */

/*                'pp' is an integer greater than or equal to one and */
/*                represents a "partition number". */

/*                Each mission is divided into some number of partitions. */
/*                A new partition starts when the spacecraft clock */
/*                resets, either to zero, or to some other */
/*                value. Thus, the first partition for any mission */
/*                starts with launch, and ends with the first clock */
/*                reset. The second partition starts immediately when */
/*                the first stopped, and so on. */

/*                In order to be completely unambiguous about a */
/*                particular time, you need to specify a partition number */
/*                along with the standard clock string. */

/*                Information about when partitions occur for different */
/*                missions is contained in a spacecraft clock kernel */
/*                file which needs to be loaded into the kernel pool */
/*                before calling SCDECD. */

/*                The routine SCPART may be used to read the partition */
/*                start and stop times, in encoded units of ticks, from */
/*                the kernel file. */

/*                Since the end time of one partition is coincident with */
/*                the begin time of the next, two different time strings */
/*                with different partition numbers can encode into the */
/*                same value. */

/*                For example, if partition 1 ends at time t1, and */
/*                partition 2 starts at time t2, then */

/*                               '1/t1' and '2/t2' */

/*                will be encoded into the same value, say X. SCDECD */
/*                always decodes such values into the latter of the */
/*                two partitions. In this example, */

/*                          CALL SCDECD ( X, SC, CLKSTR ) */

/*                will result in */

/*                          CLKSTR = '2/t2'. */



/*                'sclk_string' is a spacecraft specific clock string, */
/*                typically consisting of a number of components */
/*                separated by delimiters. */

/*                Using Galileo as an example, the full format is */

/*                               wwwwwwww:xx:y:z */

/*                where z is a mod-8 counter (values 0-7) which */
/*                increments approximately once every 8 1/3 ms., y is a */
/*                mod-10 counter (values 0-9) which increments once */
/*                every time z turns over, i.e., approximately once every */
/*                66 2/3 ms., xx is a mod-91 (values 0-90) counter */
/*                which increments once every time y turns over, i.e., */
/*                once every 2/3 seconds. wwwwwwww is the Real-Time Image */
/*                Count (RIM), which increments once every time xx turns */
/*                over, i.e., once every 60 2/3 seconds. The roll-over */
/*                expression for the RIM is 16777215, which corresponds */
/*                to approximately 32 years. */

/*                wwwwwwww, xx, y, and z are referred to interchangeably */
/*                as the fields or components of the spacecraft clock. */
/*                SCLK components may be separated by any of these five */
/*                characters: ' '  ':'  ','  '-'  '.' */
/*                The delimiter used is determined by a kernel pool */
/*                variable and can be adjusted by the user. */

/*                Some spacecraft clock components have offset, or */
/*                starting, values different from zero.  For example, */
/*                with an offset value of 1, a mod 20 counter would */
/*                cycle from 1 to 20 instead of from 0 to 19. */

/*                See the SCLK required reading for a detailed */
/*                description of the Voyager and Mars Observer clock */
/*                formats. */


/* $ Parameters */

/*     MXPART     is the maximum number of spacecraft clock partitions */
/*                expected in the kernel file for any one spacecraft. */
/*                See the INCLUDE file sclk.inc for this parameter's */
/*                value. */

/* $ Exceptions */

/*     1) If kernel variables required by this routine are unavailable, */
/*        the error will be diagnosed by routines called by this routine. */
/*        SCLKCH will be returned as a blank string in this case. */

/*     2) If the number of partitions in the kernel file for spacecraft */
/*        SC exceeds the parameter MXPART, the error */
/*        'SPICE(TOOMANYPARTS)' is signaled.  SCLKCH will be returned */
/*        as a blank string in this case. */

/*     3) If the encoded value does not fall in the boundaries of the */
/*        mission, the error 'SPICE(VALUEOUTOFRANGE)' is signaled. */
/*        SCLKCH will be returned as a blank string in this case. */

/*     4) If the declared length of SCLKCH is not large enough to */
/*        contain the output clock string the error */
/*        'SPICE(SCLKTRUNCATED)' is signaled either by this routine */
/*        or by a routine called by this routine.  On output SCLKCH */
/*        will contain a portion of the truncated clock string. */

/* $ Files */

/*     A kernel file containing spacecraft clock partition information */
/*     for the desired spacecraft must be loaded, using the routine */
/*     FURNSH, before calling this routine. */

/* $ Particulars */

/*     In general, it is difficult to compare spacecraft clock counts */
/*     numerically since there are too many clock components for a */
/*     single comparison.  The routine SCENCD provides a method of */
/*     assigning a single double precision number to a spacecraft's */
/*     clock count, given one of its character representations. */

/*     This routine performs the inverse operation to SCENCD, converting */
/*     an encoded double precision number to character format. */

/*     To convert the number of ticks since the start of the mission to */
/*     a clock format character string, SCDECD: */

/*        1) Determines the spacecraft clock partition that TICKS falls */
/*           in. */

/*        2) Subtracts off the number of ticks occurring in previous */
/*           partitions, to get the number of ticks since the beginning */
/*           of the current partition. */

/*        3) Converts the resulting ticks to clock format and forms the */
/*           string */

/*                      'partition_number/clock_string' */


/* $ Examples */

/*      Double precision encodings of spacecraft clock counts are used to */
/*      tag pointing data in the C-kernel. */

/*      In the following example, pointing for a sequence of images from */
/*      the Voyager 2 narrow angle camera is requested from the C-kernel */
/*      using an array of character spacecraft clock counts as input. */
/*      The clock counts attached to the output are then decoded to */
/*      character and compared with the input strings. */

/*            CHARACTER*(25)     CLKIN   ( 4 ) */
/*            CHARACTER*(25)     CLKOUT */
/*            CHARACTER*(25)     CLKTOL */

/*            DOUBLE PRECISION   TIMEIN */
/*            DOUBLE PRECISION   TIMOUT */
/*            DOUBLE PRECISION   CMAT     ( 3, 3 ) */

/*            INTEGER            NPICS */
/*            INTEGER            SC */

/*            DATA  NPICS     /  4                   / */

/*            DATA  CLKIN     / '2/20538:39:768', */
/*           .                  '2/20543:21:768', */
/*           .                  '2/20550:37', */
/*           .                  '2/20561:59'         / */

/*            DATA  CLKTOL   /  '      0:01:000'     / */

/*      C */
/*      C     The instrument we want pointing for is the Voyager 2 */
/*      C     narrow angle camera.  The reference frame we want is */
/*      C     J2000. The spacecraft is Voyager 2. */
/*      C */
/*            INST = -32001 */
/*            REF  = 'J2000' */
/*            SC   = -32 */

/*      C */
/*      C     Load the appropriate files. We need */
/*      C */
/*      C     1) CK file containing pointing data. */
/*      C     2) Spacecraft clock kernel file, for SCENCD and SCDECD. */
/*      C */
/*            CALL CKLPF  ( 'VGR2NA.CK' ) */
/*            CALL FURNSH ( 'SCLK.KER'  ) */

/*      C */
/*      C     Convert the tolerance string to ticks. */
/*      C */
/*            CALL SCTIKS ( SC, CLKTOL, TOL ) */

/*            DO I = 1, NPICS */

/*               CALL SCENCD ( SC, CLKIN( I ), TIMEIN ) */

/*               CALL CKGP   ( INST, TIMEIN, TOL, REF, CMAT, TIMOUT, */
/*           .                 FOUND ) */

/*               CALL SCDECD ( SC, TIMOUT, CLKOUT ) */

/*               WRITE (*,*) */
/*               WRITE (*,*) 'Input  s/c clock count: ', CLKIN( I ) */
/*               WRITE (*,*) 'Output s/c clock count: ', CLKOUT */
/*               WRITE (*,*) 'Output C-Matrix:        ', CMAT */

/*            END DO */


/*     The output from such a program might look like: */


/*            Input  s/c clock count:  2/20538:39:768 */
/*            Output s/c clock count:  2/20538:39:768 */
/*            Output C-Matrix:  'first C-matrix' */

/*            Input  s/c clock count:  2/20543:21:768 */
/*            Output s/c clock count:  2/20543:22:768 */
/*            Output C-Matrix:  'second C-matrix' */

/*            Input  s/c clock count:  2/20550:37 */
/*            Output s/c clock count:  2/20550:36:768 */
/*            Output C-Matrix:  'third C-matrix' */

/*            Input  s/c clock count:  2/20561:59 */
/*            Output s/c clock count:  2/20561:58:768 */
/*            Output C-Matrix:  'fourth C-matrix' */


/* $ Restrictions */

/*     1) Assumes that an SCLK kernel file appropriate for the clock */
/*        designated by SC is loaded in the kernel pool at the time */
/*        this routine is called. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman (JPL) */
/*     J.M. Lynch   (JPL) */
/*     R.E. Thurman (JPL) */

/* $ Version */

/* -    SPICELIB Version 2.1.0, 05-FEB-2008 (NJB) */

/*        Values of parameter MXPART and PARTLN are now */
/*        provided by the INCLUDE file sclk.inc. */

/* -    SPICELIB Version 2.0.1, 22-AUG-2006 (EDW) */

/*        Replaced references to LDPOOL with references */
/*        to FURNSH. */

/* -    SPICELIB Version 2.0.0, 17-APR-1992 (JML) (WLT) */

/*        The routine was changed to signal an error when SCLKCH is */
/*        not long enough to contain the output spacecraft clock */
/*        string. */

/*        FAILED is now checked after calling SCPART. */

/*        References to CLPOOL were deleted. */

/*        Miscellaneous minor updates to the header were performed. */

/*        Comment section for permuted index source lines was added */
/*        following the header. */

/* -    SPICELIB Version 1.0.0, 06-SEP-1990 (JML) (RET) */

/* -& */
/* $ Index_Entries */

/*     decode spacecraft_clock */

/* -& */
/* $ Revisions */

/* -    SPICELIB Version 2.0.0, 10-APR-1992 (JML) (WLT) */

/*        The routine was changed to signal an error when SCLKCH is */
/*        not long enough to contain the output spacecraft clock */
/*        string.  Previously, the SCLK routines simply truncated */
/*        the clock string on the right.  It was determined that */
/*        since this truncation could easily go undetected by the */
/*        user ( only the leftmost field of a clock string is */
/*        required when clock string is used as an input to a */
/*        SCLK routine ), it would be better to signal an error */
/*        when this happens. */

/*        FAILED is checked after calling SCPART in case an */
/*        error has occurred reading the kernel file and the */
/*        error action is not set to 'abort'. */

/*        References to CLPOOL were deleted. */

/*        Miscellaneous minor updates to the header were performed. */

/*        Comment section for permuted index source lines was added */
/*        following the header. */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("SCDECD", (ftnlen)6);
    }

/*     Use a working copy of the input. */

    ticks = d_nint(sclkdp);
    s_copy(sclkch, " ", sclkch_len, (ftnlen)1);

/*     Read the partition start and stop times (in ticks) for this */
/*     mission. Error if there are too many of them.  Also need to */
/*     check FAILED in case error handling is not in ABORT or */
/*     DEFAULT mode. */

    scpart_(sc, &nparts, pstart, pstop);
    if (failed_()) {
	chkout_("SCDECD", (ftnlen)6);
	return 0;
    }
    if (nparts > 9999) {
	setmsg_("The number of partitions, #, for spacecraft # exceeds the v"
		"alue for parameter MXPART, #.", (ftnlen)88);
	errint_("#", &nparts, (ftnlen)1);
	errint_("#", sc, (ftnlen)1);
	errint_("#", &c__9999, (ftnlen)1);
	sigerr_("SPICE(TOOMANYPARTS)", (ftnlen)19);
	chkout_("SCDECD", (ftnlen)6);
	return 0;
    }

/*     For each partition, compute the total number of ticks in that */
/*     partition plus all preceding partitions. */

    d__1 = pstop[0] - pstart[0];
    ptotls[0] = d_nint(&d__1);
    i__1 = nparts;
    for (i__ = 2; i__ <= i__1; ++i__) {
	d__1 = ptotls[(i__3 = i__ - 2) < 9999 && 0 <= i__3 ? i__3 : s_rnge(
		"ptotls", i__3, "scdecd_", (ftnlen)495)] + pstop[(i__4 = i__ 
		- 1) < 9999 && 0 <= i__4 ? i__4 : s_rnge("pstop", i__4, "scd"
		"ecd_", (ftnlen)495)] - pstart[(i__5 = i__ - 1) < 9999 && 0 <= 
		i__5 ? i__5 : s_rnge("pstart", i__5, "scdecd_", (ftnlen)495)];
	ptotls[(i__2 = i__ - 1) < 9999 && 0 <= i__2 ? i__2 : s_rnge("ptotls", 
		i__2, "scdecd_", (ftnlen)495)] = d_nint(&d__1);
    }

/*     The partition corresponding to the input ticks is the first one */
/*     whose tick total is greater than the input value.  The one */
/*     exception is when the input ticks is equal to the total number */
/*     of ticks represented by all the partitions.  In this case the */
/*     partition number is the last one, i.e. NPARTS. */

/*     Error if TICKS comes before the first partition (that is, if it's */
/*     negative), or after the last one. */

    if (ticks == ptotls[(i__1 = nparts - 1) < 9999 && 0 <= i__1 ? i__1 : 
	    s_rnge("ptotls", i__1, "scdecd_", (ftnlen)510)]) {
	part = nparts;
    } else {
	part = lstled_(&ticks, &nparts, ptotls) + 1;
    }
    if (ticks < 0. || part > nparts) {
	setmsg_("Value for ticks, #, does not fall in any partition for spac"
		"ecraft #.", (ftnlen)68);
	errdp_("#", &ticks, (ftnlen)1);
	errint_("#", sc, (ftnlen)1);
	sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
	chkout_("SCDECD", (ftnlen)6);
	return 0;
    }

/*     To get the count in this partition, subtract off the total of */
/*     the preceding partition counts and add the beginning count for */
/*     this partition. */

    if (part == 1) {
	ticks += pstart[(i__1 = part - 1) < 9999 && 0 <= i__1 ? i__1 : s_rnge(
		"pstart", i__1, "scdecd_", (ftnlen)535)];
    } else {
	ticks = ticks + pstart[(i__1 = part - 1) < 9999 && 0 <= i__1 ? i__1 : 
		s_rnge("pstart", i__1, "scdecd_", (ftnlen)537)] - ptotls[(
		i__2 = part - 2) < 9999 && 0 <= i__2 ? i__2 : s_rnge("ptotls",
		 i__2, "scdecd_", (ftnlen)537)];
    }

/*     Now create the output SCLK clock string. */

/*     First convert from ticks to clock string format. */

    scfmt_(sc, &ticks, sclkch, sclkch_len);

/*     Now convert the partition number to a character string and prefix */
/*     it to the output string. */

    intstr_(&part, prtstr, (ftnlen)5);
    suffix_("/", &c__0, prtstr, (ftnlen)1, (ftnlen)5);
    prelen = lastnb_(prtstr, (ftnlen)5);
    suflen = lastnb_(sclkch, sclkch_len);
    if (i_len(sclkch, sclkch_len) - suflen < prelen) {
	setmsg_("Output string too short to contain clock string. Input tick"
		" value: #, requires string of length #, but declared length "
		"is #.", (ftnlen)124);
	errdp_("#", sclkdp, (ftnlen)1);
	i__1 = prelen + suflen;
	errint_("#", &i__1, (ftnlen)1);
	i__1 = i_len(sclkch, sclkch_len);
	errint_("#", &i__1, (ftnlen)1);
	sigerr_("SPICE(SCLKTRUNCATED)", (ftnlen)20);
	chkout_("SCDECD", (ftnlen)6);
	return 0;
    }
    prefix_(prtstr, &c__0, sclkch, (ftnlen)5, sclkch_len);
    chkout_("SCDECD", (ftnlen)6);
    return 0;
} /* scdecd_ */
コード例 #7
0
ファイル: zzcln.c プロジェクト: Dbelsa/coft
/* $Procedure      ZZCLN ( Private --- clean up ) */
/* Subroutine */ int zzcln_(integer *lookat, integer *nameat, integer *namlst,
	 integer *datlst, integer *nmpool, integer *chpool, integer *dppool)
{
    integer head, tail;
    extern /* Subroutine */ int chkin_(char *, ftnlen), lnkfsl_(integer *, 
	    integer *, integer *), chkout_(char *, ftnlen);

/* $ 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 cleans up changes to the kernel pool that were */
/*     made prior to the detection of a parsing error.  It is purely */
/*     a utility for use only by ZZRVAR. */

/* $ 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 */

/*       PRIVATE UTILITY */

/* $ Declarations */
/* $ Brief_I/O */

/*      VARIABLE  I/O  DESCRIPTION */
/*      --------  ---  -------------------------------------------------- */

/*      LOOKAT     I   The hash value of some name. */
/*      NAMEAT     I   The actual node where the name was stored */
/*      NAMLST    I/O  The array of heads of name lists. */
/*      DATLST    I/O  The array of heads of lists of values */
/*      NMPOOL    I/O  The linked list pool of variable names. */
/*      CHPOOL    I/O  The linked list pool of variable d.p. values. */
/*      DPPOOL    I/O  The linked list pool of variable string values. */


/* $ Detailed_Input */

/*     LOOKAT      is the hash value of some string.  NAMLST(LOOKAT) is */
/*                 the head of some collision resolution list of names. */

/*     NAMEAT      is the node in the list headed by NAMLST(LOOKAT) where */
/*                 some name has been stored in the kernel pool */
/*                 collection of NAMES. The node NAMEAT needs to be */
/*                 removed from its list in NMPOOL. */

/*     NAMLST      is an array of heads of collision */
/*                 resolution lists in NMPOOL.  If NAMLST(LOOKAT) is */
/*                 the same as NAMEAT, we need to adjust NAMLST(LOOKAT) */
/*                 so that it points to the next node in the list. */

/*     DATLST      is an array of heads of data value lists for the */
/*                 variables in the kernel pool.  We will need to free */
/*                 the data list pointed to by DATLST(NAMEAT) and */
/*                 zero out DATLST(NAMEAT). */

/*     NMPOOL      is a linked list pool for collision resolutions of */
/*                 a string hash function.  The node NAMEAT needs to */
/*                 be freed. */

/*     CHPOOL      is a linked list pool for string values associated */
/*                 with a kernel pool variable  If DATLST(NAMEAT) points */
/*                 into CHPOOL, then the list containing this node must */
/*                 be freed. */

/*     DPPOOL      is a linked list pool for d.p. values associated */
/*                 with a kernel pool variable. If DATLST(NAMEAT) points */
/*                 into DPPOOL, then the list containing this node must */
/*                 be freed. */


/* $ Detailed_Output */

/*      NAMLST    are the same structures as the input with the */
/*      DATLST    corrections made for the freeing of the NMPOOL */
/*      NMPOOL    node NAMEAT. */
/*      CHPOOL */
/*      DPPOOL */

/* $ Parameters */

/*      None. */

/* $ Files */

/*      None. */

/* $ Exceptions */

/*      None. */

/* $ Particulars */

/*     During the course of reading and parsing a kernel pool variable */
/*     it may happen that an error in the input text is encountered after */
/*     a kernel pool variable update has been initiated.  This routine */
/*     removes all traces of that variable from the kernel pool storage */
/*     structures. */

/* $ Examples */

/*     See ZZRVAR */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*      W.L. Taber      (JPL) */

/* $ Literature_References */

/*      None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 20-SEP-1995 (WLT) */

/* -& */

/*     Local Parameters and Variables */


/*     First perform the clean up function. This variable */
/*     has been corrupted so there's no point in hanging */
/*     on to it. */

/*     First remove the data... */

    chkin_("ZZCLN", (ftnlen)5);
    head = datlst[*nameat - 1];
    if (head < 0) {
	head = -head;
	tail = -chpool[(head << 1) + 11];
	lnkfsl_(&head, &tail, chpool);
    } else if (head > 0) {
	tail = -dppool[(head << 1) + 11];
	lnkfsl_(&head, &tail, dppool);
    }

/*     Remove the sub-list head from the data list. */

    datlst[*nameat - 1] = 0;

/*     If this was a singleton list remove the pointer to */
/*     the head of the list. */

    head = namlst[*lookat - 1];
    tail = -nmpool[(head << 1) + 11];
    if (head == tail) {
	namlst[*lookat - 1] = 0;
    } else if (namlst[*lookat - 1] == *nameat) {
	namlst[*lookat - 1] = nmpool[(*nameat << 1) + 10];
    }

/*     Finally free up this node in the NMPOOL. */

    head = *nameat;
    tail = *nameat;
    lnkfsl_(&head, &tail, nmpool);
    chkout_("ZZCLN", (ftnlen)5);
    return 0;
} /* zzcln_ */
コード例 #8
0
ファイル: ckw04a.c プロジェクト: Dbelsa/coft
/* $Procedure      CKW04A ( CK type 04: Add data to a segment ) */
/* Subroutine */ int ckw04a_(integer *handle, integer *npkts, integer *pktsiz,
	 doublereal *pktdat, doublereal *sclkdp)
{
    /* System generated locals */
    integer i__1, i__2;

    /* Builtin functions */
    integer s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer k;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    integer dispm, kk;
    extern /* Subroutine */ int errhan_(char *, integer *, ftnlen);
    integer displm;
    extern /* Subroutine */ int sigerr_(char *, ftnlen);
    integer numcft[7];
    extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *, 
	    ftnlen), errint_(char *, integer *, ftnlen);
    extern logical return_(void);
    extern /* Subroutine */ int sgwvpk_(integer *, integer *, integer *, 
	    doublereal *, integer *, doublereal *), zzck4i2d_(integer *, 
	    integer *, doublereal *, doublereal *);

/* $ Abstract */

/*     Add data to a type 4 CK segment currently being written to */
/*     the file associated with HANDLE. See also CKW04B and CKW04E. */

/* $ 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 */

/*     CK */
/*     DAF */

/* $ Keywords */

/*     POINTING */

/* $ Declarations */
/* $ Abstract */

/*     Declarations of the CK data type specific and general CK low */
/*     level routine parameters. */

/* $ 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 */

/*     CK.REQ */

/* $ Keywords */

/*     CK */

/* $ Restrictions */

/*     1) If new CK types are added, the size of the record passed */
/*        between CKRxx and CKExx must be registered as separate */
/*        parameter. If this size will be greater than current value */
/*        of the CKMRSZ parameter (which specifies the maximum record */
/*        size for the record buffer used inside CKPFS) then it should */
/*        be assigned to CKMRSZ as a new value. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */
/*     B.V. Semenov      (JPL) */

/* $ Literature_References */

/*     CK Required Reading. */

/* $ Version */

/* -    SPICELIB Version 3.0.0, 27-JAN-2014 (NJB) */

/*        Updated to support CK type 6. Maximum degree for */
/*        type 5 was updated to be consistent with the */
/*        maximum degree for type 6. */

/* -    SPICELIB Version 2.0.0, 19-AUG-2002 (NJB) */

/*        Updated to support CK type 5. */

/* -    SPICELIB Version 1.0.0, 05-APR-1999 (BVS) */

/* -& */

/*     Number of quaternion components and number of quaternion and */
/*     angular rate components together. */


/*     CK Type 1 parameters: */

/*     CK1DTP   CK data type 1 ID; */

/*     CK1RSZ   maximum size of a record passed between CKR01 */
/*              and CKE01. */


/*     CK Type 2 parameters: */

/*     CK2DTP   CK data type 2 ID; */

/*     CK2RSZ   maximum size of a record passed between CKR02 */
/*              and CKE02. */


/*     CK Type 3 parameters: */

/*     CK3DTP   CK data type 3 ID; */

/*     CK3RSZ   maximum size of a record passed between CKR03 */
/*              and CKE03. */


/*     CK Type 4 parameters: */

/*     CK4DTP   CK data type 4 ID; */

/*     CK4PCD   parameter defining integer to DP packing schema that */
/*              is applied when seven number integer array containing */
/*              polynomial degrees for quaternion and angular rate */
/*              components packed into a single DP number stored in */
/*              actual CK records in a file; the value of must not be */
/*              changed or compatibility with existing type 4 CK files */
/*              will be lost. */

/*     CK4MXD   maximum Chebychev polynomial degree allowed in type 4 */
/*              records; the value of this parameter must never exceed */
/*              value of the CK4PCD; */

/*     CK4SFT   number of additional DPs, which are not polynomial */
/*              coefficients, located at the beginning of a type 4 */
/*              CK record that passed between routines CKR04 and CKE04; */

/*     CK4RSZ   maximum size of type 4 CK record passed between CKR04 */
/*              and CKE04; CK4RSZ is computed as follows: */

/*                 CK4RSZ = ( CK4MXD + 1 ) * QAVSIZ + CK4SFT */


/*     CK Type 5 parameters: */


/*     CK5DTP   CK data type 5 ID; */

/*     CK5MXD   maximum polynomial degree allowed in type 5 */
/*              records. */

/*     CK5MET   number of additional DPs, which are not polynomial */
/*              coefficients, located at the beginning of a type 5 */
/*              CK record that passed between routines CKR05 and CKE05; */

/*     CK5MXP   maximum packet size for any subtype.  Subtype 2 */
/*              has the greatest packet size, since these packets */
/*              contain a quaternion, its derivative, an angular */
/*              velocity vector, and its derivative.  See ck05.inc */
/*              for a description of the subtypes. */

/*     CK5RSZ   maximum size of type 5 CK record passed between CKR05 */
/*              and CKE05; CK5RSZ is computed as follows: */

/*                 CK5RSZ = ( CK5MXD + 1 ) * CK5MXP + CK5MET */


/*     CK Type 6 parameters: */


/*     CK6DTP   CK data type 6 ID; */

/*     CK6MXD   maximum polynomial degree allowed in type 6 */
/*              records. */

/*     CK6MET   number of additional DPs, which are not polynomial */
/*              coefficients, located at the beginning of a type 6 */
/*              CK record that passed between routines CKR06 and CKE06; */

/*     CK6MXP   maximum packet size for any subtype.  Subtype 2 */
/*              has the greatest packet size, since these packets */
/*              contain a quaternion, its derivative, an angular */
/*              velocity vector, and its derivative.  See ck06.inc */
/*              for a description of the subtypes. */

/*     CK6RSZ   maximum size of type 6 CK record passed between CKR06 */
/*              and CKE06; CK6RSZ is computed as follows: */

/*                 CK6RSZ = CK6MET + ( CK6MXD + 1 ) * ( CK6PS3 + 1 ) */

/*              where CK6PS3 is equal to the parameter CK06PS3 defined */
/*              in ck06.inc. Note that the subtype having the largest */
/*              packet size (subtype 2) does not give rise to the */
/*              largest record size, because that type is Hermite and */
/*              requires half the window size used by subtype 3 for a */
/*              given polynomial degree. */


/*     The parameter CK6PS3 must be in sync with C06PS3 defined in */
/*     ck06.inc. */



/*     Maximum record size that can be handled by CKPFS. This value */
/*     must be set to the maximum of all CKxRSZ parameters (currently */
/*     CK5RSZ.) */

/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   The handle of an DAF file opened for writing. */
/*     NPKTS      I   Number of data packets to write to a segment. */
/*     PKTSIZ     I   The numbers of values in the data packets */
/*     PKTDAT     I   The data packets. */
/*     SCLKDP     I   The SCLK times associated with the data packets. */

/* $ Detailed_Input */

/*     HANDLE     is the file handle of a CK file in which a CK type 4 */
/*                segment is currently being written. */

/*     NPKTS      is the number of data packets to write to a segment. */

/*     PKTSIZ     is the number of values in all data packets. */

/*     PKTDAT     is the data packets. The data packets in this array */
/*                must be organized as described in the $ Particulars */
/*                section of the header. */

/*     SCLKDP     contains the initial SCLK times corresponding to the */
/*                Chebyshev coefficients in PKTSIZ. The I'th time is */
/*                start time of the I'th packet coverage interval. */
/*                The times must form a strictly increasing sequence. */

/* $ Detailed_Output */

/*     None.      Data is stored in a segment in the DAF file */
/*                associated with HANDLE. */

/* $ Parameters */

/*     See 'ckparam.inc'. */

/* $ Exceptions */

/*     1) If the number of coefficient sets and epochs is not positive, */
/*        the error SPICE(INVALIDARGUMENT) will be signalled. */

/*     2) If size of any input packet is greater that maximum allowed */
/*        type 4 CK record size minus one, the error */
/*        SPICE(INVALIDARGUMENT) will be signalled. */

/* $ Files */

/*     See HANDLE in the $ Detailed_Input section. */

/* $ Particulars */

/*     This routine adds data to a type 4 CK segment that is currently */
/*     being written to the associated with HANDLE. The segment must */
/*     have been started by a call to the routine CKW04B, the routine */
/*     which begins a type 4 CK segment. */

/*     This routine is one of a set of three routines for creating and */
/*     adding data to type 4 CK segments. These routines are: */

/*        CKW04B: Begin a type 4 CK segment. This routine must be */
/*                called before any data may be added to a type 4 */
/*                segment. */

/*        CKW04A: Add data to a type 4 CK segment. This routine may be */
/*                called any number of times after a call to CKW04B to */
/*                add type 4 records to the CK segment that was */
/*                started. */

/*        CKW04E: End a type 4 CK segment. This routine is called to */
/*                make the type 4 segment a permanent addition to the */
/*                DAF file. Once this routine is called, no further type */
/*                4 records may be added to the segment. A new segment */
/*                must be started. */

/*     A type 4 CK segment consists of coefficient sets for variable */
/*     order Chebyshev polynomials over consecutive time intervals of a */
/*     variable length. The gaps between intervals are allowed. The */
/*     Chebyshev polynomials represent individual SPICE-style quaternion */
/*     components q0, q1, q2 and q3 and individual angular velocities */
/*     AV1, AV2 and AV3 if they are included with the data. */

/*     See the discussion of quaternion styles below. */

/*     The pointing data supplied to the type 4 CK writer (CKW04A) */
/*     is packed into an array as a sequence of records, */

/*        ---------------------------------------------------- */
/*        | Record 1 | Record 2 | .. | Record N-1 | Record N | */
/*        ---------------------------------------------------- */

/*     with each record in data packets has the following format. */

/*        ---------------------------------------------------- */
/*        | The midpoint of the approximation interval       | */
/*        ---------------------------------------------------- */
/*        | The radius of the approximation interval         | */
/*        ---------------------------------------------------- */
/*        | Number of coefficients for q0                    | */
/*        ---------------------------------------------------- */
/*        | Number of coefficients for q1                    | */
/*        ---------------------------------------------------- */
/*        | Number of coefficients for q2                    | */
/*        ---------------------------------------------------- */
/*        | Number of coefficients for q3                    | */
/*        ---------------------------------------------------- */
/*        | Number of coefficients for AV1                   | */
/*        ---------------------------------------------------- */
/*        | Number of coefficients for AV2                   | */
/*        ---------------------------------------------------- */
/*        | Number of coefficients for AV3                   | */
/*        ---------------------------------------------------- */
/*        | q0 Cheby coefficients                            | */
/*        ---------------------------------------------------- */
/*        | q1 Cheby coefficients                            | */
/*        ---------------------------------------------------- */
/*        | q2 Cheby coefficients                            | */
/*        ---------------------------------------------------- */
/*        | q3 Cheby coefficients                            | */
/*        ---------------------------------------------------- */
/*        | AV1 Cheby coefficients (optional)                | */
/*        ---------------------------------------------------- */
/*        | AV2 Cheby coefficients (optional)                | */
/*        ---------------------------------------------------- */
/*        | AV3 Cheby coefficients (optional)                | */
/*        ---------------------------------------------------- */



/*     Quaternion Styles */
/*     ----------------- */

/*     There are different "styles" of quaternions used in */
/*     science and engineering applications. Quaternion styles */
/*     are characterized by */

/*        - The order of quaternion elements */

/*        - The quaternion multiplication formula */

/*        - The convention for associating quaternions */
/*          with rotation matrices */

/*     Two of the commonly used styles are */

/*        - "SPICE" */

/*           > Invented by Sir William Rowan Hamilton */
/*           > Frequently used in mathematics and physics textbooks */

/*        - "Engineering" */

/*           > Widely used in aerospace engineering applications */


/*     SPICELIB subroutine interfaces ALWAYS use SPICE quaternions. */
/*     Quaternions of any other style must be converted to SPICE */
/*     quaternions before they are passed to SPICELIB routines. */


/*     Relationship between SPICE and Engineering Quaternions */
/*     ------------------------------------------------------ */

/*     Let M be a rotation matrix such that for any vector V, */

/*        M*V */

/*     is the result of rotating V by theta radians in the */
/*     counterclockwise direction about unit rotation axis vector A. */
/*     Then the SPICE quaternions representing M are */

/*        (+/-) (  cos(theta/2), */
/*                 sin(theta/2) A(1), */
/*                 sin(theta/2) A(2), */
/*                 sin(theta/2) A(3)  ) */

/*     while the engineering quaternions representing M are */

/*        (+/-) ( -sin(theta/2) A(1), */
/*                -sin(theta/2) A(2), */
/*                -sin(theta/2) A(3), */
/*                 cos(theta/2)       ) */

/*     For both styles of quaternions, if a quaternion q represents */
/*     a rotation matrix M, then -q represents M as well. */

/*     Given an engineering quaternion */

/*        QENG   = ( q0,  q1,  q2,  q3 ) */

/*     the equivalent SPICE quaternion is */

/*        QSPICE = ( q3, -q0, -q1, -q2 ) */


/*     Associating SPICE Quaternions with Rotation Matrices */
/*     ---------------------------------------------------- */

/*     Let FROM and TO be two right-handed reference frames, for */
/*     example, an inertial frame and a spacecraft-fixed frame. Let the */
/*     symbols */

/*        V    ,   V */
/*         FROM     TO */

/*     denote, respectively, an arbitrary vector expressed relative to */
/*     the FROM and TO frames. Let M denote the transformation matrix */
/*     that transforms vectors from frame FROM to frame TO; then */

/*        V   =  M * V */
/*         TO         FROM */

/*     where the expression on the right hand side represents left */
/*     multiplication of the vector by the matrix. */

/*     Then if the unit-length SPICE quaternion q represents M, where */

/*        q = (q0, q1, q2, q3) */

/*     the elements of M are derived from the elements of q as follows: */

/*          +-                                                         -+ */
/*          |           2    2                                          | */
/*          | 1 - 2*( q2 + q3 )   2*(q1*q2 - q0*q3)   2*(q1*q3 + q0*q2) | */
/*          |                                                           | */
/*          |                                                           | */
/*          |                               2    2                      | */
/*      M = | 2*(q1*q2 + q0*q3)   1 - 2*( q1 + q3 )   2*(q2*q3 - q0*q1) | */
/*          |                                                           | */
/*          |                                                           | */
/*          |                                                   2    2  | */
/*          | 2*(q1*q3 - q0*q2)   2*(q2*q3 + q0*q1)   1 - 2*( q1 + q2 ) | */
/*          |                                                           | */
/*          +-                                                         -+ */

/*     Note that substituting the elements of -q for those of q in the */
/*     right hand side leaves each element of M unchanged; this shows */
/*     that if a quaternion q represents a matrix M, then so does the */
/*     quaternion -q. */

/*     To map the rotation matrix M to a unit quaternion, we start by */
/*     decomposing the rotation matrix as a sum of symmetric */
/*     and skew-symmetric parts: */

/*                                        2 */
/*        M = [ I  +  (1-cos(theta)) OMEGA  ] + [ sin(theta) OMEGA ] */

/*                     symmetric                   skew-symmetric */


/*     OMEGA is a skew-symmetric matrix of the form */

/*                   +-             -+ */
/*                   |  0   -n3   n2 | */
/*                   |               | */
/*         OMEGA  =  |  n3   0   -n1 | */
/*                   |               | */
/*                   | -n2   n1   0  | */
/*                   +-             -+ */

/*     The vector N of matrix entries (n1, n2, n3) is the rotation axis */
/*     of M and theta is M's rotation angle.  Note that N and theta */
/*     are not unique. */

/*     Let */

/*        C = cos(theta/2) */
/*        S = sin(theta/2) */

/*     Then the unit quaternions Q corresponding to M are */

/*        Q = +/- ( C, S*n1, S*n2, S*n3 ) */

/*     The mappings between quaternions and the corresponding rotations */
/*     are carried out by the SPICELIB routines */

/*        Q2M {quaternion to matrix} */
/*        M2Q {matrix to quaternion} */

/*     M2Q always returns a quaternion with scalar part greater than */
/*     or equal to zero. */


/*     SPICE Quaternion Multiplication Formula */
/*     --------------------------------------- */

/*     Given a SPICE quaternion */

/*        Q = ( q0, q1, q2, q3 ) */

/*     corresponding to rotation axis A and angle theta as above, we can */
/*     represent Q using "scalar + vector" notation as follows: */

/*        s =   q0           = cos(theta/2) */

/*        v = ( q1, q2, q3 ) = sin(theta/2) * A */

/*        Q = s + v */

/*     Let Q1 and Q2 be SPICE quaternions with respective scalar */
/*     and vector parts s1, s2 and v1, v2: */

/*        Q1 = s1 + v1 */
/*        Q2 = s2 + v2 */

/*     We represent the dot product of v1 and v2 by */

/*        <v1, v2> */

/*     and the cross product of v1 and v2 by */

/*        v1 x v2 */

/*     Then the SPICE quaternion product is */

/*        Q1*Q2 = s1*s2 - <v1,v2>  + s1*v2 + s2*v1 + (v1 x v2) */

/*     If Q1 and Q2 represent the rotation matrices M1 and M2 */
/*     respectively, then the quaternion product */

/*        Q1*Q2 */

/*     represents the matrix product */

/*        M1*M2 */


/* $ Examples */

/*     Assume that we have: */

/*        HANDLE   is the handle of an CK file opened with write */
/*                 access. */

/*        SEGID    is a character string of no more than 40 characters */
/*                 which provides a pedigree for the data in the CK */
/*                 segment we will create. */

/*        INST     is the SPICE ID code for the instrument whose */
/*                 pointing data is to be placed into the file. */

/*        AVFLAG   angular rates flag. */

/*        REFFRM   is the name of the SPICE reference frame for the */
/*                 pointing data. */

/*        BEGTIM   is the starting encoded SCLK time for which the */
/*                 segment is valid. */

/*        ENDTIM   is the ending encoded SCLK time for which the segment */
/*                 is valid. */

/*        N        is the number of type 4 records that we want to */
/*                 put into a segment in an CK file. */

/*        NPKTS    is integer array which contains the lengths of */
/*                 variable size data packets */

/*        RECRDS   contains N type 4 records packaged for the CK */
/*                 file. */

/*        SCSTRT   contains the initial encoded SC time for each of */
/*                 the records contained in RECRDS, where */

/*                    SCSTRT(I) < SCSTRT(I+1), I = 1, N-1 */

/*                    SCSTRT(1) <= FIRST, SCSTRT(N) < LAST */

/*     Then the following code fragment demonstrates how to create */
/*     a type 4 CK segment if all of the data for the segment is */
/*     available at one time. */

/*     C */
/*     C     Begin the segment. */
/*     C */
/*           CALL CKW04B ( HANDLE, BEGTIM, INST, REF, AVFLAG, SEGID ) */
/*     C */
/*     C     Add the data to the segment all at once. */
/*     C */
/*           CALL CKW04A ( HANDLE, N, NPKTS, RECRDS, SCSTRT ) */
/*     C */
/*     C     End the segment, making the segment a permanent */
/*     C     addition to the CK file. */
/*     C */
/*           CALL CKW04E ( HANDLE, ENDTIM ) */

/* $ Restrictions */

/*     1) The type 4 CK segment to which the data is added must have */
/*        been started by the routine CKW04B, the routine which begins */
/*        a type 4 CK segment. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     Y.K. Zaiko     (JPL) */
/*     B.V. Semenov   (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.1.2, 18-APR-2014 (BVS) */

/*        Minor header edits. */

/* -    SPICELIB Version 1.1.1, 26-FEB-2008 (NJB) */

/*        Updated header; added information about SPICE */
/*        quaternion conventions. */

/* -    SPICELIB Version 1.1.0, 07-SEP-2001 (EDW) */

/*        Removed DAFHLU call; replaced ERRFNM call with ERRHAN. */
/*        Added IMPLICIT NONE. */

/* -    SPICELIB Version 1.0.0, 05-MAY-1999 (YKZ) (BVS) */

/* -& */
/* $ Index_Entries */

/*     add data to a type_4 ck segment */

/* -& */

/*     Spicelib functions. */


/*     Local parameters. */


/*     The number of elements by which coefficients in each packet */
/*     have to be shifted to the left after numbers of coefficients */
/*     were packed into a single integer. */


/*     Local Variables. */


/*     Standard SPICELIB error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("CKW04A", (ftnlen)6);
    }

/*     First, check if the number of coefficient sets and epochs */
/*     is positive and whether each packet is smaller than the */
/*     maximum size of a record that CKPFS can handle. */

    i__1 = *npkts;
    for (k = 1; k <= i__1; ++k) {
	if (pktsiz[k - 1] <= 0) {
	    setmsg_("The number of coefficient sets and epochs in the # data"
		    " packet (record) to be added to the DAF segment in the f"
		    "ile '#' was not positive. Its value was: #.", (ftnlen)154)
		    ;
	    errint_("#", &k, (ftnlen)1);
	    errhan_("#", handle, (ftnlen)1);
	    errint_("#", &pktsiz[k - 1], (ftnlen)1);
	    sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
	    chkout_("CKW04A", (ftnlen)6);
	    return 0;
	}

/*        We do .GE. comparison because a type 4 CK record passed */
/*        inside CKPFS will have one more element -- time at which */
/*        the pointing will be evaluated. */

	if (pktsiz[k - 1] >= 143) {
	    setmsg_("The total size of the # data packet (record) to be adde"
		    "d to the DAF segment in the file '#' is greater than the"
		    " maximum allowed type 4 record size #. Its value was: #.",
		     (ftnlen)167);
	    errint_("#", &k, (ftnlen)1);
	    errhan_("#", handle, (ftnlen)1);
	    errint_("#", &c__142, (ftnlen)1);
	    errint_("#", &pktsiz[k - 1], (ftnlen)1);
	    sigerr_("SPICE(INVALIDARGUMENT)", (ftnlen)22);
	    chkout_("CKW04A", (ftnlen)6);
	    return 0;
	}
    }
    displm = 0;
    dispm = 0;

/*     The cycle below encodes groups of numbers of coefficients in */
/*     data packets to single double precision numbers and shift */
/*     data in packets to the left to decrease the data packet */
/*     lengths. */

    i__1 = *npkts;
    for (k = 1; k <= i__1; ++k) {

/*        Encode integer numbers of coefficients for each component */
/*        to single double precision variable */

	for (kk = 1; kk <= 7; ++kk) {
	    numcft[(i__2 = kk - 1) < 7 && 0 <= i__2 ? i__2 : s_rnge("numcft", 
		    i__2, "ckw04a_", (ftnlen)580)] = (integer) pktdat[kk + 2 
		    + displm - 1];
	}
	zzck4i2d_(numcft, &c__7, &c_b20, &pktdat[dispm + 2]);

/*        Shift coefficients sets to the left to overwrite numbers of */
/*        packets */

	i__2 = pktsiz[k - 1];
	for (kk = 4; kk <= i__2; ++kk) {
	    pktdat[kk + dispm - 1] = pktdat[kk + 6 + displm - 1];
	}

/*        Shift middle value and radii of interval */

	pktdat[dispm] = pktdat[displm];
	pktdat[dispm + 1] = pktdat[displm + 1];
	displm += pktsiz[k - 1];

/*        Length of each data packet became less for 6 elements because */
/*        of encoding of 7 double precision numbers, which are the */
/*        numbers of polynomial coefficients, to one double precision */
/*        number */

	pktsiz[k - 1] += -6;
	dispm += pktsiz[k - 1];
    }

/*     Add the data. */

    sgwvpk_(handle, npkts, pktsiz, pktdat, npkts, sclkdp);

/*     No need to check FAILED() here, since all we do is check out. */
/*     Leave it up to the caller. */

    chkout_("CKW04A", (ftnlen)6);
    return 0;
} /* ckw04a_ */
コード例 #9
0
ファイル: zzeklerc.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure ZZEKLERC  ( EK, LLE, using record pointers, character  ) */
/* Subroutine */ int zzeklerc_(integer *handle, integer *segdsc, integer *
	coldsc, char *ckey, integer *recptr, logical *null, integer *prvidx, 
	integer *prvptr, ftnlen ckey_len)
{
    extern /* Subroutine */ int zzekerc1_(integer *, integer *, integer *, 
	    char *, integer *, logical *, integer *, integer *, ftnlen), 
	    zzekcnam_(integer *, integer *, char *, ftnlen), chkin_(char *, 
	    ftnlen), errch_(char *, char *, ftnlen, ftnlen);
    integer dtype, itype;
    extern logical failed_(void);
    logical indexd;
    char column[32];
    extern /* Subroutine */ int setmsg_(char *, ftnlen), sigerr_(char *, 
	    ftnlen), chkout_(char *, ftnlen), errint_(char *, integer *, 
	    ftnlen);

/* $ Abstract */

/*     Find the last column value less than or equal to a specified key, */
/*     for a specified, indexed character EK column, using dictionary */
/*     ordering on character data values and record pointers. */

/* $ 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 */

/*     EK */

/* $ Keywords */

/*     EK */
/*     PRIVATE */

/* $ 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. */


/*     Include Section:  EK Boolean Enumerated Type */


/*        ekbool.inc Version 1   21-DEC-1994 (NJB) */


/*     Within the EK system, boolean values sometimes must be */
/*     represented by integer or character codes.  The codes and their */
/*     meanings are listed below. */

/*     Integer code indicating `true': */


/*     Integer code indicating `false': */


/*     Character code indicating `true': */


/*     Character code indicating `false': */


/*     End Include Section:  EK Boolean Enumerated 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. */


/*     Include Section:  EK Column Name Size */

/*        ekcnamsz.inc Version 1    17-JAN-1995 (NJB) */


/*     Size of column name, in characters. */


/*     End Include Section:  EK Column Name Size */

/* $ 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. */


/*     Include Section:  EK Column Descriptor Parameters */

/*        ekcoldsc.inc Version 6    23-AUG-1995 (NJB) */


/*     Note:  The column descriptor size parameter CDSCSZ  is */
/*     declared separately in the include section CDSIZE$INC.FOR. */

/*     Offset of column descriptors, relative to start of segment */
/*     integer address range.  This number, when added to the last */
/*     integer address preceding the segment, yields the DAS integer */
/*     base address of the first column descriptor.  Currently, this */
/*     offset is exactly the size of a segment descriptor.  The */
/*     parameter SDSCSZ, which defines the size of a segment descriptor, */
/*     is declared in the include file eksegdsc.inc. */


/*     Size of column descriptor */


/*     Indices of various pieces of column descriptors: */


/*     CLSIDX is the index of the column's class code.  (We use the */
/*     word `class' to distinguish this item from the column's data */
/*     type.) */


/*     TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/*     or TIME).  The type is actually implied by the class, but it */
/*     will frequently be convenient to look up the type directly. */



/*     LENIDX is the index of the column's string length value, if the */
/*     column has character type.  A value of IFALSE in this element of */
/*     the descriptor indicates that the strings have variable length. */


/*     SIZIDX is the index of the column's element size value.  This */
/*     descriptor element is meaningful for columns with fixed-size */
/*     entries.  For variable-sized columns, this value is IFALSE. */


/*     NAMIDX is the index of the base address of the column's name. */


/*     IXTIDX is the data type of the column's index.  IXTIDX */
/*     contains a type value only if the column is indexed. For columns */
/*     that are not indexed, the location IXTIDX contains the boolean */
/*     value IFALSE. */


/*     IXPIDX is a pointer to the column's index.  IXTPDX contains a */
/*     meaningful value only if the column is indexed.  The */
/*     interpretation of the pointer depends on the data type of the */
/*     index. */


/*     NFLIDX is the index of a flag indicating whether nulls are */
/*     permitted in the column.  The value at location NFLIDX is */
/*     ITRUE if nulls are permitted and IFALSE otherwise. */


/*     ORDIDX is the index of the column's ordinal position in the */
/*     list of columns belonging to the column's parent segment. */


/*     METIDX is the index of the column's integer metadata pointer. */
/*     This pointer is a DAS integer address. */


/*     The last position in the column descriptor is reserved.  No */
/*     parameter is defined to point to this location. */


/*     End Include Section:  EK Column Descriptor Parameters */

/* $ 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. */


/*     Include Section:  EK Segment Descriptor Parameters */

/*        eksegdsc.inc  Version 8  06-NOV-1995 (NJB) */


/*     All `base addresses' referred to below are the addresses */
/*     *preceding* the item the base applies to.  This convention */
/*     enables simplied address calculations in many cases. */

/*     Size of segment descriptor.  Note:  the include file ekcoldsc.inc */
/*     must be updated if this parameter is changed.  The parameter */
/*     CDOFF in that file should be kept equal to SDSCSZ. */


/*     Index of the segment type code: */


/*     Index of the segment's number.  This number is the segment's */
/*     index in the list of segments contained in the EK to which */
/*     the segment belongs. */


/*     Index of the DAS integer base address of the segment's integer */
/*     meta-data: */


/*     Index of the DAS character base address of the table name: */


/*     Index of the segment's column count: */


/*     Index of the segment's record count: */


/*     Index of the root page number of the record tree: */


/*     Index of the root page number of the character data page tree: */


/*     Index of the root page number of the double precision data page */
/*     tree: */


/*     Index of the root page number of the integer data page tree: */


/*     Index of the `modified' flag: */


/*     Index of the `initialized' flag: */


/*     Index of the shadowing flag: */


/*     Index of the companion file handle: */


/*     Index of the companion segment number: */


/*     The next three items are, respectively, the page numbers of the */
/*     last character, d.p., and integer data pages allocated by the */
/*     segment: */


/*     The next three items are, respectively, the page-relative */
/*     indices of the last DAS word in use in the segment's */
/*     last character, d.p., and integer data pages: */


/*     Index of the DAS character base address of the column name list: */


/*     The last descriptor element is reserved for future use.  No */
/*     parameter is defined to point to this location. */


/*     End Include Section:  EK Segment Descriptor Parameters */

/* $ 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. */


/*     Include Section:  EK Data Types */

/*        ektype.inc Version 1  27-DEC-1994 (NJB) */


/*     Within the EK system, data types of EK column contents are */
/*     represented by integer codes.  The codes and their meanings */
/*     are listed below. */

/*     Integer codes are also used within the DAS system to indicate */
/*     data types; the EK system makes no assumptions about compatibility */
/*     between the codes used here and those used in the DAS system. */


/*     Character type: */


/*     Double precision type: */


/*     Integer type: */


/*     `Time' type: */

/*     Within the EK system, time values are represented as ephemeris */
/*     seconds past J2000 (TDB), and double precision numbers are used */
/*     to store these values.  However, since time values require special */
/*     treatment both on input and output, and since the `TIME' column */
/*     has a special role in the EK specification and code, time values */
/*     are identified as a type distinct from double precision numbers. */


/*     End Include Section:  EK Data Types */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   File handle. */
/*     SEGDSC     I   Segment descriptor. */
/*     COLDSC     I   Column descriptor. */
/*     CKEY       I   Double precision key. */
/*     RECPTR     I   Record pointer. */
/*     NULL       I   Null flag. */
/*     PRVIDX     O   Ordinal position of predecessor of CKEY. */
/*     PRVPTR     O   Record pointer for predecessor of CKEY. */

/* $ Detailed_Input */

/*     HANDLE         is a file handle of an EK that is open for read or */
/*                    write access. */

/*     SEGDSC         is the segment descriptor of the segment */
/*                    containing the column specified by COLDSC. */

/*     COLDSC         is the column descriptor of the column to be */
/*                    searched. */

/*     CKEY, */
/*     RECPTR         are, respectively, a character key and a pointer */
/*                    to the EK record containing that key. */
/*                    The last column entry less than or equal to */
/*                    this key is sought.  The order relation used */
/*                    is dictionary ordering on the pair (CKEY, RECPTR). */

/*     NULL           is a logical flag indicating whether the input */
/*                    key is null.  When NULL is .TRUE., CKEY is */
/*                    ignored by this routine. */

/* $ Detailed_Output */

/*     PRVIDX         is the ordinal position, according to the order */
/*                    relation implied by the column's index, of the */
/*                    record containing the last element less than or */
/*                    equal to CKEY, where the order relation is */
/*                    as indicated above.  If the column contains */
/*                    elements equal to CKEY, PRVIDX is the index of the */
/*                    last such element. */

/*                    If all elements of the column are greater than */
/*                    CKEY, PRVIDX is set to zero. */

/*     PRVPTR         is a pointer to the record containing the element */
/*                    whose ordinal position is PRVIDX. */

/*                    If all elements of the column are greater than */
/*                    CKEY, PRVPTR is set to zero. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)  If HANDLE is invalid, the error will be diagnosed by routines */
/*         called by this routine. */

/*     2)  If the data type of the input column is not character, */
/*         the error SPICE(INVALIDTYPE) is signalled. */

/*     3)  If the input column is not indexed, the error */
/*         SPICE(NOTINDEXED) is signalled. */

/*     4)  If the index type of the input column is not recognized, */
/*         the error SPICE(INVALIDTYPE) is signalled. */

/*     5)  If an I/O error occurs while reading or writing the indicated */
/*         file, the error will be diagnosed by routines called by this */
/*         routine. */

/* $ Files */

/*     See the EK Required Reading for a discussion of the EK file */
/*     format. */

/* $ Particulars */

/*     This routine finds the last column element less than or equal */
/*     to a specified character key, within a specified segment and */
/*     column. */

/*     In order to support the capability of creating an index for a */
/*     column that has already been populated with data, this routine */
/*     does not require that number of elements referenced by the */
/*     input column's index match the number of elements in the column; */
/*     the index is allowed to reference fewer elements.  However, */
/*     every record referenced by the index must be populated with data. */

/* $ Examples */

/*     See ZZEKIIXC. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */

/* $ Version */

/* -    Beta Version 1.1.0, 18-JUN-1999 (WLT) */

/*        Removed an unbalanced call to CHKOUT. */

/* -    Beta Version 1.0.0, 11-OCT-1995 (NJB) */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Use discovery check-in. */

    if (failed_()) {
	return 0;
    }

/*     If the column's not indexed, we have no business being here. */

    indexd = coldsc[5] != -1;
    if (! indexd) {
	zzekcnam_(handle, coldsc, column, (ftnlen)32);
	chkin_("ZZEKLERC ", (ftnlen)9);
	setmsg_("Column # is not indexed.", (ftnlen)24);
	errch_("#", column, (ftnlen)1, (ftnlen)32);
	sigerr_("SPICE(NOTINDEXED)", (ftnlen)17);
	chkout_("ZZEKLERC ", (ftnlen)9);
	return 0;
    }

/*     Check the column's data type. */

    dtype = coldsc[1];
    if (dtype != 1) {
	zzekcnam_(handle, coldsc, column, (ftnlen)32);
	chkin_("ZZEKLERC ", (ftnlen)9);
	setmsg_("Column # should be CHR but has type #.", (ftnlen)38);
	errch_("#", column, (ftnlen)1, (ftnlen)32);
	errint_("#", &dtype, (ftnlen)1);
	sigerr_("SPICE(INVALIDTYPE)", (ftnlen)18);
	chkout_("ZZEKLERC ", (ftnlen)9);
	return 0;
    }

/*     Hand the problem off to the subroutine that understands this */
/*     column's index type. */

    itype = coldsc[5];
    if (itype == 1) {
	zzekerc1_(handle, segdsc, coldsc, ckey, recptr, null, prvidx, prvptr, 
		ckey_len);
    } else {
	zzekcnam_(handle, coldsc, column, (ftnlen)32);
	chkin_("ZZEKLERC ", (ftnlen)9);
	setmsg_("Column # has index type #.", (ftnlen)26);
	errch_("#", column, (ftnlen)1, (ftnlen)32);
	errint_("#", &itype, (ftnlen)1);
	sigerr_("SPICE(INVALIDTYPE)", (ftnlen)18);
	chkout_("ZZEKLERC ", (ftnlen)9);
	return 0;
    }
    return 0;
} /* zzeklerc_ */
コード例 #10
0
ファイル: spkpvn.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure SPKPVN ( S/P Kernel, position and velocity in native frame ) */
/* Subroutine */ int spkpvn_(integer *handle, doublereal *descr, doublereal *
	et, integer *ref, doublereal *state, integer *center)
{
    integer type__;
    extern /* Subroutine */ int chkin_(char *, ftnlen), dafus_(doublereal *, 
	    integer *, integer *, doublereal *, integer *), spke01_(
	    doublereal *, doublereal *, doublereal *), spke02_(doublereal *, 
	    doublereal *, doublereal *), spke03_(doublereal *, doublereal *, 
	    doublereal *), spke10_(doublereal *, doublereal *, doublereal *), 
	    spke05_(doublereal *, doublereal *, doublereal *), spke12_(
	    doublereal *, doublereal *, doublereal *), spke13_(doublereal *, 
	    doublereal *, doublereal *), spke08_(doublereal *, doublereal *, 
	    doublereal *), spke09_(doublereal *, doublereal *, doublereal *), 
	    spke14_(doublereal *, doublereal *, doublereal *), spke15_(
	    doublereal *, doublereal *, doublereal *), spke17_(doublereal *, 
	    doublereal *, doublereal *), spke18_(doublereal *, doublereal *, 
	    doublereal *), spkr01_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr02_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr03_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr05_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr10_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr12_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr08_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr09_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr13_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr14_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr15_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr17_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr18_(integer *, doublereal *, doublereal *, 
	    doublereal *), spkr19_(integer *, doublereal *, doublereal *, 
	    doublereal *), spke19_(doublereal *, doublereal *, doublereal *), 
	    spkr20_(integer *, doublereal *, doublereal *, doublereal *), 
	    spke20_(doublereal *, doublereal *, doublereal *), spkr21_(
	    integer *, doublereal *, doublereal *, doublereal *), spke21_(
	    doublereal *, doublereal *, doublereal *);
    doublereal dc[2];
    integer ic[6];
    extern logical failed_(void);
    doublereal record[198];
    extern /* Subroutine */ int sgfcon_(integer *, doublereal *, integer *, 
	    integer *, doublereal *), sigerr_(char *, ftnlen), chkout_(char *,
	     ftnlen);
    integer recsiz;
    extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *, 
	    integer *, ftnlen);
    extern logical return_(void);

/* $ Abstract */

/*     Return the state (position and velocity) of a target body */
/*     relative to some center of motion. */

/* $ 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 */
/* $ Abstract */

/*     Declare SPK data record size.  This record is declared in */
/*     SPKPVN and is passed to SPK reader (SPKRxx) and evaluator */
/*     (SPKExx) routines. */

/* $ 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 */

/*     SPK */

/* $ Restrictions */

/*     1) If new SPK types are added, it may be necessary to */
/*        increase the size of this record.  The header of SPKPVN */
/*        should be updated as well to show the record size */
/*        requirement for each data type. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 2.0.0, 05-OCT-2012 (NJB) */

/*        Updated to support increase of maximum degree to 27 for types */
/*        2, 3, 8, 9, 12, 13, 18, and 19. See SPKPVN for a list */
/*        of record size requirements as a function of data type. */

/* -    SPICELIB Version 1.0.0, 16-AUG-2002 (NJB) */

/* -& */

/*     End include file spkrec.inc */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   File handle. */
/*     DESCR      I   Segment descriptor. */
/*     ET         I   Target epoch. */
/*     REF        O   Target reference frame. */
/*     STATE      O   Position, velocity. */
/*     CENTER     O   Center of state. */
/*     MAXREC     P   Maximum length of records returned by SPKRnn. */

/* $ Detailed_Input */

/*     HANDLE, */
/*     DESCR       are the file handle assigned to a SPK file, and the */
/*                 descriptor for a segment within the file. Together */
/*                 they determine the ephemeris data from which the */
/*                 state of the body is to be computed. */

/*     ET          is the epoch (ephemeris time) at which the state */
/*                 is to be computed. */

/* $ Detailed_Output */

/*     REF         is the id-code of the reference frame to */
/*                 which the vectors returned by the routine belong. */

/*     STATE       contains the position and velocity, at epoch ET, */
/*                 for whatever body is covered by the specified segment. */
/*                 STATE has six elements:  the first three contain the */
/*                 body's position; the last three contain the body's */
/*                 velocity.  These vectors are rotated into the */
/*                 specified  reference frame, the origin of */
/*                 which is located at the center of motion for the */
/*                 body (see CENTER, below).  Units are always km and */
/*                 km/sec. */

/*     CENTER      is the integer ID code of the center of motion for */
/*                 the state. */

/* $ Parameters */

/*     MAXREC      is the maximum length of a record returned by any of */
/*                 data type-specific routines SPKRnn, which are called */
/*                 by SPKPVN (see Particulars). */

/* $ Exceptions */

/*     1) If the segment type is not supported by the current */
/*        version of SPKPVN, the error 'SPICE(SPKTYPENOTSUPP)' */
/*        is signaled. */


/* $ Files */

/*     See argument HANDLE. */

/* $ Particulars */

/*     SPKPVN is the most basic of the SPK readers, the reader upon */
/*     which SPKPV and SPKGEO, etc. are built. It should not normally */
/*     be called directly except in cases where some optimization is */
/*     required. (That is, where the calling program has prior knowledge */
/*     of the center-barycenter shifts to be performed, or a non-standard */
/*     method of determining the files and segments to be used when */
/*     computing states.) */

/*     This is the only reader which makes distinctions between the */
/*     various segment types in the SPK format. The complete list */
/*     of types currently supported is shown below. */

/*        Type   Description */
/*        ----   ----------------------- */
/*           1   Difference Lines */
/*           2   Chebyshev (P) */
/*           3   Chebyshev (P,V) */
/*           5   Two body propagation between discrete states */
/*           8   Lagrange interpolation, equally spaced discrete states */
/*           9   Lagrange interpolation, unequally spaced discrete states */
/*          12   Hermite interpolation, equally spaced discrete states */
/*          13   Hermite interpolation, unequally spaced discrete states */
/*          14   Chebyshev Unequally spaced */
/*          15   Precessing Ellipse */
/*          17   Equinoctial Elements */
/*          18   ESOC/DDID Hermite/Lagrange Interpolation */
/*          19   ESOC/DDID Piecewise Interpolation */
/*          20   Chebyshev (V) */
/*          21   Extended Modified Difference Array */

/*     SPKPVN is the only reader that needs to be changed in order to */
/*     add a new segment type to the SPK format.  If a new data type is */
/*     added, the following steps should be taken: */

/*     1) Write two new routines, SPKRnn and SPKEnn, to read and */
/*        evaluate, respectively, a record from a data type nn segment. */

/*     2) Insert a new case into the body of SPKPVN to accommodate the */
/*        new type. */

/*     3) If necessary, adjust the parameter MAXREC, above, so that it */
/*        is large enough to encompass the maximum size of a record */
/*        returned by SPKRnn and passed to SPKEnn. */

/*        The maximum record lengths for each data type currently */
/*        supported are as follows: */

/*                  Data type       Maximum record length */
/*                  ---------       --------------------- */
/*                      1                    71 */
/*                      2                    87 */
/*                      3                   171 */
/*                      5                    15 */
/*                      8                   171 */
/*                      9                   197 */
/*                     12                    87 */
/*                     13                    99 */
/*                     14                 Variable */
/*                     15                    16 */
/*                     17                    12 */
/*                     18                   198 */
/*                     19                   198 */
/*                     20                   159 */
/*                     21                   112 */

/* $ Examples */

/*     In the following code fragment, an entire SPK file is searched */
/*     for segments containing a particular epoch. For each one found, */
/*     the body, center, segment identifier, and range at the epoch */
/*     are printed out. */

/*        CALL DAFOPR ( 'TEST.SPK', HANDLE ) */
/*        CALL DAFBFS (             HANDLE ) */

/*        CALL DAFFNA ( FOUND  ) */

/*        DO WHILE ( FOUND ) */
/*           CALL DAFGS ( DESCR ) */
/*           CALL DAFUS ( DESCR, 2, 6, DC, IC ) */

/*           IF ( DC(1) .LE. ET  .AND.  ET .LE. DC(2) ) THEN */
/*              CALL SPKPVN ( HANDLE, DESCR, ET, REF, STATE, CENTER ) */
/*              CALL DAFGN  ( IDENT ) */
/*              CALL FRMNAM ( REF, FRAME ) */
/*              WRITE (*,*) */
/*              WRITE (*,*) 'Body   = ', IC(1) */
/*              WRITE (*,*) 'Center = ', CENTER, */
/*              WRITE (*,*) 'ID     = ', IDENT */
/*              WRITE (*,*) 'Frame  = ', FRAME */
/*              WRITE (*,*) 'Range  = ', VNORM ( STATE ) */
/*           END IF */

/*           CALL DAFFNA ( FOUND ) */
/*        END DO */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */
/*     W.L. Taber      (JPL) */

/* $ Version */

/* -    SPICELIB Version 4.0.0,  23-DEC-2013 (NJB) */

/*        Added support for types 19, 20 and 21. Added header */
/*        comments giving description for types 18, 19, */
/*        and 21. Removed header reference to type 4. */

/* -    SPICELIB Version 3.0.0,  16-AUG-2002 (NJB) */

/*        Added support for type 18.  This routine now uses the */
/*        include file spkrec.inc to declare the record size. */

/*        Corrected header comments giving record sizes for types */
/*        8, 9, 12, 13. */

/* -    SPICELIB Version 2.0.0,  06-NOV-1999 (NJB) */

/*        Added support for types 12 and 13. */

/* -    SPICELIB Version 1.1.0,  7-JAN-1997 (WLT) */

/*        Added support for type 17. */

/* -    SPICELIB Version 1.0.0, 19-SEP-1995 (WLT) */


/* -& */
/* $ Index_Entries */

/*     position and velocity from ephemeris */
/*     spk file position and velocity */

/* -& */
/* $ Revisions */

/* -    SPICELIB Version 1.1.0,  7-JAN-1997 (WLT) */

/*        Added support for type 17. */


/* -& */

/*     SPICELIB functions */


/*     Some local space is needed in which to return records, and */
/*     into which to unpack the segment descriptor. */


/*     Local Parameters */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("SPKPVN", (ftnlen)6);
    }

/*     Unpacking the segment descriptor will tell us the center, */
/*     reference frame, and data type for this segment. */

    dafus_(descr, &c__2, &c__6, dc, ic);
    *center = ic[1];
    *ref = ic[2];
    type__ = ic[3];

/*     Each data type has a pair of routines to read and evaluate */
/*     records for that data type. These routines are the only ones */
/*     that actually look inside the segments. */

/*     By the time we have more than 100 data types, we should be */
/*     allowed to use longer variable names. */

    if (type__ == 1) {
	spkr01_(handle, descr, et, record);
	spke01_(et, record, state);
    } else if (type__ == 2) {
	spkr02_(handle, descr, et, record);
	spke02_(et, record, state);
    } else if (type__ == 3) {
	spkr03_(handle, descr, et, record);
	spke03_(et, record, state);

/*     Type 04 is not officially part of the library. */

/*     ELSE IF ( TYPE .EQ. 04 ) THEN */
/*         CALL SPKR04 ( HANDLE, DESCR, ET, RECORD         ) */
/*         CALL SPKE04 (                ET, RECORD, STATE  ) */
    } else if (type__ == 5) {
	spkr05_(handle, descr, et, record);
	spke05_(et, record, state);
    } else if (type__ == 8) {
	spkr08_(handle, descr, et, record);
	spke08_(et, record, state);
    } else if (type__ == 9) {
	spkr09_(handle, descr, et, record);
	spke09_(et, record, state);
    } else if (type__ == 10) {
	spkr10_(handle, descr, et, record);
	spke10_(et, record, state);
    } else if (type__ == 12) {
	spkr12_(handle, descr, et, record);
	spke12_(et, record, state);
    } else if (type__ == 13) {
	spkr13_(handle, descr, et, record);
	spke13_(et, record, state);
    } else if (type__ == 14) {

/*        Fetch the number of Chebyshev coefficients, compute the record */
/*        size needed, and signal an error if there is not enough storage */
/*        in RECORD. The number of coefficients is the first constant */
/*        value in the generic segment. */

	sgfcon_(handle, descr, &c__1, &c__1, record);
	if (failed_()) {
	    chkout_("SPKPVN", (ftnlen)6);
	    return 0;
	}
	recsiz = (integer) record[0] * 6 + 3;
	if (recsiz > 198) {
	    setmsg_("Storage for # double precision numbers is needed for an"
		    " SPK data record and only # locations were available. Up"
		    "date the parameter MAXREC in the subroutine SPKPVN and n"
		    "otify the NAIF group of this problem.", (ftnlen)204);
	    errint_("#", &recsiz, (ftnlen)1);
	    errint_("#", &c__198, (ftnlen)1);
	    sigerr_("SPICE(SPKRECTOOLARGE)", (ftnlen)21);
	    chkout_("SPKPVN", (ftnlen)6);
	    return 0;
	}
	spkr14_(handle, descr, et, record);
	spke14_(et, record, state);
    } else if (type__ == 15) {
	spkr15_(handle, descr, et, record);
	spke15_(et, record, state);
    } else if (type__ == 17) {
	spkr17_(handle, descr, et, record);
	spke17_(et, record, state);
    } else if (type__ == 18) {
	spkr18_(handle, descr, et, record);
	spke18_(et, record, state);
    } else if (type__ == 19) {
	spkr19_(handle, descr, et, record);
	spke19_(et, record, state);
    } else if (type__ == 20) {
	spkr20_(handle, descr, et, record);
	spke20_(et, record, state);
    } else if (type__ == 21) {
	spkr21_(handle, descr, et, record);
	spke21_(et, record, state);
    } else {
	setmsg_("SPK type # is not supported in your version of the SPICE li"
		"brary.  You will need to upgrade your version of the library"
		" to make use of ephemerides that contain this SPK data type. "
		, (ftnlen)180);
	errint_("#", &type__, (ftnlen)1);
	sigerr_("SPICE(SPKTYPENOTSUPP)", (ftnlen)21);
	chkout_("SPKPVN", (ftnlen)6);
	return 0;
    }
    chkout_("SPKPVN", (ftnlen)6);
    return 0;
} /* spkpvn_ */
コード例 #11
0
ファイル: lnkan.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure      LNKAN  ( LNK, allocate node ) */
/* Subroutine */ int lnkan_(integer *pool, integer *new__)
{
    extern /* Subroutine */ int chkin_(char *, ftnlen), sigerr_(char *, 
	    ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen);

/* $ Abstract */

/*     Allocate a node in a doubly linked list pool. */

/* $ 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 */

/*     LNK */

/* $ Keywords */

/*     LIST */

/* $ Declarations */
/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     POOL      I-O  A doubly linked list pool. */
/*     NEW        O   Number of new node that was allocated. */
/*     LBPOOL     P   Lower bound of pool column indices. */

/* $ Detailed_Input */

/*     POOL           is a doubly linked list pool. */

/* $ Detailed_Output */

/*     POOL           is the input pool, with the following */
/*                    modifications: */

/*                       -- NEW is an allocated node:  both the forward */
/*                          and backward pointers of NEW are -NEW. */

/*                       -- The node that was the successor of NEW on */
/*                          input is the head of the free list on output. */


/*     NEW            is the number of the newly allocated node. */

/* $ Parameters */

/*     LBPOOL        is the lower bound of the column indices of the POOL */
/*                   array.  The columns indexed LBPOOL to 0 are reserved */
/*                   as a control area for the pool. */

/* $ Exceptions */

/*     1)  If no free nodes are available for allocation, the error */
/*         SPICE(NOFREENODES) is signalled. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     In a doubly linked list pool, an `allocated node' is one that has */
/*     been removed from the free list.  An allocated node may be linked */
/*     to other nodes or may be unlinked; in the latter case, both the */
/*     forward and backward pointers of the node will be the negative of */
/*     the node number. */

/*     A node must be allocated before it can be linked to another */
/*     node. */

/* $ Examples */

/*     1)  Let POOL be a doubly linked list pool.  To build a new list */
/*         of ten nodes, the code fragment below can be used: */

/*            C */
/*            C     We'll use LNKILA ( LNK, insert list after */
/*            C     a specified node ) to add nodes to the tail of the */
/*            C     list. */
/*            C */
/*                  PREV = 0 */

/*                  DO I = 1, 10 */

/*                     CALL LNKAN  ( POOL, NODE       ) */
/*                     CALL LNKILA ( PREV, NODE, POOL ) */
/*                     PREV = NODE */

/*                  END DO */


/*     2)  In this version of example (1), we check that a sufficient */
/*         number of free nodes are available before building the list: */

/*            C */
/*            C     Make sure we have 10 free nodes available. */
/*            C     Signal an error if not.  Use LNKNFN to obtain */
/*            C     the number of free nodes. */
/*            C */
/*                  IF ( LNKNFN(POOL) .LT. 10 ) THEN */

/*                     CALL SETMSG ( 'Only # free nodes are available '// */
/*                 .                 'but 10 are required.'            ) */
/*                     CALL ERRINT ( '#', LNKNFN(POOL)                 ) */
/*                     CALL SIGERR ( 'POOL_TOO_SMALL'                  ) */
/*                     RETURN */

/*                  END IF */

/*                     [ Build list ] */
/*                           . */
/*                           . */
/*                           . */

/* $ Restrictions */

/*     Linked list pools must be initialized via the routine */
/*     LNKINI.  Failure to initialize a linked list pool */
/*     will almost certainly lead to confusing results. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */
/*     W.L. Taber     (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 19-DEC-1995 (NJB) (WLT) */

/* -& */
/* $ Index_Entries */

/*     allocate node from linked list pool */

/* -& */

/*     Local parameters */


/*     The control area contains 3 elements.  They are: */

/*        The "size" of the pool, that is, the number */
/*        of nodes in the pool. */

/*        The number of free nodes in the pool. */

/*        The "free pointer," which is the column index of the first free */
/*        node. */

/*     Parameters defining the row and column indices of these control */
/*     elements are given below. */


/*     Each assigned node consists of a backward pointer and a forward */
/*     pointer. */

/*        +-------------+       +-------------+       +-------------+ */
/*        |  forward--> |       |  forward--> |       |  forward--> | */
/*        +-------------+  ...  +-------------+  ...  +-------------+ */
/*        | <--backward |       | <--backward |       | <--backward | */
/*        +-------------+       +-------------+       +-------------+ */

/*            node 1                 node I              node SIZE */




/*     Free nodes say that that's what they are.  The way they say it */
/*     is by containing the value FREE in their backward pointers. */
/*     Needless to say, FREE is a value that cannot be a valid pointer. */


/*     Discovery check-in is used in place of standard SPICE error */
/*     handling. */

    if (pool[11] == 0) {
	chkin_("LNKAN", (ftnlen)5);
	setmsg_("There are no free nodes left for allocating in the supplied"
		" linked list pool. ", (ftnlen)78);
	sigerr_("SPICE(NOFREENODES)", (ftnlen)18);
	chkout_("LNKAN", (ftnlen)5);
	return 0;
    }

/*     The caller gets the first free node.  The forward pointer of */
/*     this node indicates the next free node.  After this, there's one */
/*     less free node. */

    *new__ = pool[8];
    pool[8] = pool[(*new__ << 1) + 10];
    --pool[11];

/*     The forward and backward pointers of the allocated node become */
/*     the negatives of the node numbers of the head and tail nodes */
/*     of the list containing NEW.  Since this is a singleton list, */
/*     both pointers are -NEW. */

    pool[(*new__ << 1) + 10] = -(*new__);
    pool[(*new__ << 1) + 11] = -(*new__);
    return 0;
} /* lnkan_ */
コード例 #12
0
ファイル: spkapp.c プロジェクト: Dbelsa/coft
/* $Procedure SPKAPP ( S/P Kernel, apparent state ) */
/* Subroutine */ int spkapp_(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];
    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), spkssb_(
	    integer *, doublereal *, char *, doublereal *, 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_("SPKAPP", (ftnlen)6);
    }
    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_("SPKAPP", (ftnlen)6);
	    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_("SPKAPP", (ftnlen)6);
	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. */

    spkssb_(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;
	spkssb_(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_("SPKAPP", (ftnlen)6);
    return 0;
} /* spkapp_ */
コード例 #13
0
ファイル: zzekad04.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure     ZZEKAD04 ( EK, add data to class 4 column ) */
/* Subroutine */ int zzekad04_(integer *handle, integer *segdsc, integer *
	coldsc, integer *recptr, integer *nvals, integer *ivals, logical *
	isnull)
{
    /* System generated locals */
    integer i__1, i__2;

    /* Local variables */
    integer nrec;
    extern integer zzekrp2n_(integer *, integer *, integer *);
    integer room;
    extern /* Subroutine */ int zzekpgbs_(integer *, integer *, integer *), 
	    zzekglnk_(integer *, integer *, integer *, integer *), zzeksfwd_(
	    integer *, integer *, integer *, integer *), zzekslnk_(integer *, 
	    integer *, integer *, integer *);
    integer p, mbase, pbase;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    integer recno, ncols, lastw, start, p2;
    extern /* Subroutine */ int dasudi_(integer *, integer *, integer *, 
	    integer *);
    integer remain, colidx, datptr, nlinks, nwrite, ptrloc;
    logical fstpag;
    extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *, 
	    integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), zzekaps_(integer *, integer *, integer *, logical *, 
	    integer *, integer *);

/* $ Abstract */

/*     Add a column entry to a specified record in a class 4 column. */
/*     The entries of class 4 columns are arrays of integer values. */

/* $ 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 */

/*     EK */

/* $ Keywords */

/*     EK */
/*     PRIVATE */

/* $ 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. */


/*     Include Section:  EK Boolean Enumerated Type */


/*        ekbool.inc Version 1   21-DEC-1994 (NJB) */


/*     Within the EK system, boolean values sometimes must be */
/*     represented by integer or character codes.  The codes and their */
/*     meanings are listed below. */

/*     Integer code indicating `true': */


/*     Integer code indicating `false': */


/*     Character code indicating `true': */


/*     Character code indicating `false': */


/*     End Include Section:  EK Boolean Enumerated 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. */


/*     Include Section:  EK Column Descriptor Parameters */

/*        ekcoldsc.inc Version 6    23-AUG-1995 (NJB) */


/*     Note:  The column descriptor size parameter CDSCSZ  is */
/*     declared separately in the include section CDSIZE$INC.FOR. */

/*     Offset of column descriptors, relative to start of segment */
/*     integer address range.  This number, when added to the last */
/*     integer address preceding the segment, yields the DAS integer */
/*     base address of the first column descriptor.  Currently, this */
/*     offset is exactly the size of a segment descriptor.  The */
/*     parameter SDSCSZ, which defines the size of a segment descriptor, */
/*     is declared in the include file eksegdsc.inc. */


/*     Size of column descriptor */


/*     Indices of various pieces of column descriptors: */


/*     CLSIDX is the index of the column's class code.  (We use the */
/*     word `class' to distinguish this item from the column's data */
/*     type.) */


/*     TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/*     or TIME).  The type is actually implied by the class, but it */
/*     will frequently be convenient to look up the type directly. */



/*     LENIDX is the index of the column's string length value, if the */
/*     column has character type.  A value of IFALSE in this element of */
/*     the descriptor indicates that the strings have variable length. */


/*     SIZIDX is the index of the column's element size value.  This */
/*     descriptor element is meaningful for columns with fixed-size */
/*     entries.  For variable-sized columns, this value is IFALSE. */


/*     NAMIDX is the index of the base address of the column's name. */


/*     IXTIDX is the data type of the column's index.  IXTIDX */
/*     contains a type value only if the column is indexed. For columns */
/*     that are not indexed, the location IXTIDX contains the boolean */
/*     value IFALSE. */


/*     IXPIDX is a pointer to the column's index.  IXTPDX contains a */
/*     meaningful value only if the column is indexed.  The */
/*     interpretation of the pointer depends on the data type of the */
/*     index. */


/*     NFLIDX is the index of a flag indicating whether nulls are */
/*     permitted in the column.  The value at location NFLIDX is */
/*     ITRUE if nulls are permitted and IFALSE otherwise. */


/*     ORDIDX is the index of the column's ordinal position in the */
/*     list of columns belonging to the column's parent segment. */


/*     METIDX is the index of the column's integer metadata pointer. */
/*     This pointer is a DAS integer address. */


/*     The last position in the column descriptor is reserved.  No */
/*     parameter is defined to point to this location. */


/*     End Include Section:  EK Column Descriptor Parameters */

/* $ 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. */


/*     Include Section:  EK Data Page Parameters */

/*        ekfilpar.inc  Version 1  03-APR-1995 (NJB) */

/*     These parameters apply to EK files using architecture 4. */
/*     These files use a paged DAS file as their underlying file */
/*     structure. */

/*     In paged DAS EK files, data pages are structured:  they contain */
/*     metadata as well as data.  The metadata is located in the last */
/*     few addresses of each page, so as to interfere as little as */
/*     possible with calculation of data addresses. */

/*     Each data page belongs to exactly one segment.  Some bookkeeping */
/*     information, such as record pointers, is also stored in data */
/*     pages. */

/*     Each page contains a forward pointer that allows rapid lookup */
/*     of data items that span multiple pages.  Each page also keeps */
/*     track of the current number of links from its parent segment */
/*     to the page.  Link counts enable pages to `know' when they */
/*     are no longer in use by a segment; unused pages are deallocated */
/*     and returned to the free list. */

/*     The parameters in this include file depend on the parameters */
/*     declared in the include file ekpage.inc.  If those parameters */
/*     change, this file must be updated.  The specified parameter */
/*     declarations we need from that file are: */

/*        INTEGER               PGSIZC */
/*        PARAMETER           ( PGSIZC = 1024 ) */

/*        INTEGER               PGSIZD */
/*        PARAMETER           ( PGSIZD = 128 ) */

/*        INTEGER               PGSIZI */
/*        PARAMETER           ( PGSIZI = 256 ) */



/*     Character pages use an encoding mechanism to represent integer */
/*     metadata.  Each integer is encoded in five consecutive */
/*     characters. */


/*     Character data page parameters: */


/*     Size of encoded integer: */


/*     Usable page size: */


/*     Location of character forward pointer: */


/*     Location of character link count: */


/*     Double precision data page parameters: */

/*     Usable page size: */


/*     Location of d.p. forward pointer: */


/*     Location of d.p. link count: */


/*     Integer data page parameters: */

/*     Usable page size: */


/*     Location of integer forward pointer: */


/*     Location of integer link count: */


/*     End Include Section:  EK Data Page Parameters */

/* $ 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. */


/*     Include Section:  EK Record Pointer Parameters */

/*        ekrecptr.inc Version 2  18-JUL-1995 (NJB) */


/*     This file declares parameters used in EK record pointers. */
/*     Each segment references data in a given record via two levels */
/*     of indirection:  a record number points to a record pointer, */
/*     which is a structured array of metadata and data pointers. */

/*     Record pointers always occupy contiguous ranges of integer */
/*     addresses. */

/*     The parameter declarations in this file depend on the assumption */
/*     that integer pages contain 256 DAS integer words and that the */
/*     maximum number of columns in a segment is 100.  Record pointers */
/*     are stored in integer data pages, so they must fit within the */
/*     usable data area afforded by these pages.  The size of the usable */
/*     data area is given by the parameter IPSIZE which is declared in */
/*     ekdatpag.inc.  The assumed value of IPSIZE is 254. */


/*     The first element of each record pointer is a status indicator. */
/*     The meanings of status indicators depend on whether the parent EK */
/*     is shadowed or not.  For shadowed EKs, allowed status values and */
/*     their meanings are: */

/*        OLD       The record has not been modified since */
/*                  the EK containing the record was opened. */

/*        UPDATE    The record is an update of a previously existing */
/*                  record.  The original record is now on the */
/*                  modified record list. */

/*        NEW       The record has been added since the EK containing the */
/*                  record was opened.  The record is not an update */
/*                  of a previously existing record. */

/*        DELOLD    This status applies only to a backup record. */
/*                  DELOLD status indicates that the record corresponds */
/*                  to a deleted OLD record in the source segment. */

/*        DELNEW    This status applies only to a backup record. */
/*                  DELNEW status indicates that the record corresponds */
/*                  to a deleted NEW record in the source segment. */

/*        DELUPD    This status applies only to a backup record. */
/*                  DELUPD status indicates that the record corresponds */
/*                  to a deleted UPDATEd record in the source segment. */

/*     In EKs that are not shadowed, all records have status OLD. */



/*     The following parameters refer to indices within the record */
/*     pointer structure: */

/*     Index of status indicator: */


/*     Each record pointer contains a pointer to its companion:  for a */
/*     record belonging to a shadowed EK, this is the backup counterpart, */
/*     or if the parent EK is itself a backup EK, a pointer to the */
/*     record's source record.  The pointer is UNINIT (see below) if the */
/*     record is unmodified. */

/*     Record companion pointers contain record numbers, not record */
/*     base addresses. */

/*     Index of record's companion pointer: */


/*     Each data item is referenced by an integer.  The meaning of */
/*     this integer depends on the representation of data in the */
/*     column to which the data item belongs.  Actual lookup of a */
/*     data item must be done by subroutines appropriate to the class of */
/*     the column to which the item belongs.  Note that data items don't */
/*     necessarily occupy contiguous ranges of DAS addresses. */

/*     Base address of data pointers: */


/*     Maximum record pointer size: */


/*     Data pointers are given the value UNINIT to start with; this */
/*     indicates that the data item is uninitialized.  UNINIT is */
/*     distinct from the value NULL.  NOBACK indicates an uninitialized */
/*     backup column entry. */


/*     End Include Section:  EK Record Pointer Parameters */

/* $ 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. */


/*     Include Section:  EK Segment Descriptor Parameters */

/*        eksegdsc.inc  Version 8  06-NOV-1995 (NJB) */


/*     All `base addresses' referred to below are the addresses */
/*     *preceding* the item the base applies to.  This convention */
/*     enables simplied address calculations in many cases. */

/*     Size of segment descriptor.  Note:  the include file ekcoldsc.inc */
/*     must be updated if this parameter is changed.  The parameter */
/*     CDOFF in that file should be kept equal to SDSCSZ. */


/*     Index of the segment type code: */


/*     Index of the segment's number.  This number is the segment's */
/*     index in the list of segments contained in the EK to which */
/*     the segment belongs. */


/*     Index of the DAS integer base address of the segment's integer */
/*     meta-data: */


/*     Index of the DAS character base address of the table name: */


/*     Index of the segment's column count: */


/*     Index of the segment's record count: */


/*     Index of the root page number of the record tree: */


/*     Index of the root page number of the character data page tree: */


/*     Index of the root page number of the double precision data page */
/*     tree: */


/*     Index of the root page number of the integer data page tree: */


/*     Index of the `modified' flag: */


/*     Index of the `initialized' flag: */


/*     Index of the shadowing flag: */


/*     Index of the companion file handle: */


/*     Index of the companion segment number: */


/*     The next three items are, respectively, the page numbers of the */
/*     last character, d.p., and integer data pages allocated by the */
/*     segment: */


/*     The next three items are, respectively, the page-relative */
/*     indices of the last DAS word in use in the segment's */
/*     last character, d.p., and integer data pages: */


/*     Index of the DAS character base address of the column name list: */


/*     The last descriptor element is reserved for future use.  No */
/*     parameter is defined to point to this location. */


/*     End Include Section:  EK Segment Descriptor Parameters */

/* $ 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. */


/*     Include Section:  EK Data Types */

/*        ektype.inc Version 1  27-DEC-1994 (NJB) */


/*     Within the EK system, data types of EK column contents are */
/*     represented by integer codes.  The codes and their meanings */
/*     are listed below. */

/*     Integer codes are also used within the DAS system to indicate */
/*     data types; the EK system makes no assumptions about compatibility */
/*     between the codes used here and those used in the DAS system. */


/*     Character type: */


/*     Double precision type: */


/*     Integer type: */


/*     `Time' type: */

/*     Within the EK system, time values are represented as ephemeris */
/*     seconds past J2000 (TDB), and double precision numbers are used */
/*     to store these values.  However, since time values require special */
/*     treatment both on input and output, and since the `TIME' column */
/*     has a special role in the EK specification and code, time values */
/*     are identified as a type distinct from double precision numbers. */


/*     End Include Section:  EK Data Types */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   File handle. */
/*     SEGDSC     I   Segment descriptor. */
/*     COLDSC     I   Column descriptor. */
/*     RECPTR     I   Record pointer. */
/*     NVALS      I   Number of values to add to column. */
/*     IVALS      I   Integer values to add to column. */
/*     ISNULL     I   Flag indicating whether column entry is null. */

/* $ Detailed_Input */

/*     HANDLE         is a file handle of an EK open for write access. */

/*     SEGDSC         is the descriptor of the segment in which */
/*                    the specified column entry is to be written. */

/*     COLDSC         is the descriptor of the column in which */
/*                    the specified column entry is to be written. */

/*     RECPTR         is a pointer to the record containing the column */
/*                    entry to be written. */

/*     NVALS, */
/*     IVALS          are, respectively, the number of values to add to */
/*                    the specified column and the set of values */
/*                    themselves.  The data values are written into the */
/*                    specified column and record. */

/*                    If the column has fixed-size entries, then NVALS */
/*                    must equal the entry size for the specified column. */

/*                    Only one value can be added to a virtual column. */


/*     ISNULL         is a logical flag indicating whether the entry is */
/*                    null.  If ISNULL is .FALSE., the column entry */
/*                    defined by NVALS and IVALS is added to the */
/*                    specified kernel file. */

/*                    If ISNULL is .TRUE., NVALS and IVALS are ignored. */
/*                    The contents of the column entry are undefined. */
/*                    If the column has fixed-length, variable-size */
/*                    entries, the number of entries is considered to */
/*                    be 1. */

/* $ Detailed_Output */

/*     None.  See the $Particulars section for a description of the */
/*     effect of this routine. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)  If HANDLE is invalid, the error will be diagnosed by routines */
/*         called by this routine.  The file is not modified. */

/*     2)  If the ordinal position of the column specified by COLDSC */
/*         is out of range, the error SPICE(INVALIDINDEX) is signalled. */
/*         The file is not modified. */

/*     3)  If the input flag ISNULL is .TRUE. but the target column */
/*         does not allow nulls, the error SPICE(BADATTRIBUTE) is */
/*         signalled.  The file is not modified. */

/*     4)  If RECPTR is invalid, a DAS addressing error may occur.  The */
/*         error in *not* trapped in advance.  This routine assumes that */
/*         a valid value of RECPTR has been supplied by the caller. */

/*     3)  If an I/O error occurs while reading or writing the indicated */
/*         file, the error will be diagnosed by routines called by this */
/*         routine.  The file may be corrupted. */

/* $ Files */

/*     See the EK Required Reading for a discussion of the EK file */
/*     format. */

/* $ Particulars */

/*     This routine operates by side effects:  it sets the value of a */
/*     column entry in an EK segment.  If the column is indexed, the */
/*     index is updated to reflect the presence of the new entry.  This */
/*     routine is intended to set values of uninitialized column entries */
/*     only.  To update existing entries, use the ZZEKUExx routines, or */
/*     at the user level, the EKUCEx routines. */

/*     This routine does not participate in shadowing functions.  If the */
/*     target EK is shadowed, the caller is responsible for performing */
/*     necessary backup operations.  If the target EK is not shadowed, */
/*     the target record's status is not modified. */

/*     The changes made by this routine to the target EK file become */
/*     permanent when the file is closed.  Failure to close the file */
/*     properly will leave it in an indeterminate state. */

/* $ Examples */

/*     See EKACEI. */

/* $ Restrictions */

/*     1) This routine cannot be used to update existing column entries. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */

/* $ Version */

/* -    Beta Version 1.0.0, 26-SEP-1995 (NJB) */

/* -& */

/*     Non-SPICELIB functions */


/*     Local variables */


/*     Use discovery check-in. */

    nrec = segdsc[5];
    colidx = coldsc[8];

/*     Make sure the column exists. */

    ncols = segdsc[4];
    if (colidx < 1 || colidx > ncols) {
	chkin_("ZZEKAD04", (ftnlen)8);
	setmsg_("Column index = #; valid range is 1:#.", (ftnlen)37);
	errint_("#", &colidx, (ftnlen)1);
	errint_("#", &nrec, (ftnlen)1);
	sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
	chkout_("ZZEKAD04", (ftnlen)8);
	return 0;
    }

/*     If the value is null, make sure that nulls are permitted */
/*     in this column. */

    if (*isnull && coldsc[7] != 1) {
	recno = zzekrp2n_(handle, &segdsc[1], recptr);
	chkin_("ZZEKAD04", (ftnlen)8);
	setmsg_("Column having index # in segment # does not allow nulls, bu"
		"t a null value was supplied for the element in record #.", (
		ftnlen)115);
	errint_("#", &colidx, (ftnlen)1);
	errint_("#", &segdsc[1], (ftnlen)1);
	errint_("#", &recno, (ftnlen)1);
	sigerr_("SPICE(BADATTRIBUTE)", (ftnlen)19);
	chkout_("ZZEKAD04", (ftnlen)8);
	return 0;
    }

/*     Check NVALS.  If the column has fixed-size entries, NVALS must */
/*     match the declared entry size.  In all cases, NVALS must be */
/*     positive. */

    if (*nvals < 1) {
	chkin_("ZZEKAD04", (ftnlen)8);
	setmsg_("COLIDX = #;  segment = #; NVALS = #;  NVALS must be positiv"
		"e ", (ftnlen)61);
	errint_("#", &colidx, (ftnlen)1);
	errint_("#", &segdsc[1], (ftnlen)1);
	errint_("#", nvals, (ftnlen)1);
	sigerr_("SPICE(INVALIDCOUNT)", (ftnlen)19);
	chkout_("ZZEKAD04", (ftnlen)8);
	return 0;
    }
    if (coldsc[3] != -1) {
	if (*nvals != coldsc[3]) {
	    chkin_("ZZEKAD04", (ftnlen)8);
	    setmsg_("COLIDX = #;  segment = #; NVALS = #; declared entry siz"
		    "e = #.  Sizes must match.", (ftnlen)80);
	    errint_("#", &colidx, (ftnlen)1);
	    errint_("#", &segdsc[1], (ftnlen)1);
	    errint_("#", nvals, (ftnlen)1);
	    errint_("#", &coldsc[3], (ftnlen)1);
	    sigerr_("SPICE(INVALIDCOUNT)", (ftnlen)19);
	    chkout_("ZZEKAD04", (ftnlen)8);
	    return 0;
	}
    }

/*     Compute the data pointer location. */

    ptrloc = *recptr + 2 + colidx;
    if (*isnull) {

/*        All we need do is set the data pointer.  The segment's */
/*        metadata are not affected. */

	dasudi_(handle, &ptrloc, &ptrloc, &c_n2);
    } else {
	lastw = segdsc[20];
	room = 254 - lastw;
	remain = *nvals;
	start = 1;
	fstpag = TRUE_;
	while(remain > 0) {

/*           Decide where to write the data values.  In order to write */
/*           to the current page, we require enough room for the count */
/*           and at least one column entry element. */

	    if (room >= 2) {

/*              There's room in the current page.  If this is the first */
/*              page this entry is written on, set the data pointer */
/*              and count.  Write as much of the value as possible to */
/*              the current page. */

		p = segdsc[17];
		zzekpgbs_(&c__3, &p, &pbase);
		datptr = pbase + lastw + 1;
		if (fstpag) {
		    dasudi_(handle, &ptrloc, &ptrloc, &datptr);
		    dasudi_(handle, &datptr, &datptr, nvals);
		    --room;
		    ++datptr;
		}
		nwrite = min(remain,room);
		i__1 = datptr + nwrite - 1;
		dasudi_(handle, &datptr, &i__1, &ivals[start - 1]);
		remain -= nwrite;
		room -= nwrite;
		start += nwrite;

/*              The page containing the data item gains a link. */

		zzekglnk_(handle, &c__3, &p, &nlinks);
		i__1 = nlinks + 1;
		zzekslnk_(handle, &c__3, &p, &i__1);

/*              The last integer word in use must be updated.  Account */
/*              for the count, if this is the first page on which the */
/*              current entry is written. */

		if (fstpag) {
		    segdsc[20] = lastw + 1 + nwrite;
		    fstpag = FALSE_;
		} else {
		    segdsc[20] = lastw + nwrite;
		}
	    } else {

/*              Allocate a data page.  If this is not the first data */
/*              page written to, link the previous page to the current */
/*              one. */

		zzekaps_(handle, segdsc, &c__3, &c_false, &p2, &pbase);
		if (! fstpag) {
		    zzeksfwd_(handle, &c__3, &p, &p2);
		}

/*              The last integer page and word in use must be updated. */

		p = p2;
		lastw = 0;
		segdsc[17] = p;
		segdsc[20] = lastw;
		room = 254;

/*              Make sure the link count is zeroed out. */

		zzekslnk_(handle, &c__3, &p, &c__0);
	    }
	}
    }

/*     Write out the updated segment descriptor. */

    mbase = segdsc[2];
    i__1 = mbase + 1;
    i__2 = mbase + 24;
    dasudi_(handle, &i__1, &i__2, segdsc);

/*     Class 4 columns are not indexed, so we need not update any */
/*     index to account for the new element. */

    return 0;
} /* zzekad04_ */
コード例 #14
0
ファイル: zzekrd08.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure   ZZEKRD08 ( EK, read class 8 column entry ) */
/* Subroutine */ int zzekrd08_(integer *handle, integer *segdsc, integer *
	coldsc, integer *recptr, doublereal *dval, logical *isnull)
{
    /* System generated locals */
    integer i__1, i__2;

    /* Local variables */
    integer mdat[2], nrec;
    extern integer zzekrp2n_(integer *, integer *, integer *);
    integer unit;
    char cflag[1];
    integer q, r__;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    integer recno, ncols, addrss, colidx, datbas, metloc, nflbas, offset;
    logical nullok;
    extern /* Subroutine */ int dashlu_(integer *, integer *), setmsg_(char *,
	     ftnlen), errint_(char *, integer *, ftnlen), sigerr_(char *, 
	    ftnlen), chkout_(char *, ftnlen), dasrdi_(integer *, integer *, 
	    integer *, integer *), dasrdc_(integer *, integer *, integer *, 
	    integer *, integer *, char *, ftnlen), dasrdd_(integer *, integer 
	    *, integer *, doublereal *);

/* $ Abstract */

/*     Read a column entry from a specified record in a class 8 column. */
/*     Class 8 columns contain fixed-count, scalar, double precision */
/*     values. */

/* $ 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 */

/*     EK */

/* $ Keywords */

/*     EK */
/*     PRIVATE */

/* $ 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. */


/*     Include Section:  EK Boolean Enumerated Type */


/*        ekbool.inc Version 1   21-DEC-1994 (NJB) */


/*     Within the EK system, boolean values sometimes must be */
/*     represented by integer or character codes.  The codes and their */
/*     meanings are listed below. */

/*     Integer code indicating `true': */


/*     Integer code indicating `false': */


/*     Character code indicating `true': */


/*     Character code indicating `false': */


/*     End Include Section:  EK Boolean Enumerated 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. */


/*     Include Section:  EK Column Class 8 Parameters */

/*        ekclas08.inc  Version 1    07-NOV-1995 (NJB) */


/*     The following parameters give the offsets of items in the */
/*     class 8 integer metadata array. */

/*     Data array base address: */


/*     Null flag array base address: */


/*     Size of class 8 metadata array: */


/*     End Include Section:  EK Column Class 8 Parameters */

/* $ 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. */


/*     Include Section:  EK Column Descriptor Parameters */

/*        ekcoldsc.inc Version 6    23-AUG-1995 (NJB) */


/*     Note:  The column descriptor size parameter CDSCSZ  is */
/*     declared separately in the include section CDSIZE$INC.FOR. */

/*     Offset of column descriptors, relative to start of segment */
/*     integer address range.  This number, when added to the last */
/*     integer address preceding the segment, yields the DAS integer */
/*     base address of the first column descriptor.  Currently, this */
/*     offset is exactly the size of a segment descriptor.  The */
/*     parameter SDSCSZ, which defines the size of a segment descriptor, */
/*     is declared in the include file eksegdsc.inc. */


/*     Size of column descriptor */


/*     Indices of various pieces of column descriptors: */


/*     CLSIDX is the index of the column's class code.  (We use the */
/*     word `class' to distinguish this item from the column's data */
/*     type.) */


/*     TYPIDX is the index of the column's data type code (CHR, INT, DP, */
/*     or TIME).  The type is actually implied by the class, but it */
/*     will frequently be convenient to look up the type directly. */



/*     LENIDX is the index of the column's string length value, if the */
/*     column has character type.  A value of IFALSE in this element of */
/*     the descriptor indicates that the strings have variable length. */


/*     SIZIDX is the index of the column's element size value.  This */
/*     descriptor element is meaningful for columns with fixed-size */
/*     entries.  For variable-sized columns, this value is IFALSE. */


/*     NAMIDX is the index of the base address of the column's name. */


/*     IXTIDX is the data type of the column's index.  IXTIDX */
/*     contains a type value only if the column is indexed. For columns */
/*     that are not indexed, the location IXTIDX contains the boolean */
/*     value IFALSE. */


/*     IXPIDX is a pointer to the column's index.  IXTPDX contains a */
/*     meaningful value only if the column is indexed.  The */
/*     interpretation of the pointer depends on the data type of the */
/*     index. */


/*     NFLIDX is the index of a flag indicating whether nulls are */
/*     permitted in the column.  The value at location NFLIDX is */
/*     ITRUE if nulls are permitted and IFALSE otherwise. */


/*     ORDIDX is the index of the column's ordinal position in the */
/*     list of columns belonging to the column's parent segment. */


/*     METIDX is the index of the column's integer metadata pointer. */
/*     This pointer is a DAS integer address. */


/*     The last position in the column descriptor is reserved.  No */
/*     parameter is defined to point to this location. */


/*     End Include Section:  EK Column Descriptor Parameters */

/* $ 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. */


/*     Include Section:  EK Data Page Parameters */

/*        ekfilpar.inc  Version 1  03-APR-1995 (NJB) */

/*     These parameters apply to EK files using architecture 4. */
/*     These files use a paged DAS file as their underlying file */
/*     structure. */

/*     In paged DAS EK files, data pages are structured:  they contain */
/*     metadata as well as data.  The metadata is located in the last */
/*     few addresses of each page, so as to interfere as little as */
/*     possible with calculation of data addresses. */

/*     Each data page belongs to exactly one segment.  Some bookkeeping */
/*     information, such as record pointers, is also stored in data */
/*     pages. */

/*     Each page contains a forward pointer that allows rapid lookup */
/*     of data items that span multiple pages.  Each page also keeps */
/*     track of the current number of links from its parent segment */
/*     to the page.  Link counts enable pages to `know' when they */
/*     are no longer in use by a segment; unused pages are deallocated */
/*     and returned to the free list. */

/*     The parameters in this include file depend on the parameters */
/*     declared in the include file ekpage.inc.  If those parameters */
/*     change, this file must be updated.  The specified parameter */
/*     declarations we need from that file are: */

/*        INTEGER               PGSIZC */
/*        PARAMETER           ( PGSIZC = 1024 ) */

/*        INTEGER               PGSIZD */
/*        PARAMETER           ( PGSIZD = 128 ) */

/*        INTEGER               PGSIZI */
/*        PARAMETER           ( PGSIZI = 256 ) */



/*     Character pages use an encoding mechanism to represent integer */
/*     metadata.  Each integer is encoded in five consecutive */
/*     characters. */


/*     Character data page parameters: */


/*     Size of encoded integer: */


/*     Usable page size: */


/*     Location of character forward pointer: */


/*     Location of character link count: */


/*     Double precision data page parameters: */

/*     Usable page size: */


/*     Location of d.p. forward pointer: */


/*     Location of d.p. link count: */


/*     Integer data page parameters: */

/*     Usable page size: */


/*     Location of integer forward pointer: */


/*     Location of integer link count: */


/*     End Include Section:  EK Data Page Parameters */

/* $ 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. */


/*     Include Section:  EK Das Paging Parameters */

/*        ekpage.inc  Version 4    25-AUG-1995 (NJB) */



/*     The EK DAS paging system makes use of the integer portion */
/*     of an EK file's DAS address space to store the few numbers */
/*     required to describe the system's state.  The allocation */
/*     of DAS integer addresses is shown below. */


/*                       DAS integer array */

/*        +--------------------------------------------+ */
/*        |            EK architecture code            |  Address = 1 */
/*        +--------------------------------------------+ */
/*        |      Character page size (in DAS words)    | */
/*        +--------------------------------------------+ */
/*        |        Character page base address         | */
/*        +--------------------------------------------+ */
/*        |      Number of character pages in file     | */
/*        +--------------------------------------------+ */
/*        |   Number of character pages on free list   | */
/*        +--------------------------------------------+ */
/*        |      Character free list head pointer      |  Address = 6 */
/*        +--------------------------------------------+ */
/*        |                                            |  Addresses = */
/*        |           Metadata for d.p. pages          |    7--11 */
/*        |                                            | */
/*        +--------------------------------------------+ */
/*        |                                            |  Addresses = */
/*        |         Metadata for integer pages         |    12--16 */
/*        |                                            | */
/*        +--------------------------------------------+ */
/*                              . */
/*                              . */
/*                              . */
/*        +--------------------------------------------+ */
/*        |                                            |  End Address = */
/*        |                Unused space                |  integer page */
/*        |                                            |  end */
/*        +--------------------------------------------+ */
/*        |                                            |  Start Address = */
/*        |             First integer page             |  integer page */
/*        |                                            |  base */
/*        +--------------------------------------------+ */
/*                              . */
/*                              . */
/*                              . */
/*        +--------------------------------------------+ */
/*        |                                            | */
/*        |              Last integer page             | */
/*        |                                            | */
/*        +--------------------------------------------+ */

/*     The following parameters indicate positions of elements in the */
/*     paging system metadata array: */



/*     Number of metadata items per data type: */


/*     Character metadata indices: */


/*     Double precision metadata indices: */


/*     Integer metadata indices: */


/*     Size of metadata area: */


/*     Page sizes, in units of DAS words of the appropriate type: */


/*     Default page base addresses: */


/*     End Include Section:  EK Das Paging Parameters */

/* $ 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. */


/*     Include Section:  EK Segment Descriptor Parameters */

/*        eksegdsc.inc  Version 8  06-NOV-1995 (NJB) */


/*     All `base addresses' referred to below are the addresses */
/*     *preceding* the item the base applies to.  This convention */
/*     enables simplied address calculations in many cases. */

/*     Size of segment descriptor.  Note:  the include file ekcoldsc.inc */
/*     must be updated if this parameter is changed.  The parameter */
/*     CDOFF in that file should be kept equal to SDSCSZ. */


/*     Index of the segment type code: */


/*     Index of the segment's number.  This number is the segment's */
/*     index in the list of segments contained in the EK to which */
/*     the segment belongs. */


/*     Index of the DAS integer base address of the segment's integer */
/*     meta-data: */


/*     Index of the DAS character base address of the table name: */


/*     Index of the segment's column count: */


/*     Index of the segment's record count: */


/*     Index of the root page number of the record tree: */


/*     Index of the root page number of the character data page tree: */


/*     Index of the root page number of the double precision data page */
/*     tree: */


/*     Index of the root page number of the integer data page tree: */


/*     Index of the `modified' flag: */


/*     Index of the `initialized' flag: */


/*     Index of the shadowing flag: */


/*     Index of the companion file handle: */


/*     Index of the companion segment number: */


/*     The next three items are, respectively, the page numbers of the */
/*     last character, d.p., and integer data pages allocated by the */
/*     segment: */


/*     The next three items are, respectively, the page-relative */
/*     indices of the last DAS word in use in the segment's */
/*     last character, d.p., and integer data pages: */


/*     Index of the DAS character base address of the column name list: */


/*     The last descriptor element is reserved for future use.  No */
/*     parameter is defined to point to this location. */


/*     End Include Section:  EK Segment Descriptor Parameters */

/* $ 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. */


/*     Include Section:  EK Data Types */

/*        ektype.inc Version 1  27-DEC-1994 (NJB) */


/*     Within the EK system, data types of EK column contents are */
/*     represented by integer codes.  The codes and their meanings */
/*     are listed below. */

/*     Integer codes are also used within the DAS system to indicate */
/*     data types; the EK system makes no assumptions about compatibility */
/*     between the codes used here and those used in the DAS system. */


/*     Character type: */


/*     Double precision type: */


/*     Integer type: */


/*     `Time' type: */

/*     Within the EK system, time values are represented as ephemeris */
/*     seconds past J2000 (TDB), and double precision numbers are used */
/*     to store these values.  However, since time values require special */
/*     treatment both on input and output, and since the `TIME' column */
/*     has a special role in the EK specification and code, time values */
/*     are identified as a type distinct from double precision numbers. */


/*     End Include Section:  EK Data Types */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   Handle attached to EK file. */
/*     SEGDSC     I   Segment descriptor. */
/*     COLDSC     I   Column descriptor. */
/*     RECPTR     I   Record pointer. */
/*     DVAL       O   Double precision value in column entry. */
/*     ISNULL     O   Flag indicating whether column entry is null. */

/* $ Detailed_Input */

/*     HANDLE         is an EK file handle. */

/*     SEGDSC         is the descriptor of the segment from which data is */
/*                    to be read. */

/*     COLDSC         is the descriptor of the column from which data is */
/*                    to be read. */

/*     RECPTR         is a pointer to the record containing the column */
/*                    entry to be written.  For class 8 columns, record */
/*                    pointers are identical to record numbers. */

/* $ Detailed_Output */

/*     DVAL           is the value read from the specified column entry. */

/*     ISNULL         is a logical flag indicating whether the entry is */
/*                    null. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)  If HANDLE is invalid, the error will be diagnosed by routines */
/*         called by this routine. */

/*     2)  If the ordinal position of the column specified by COLDSC */
/*         is out of range, the error SPICE(INVALIDINDEX) is signalled. */

/*     3)  If an I/O error occurs while reading the indicated file, */
/*         the error will be diagnosed by routines called by this */
/*         routine. */

/* $ Files */

/*     See the EK Required Reading for a discussion of the EK file */
/*     format. */

/* $ Particulars */

/*     This routine is a utility for reading data from class 8 columns. */

/* $ Examples */

/*     See EKRCED. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */

/* $ Version */

/* -    Beta Version 1.0.0, 09-NOV-1995 (NJB) */

/* -& */

/*     Non-SPICELIB functions */


/*     Local variables */


/*     Use discovery check-in. */


/*     Make sure the column exists. */

    ncols = segdsc[4];
    colidx = coldsc[8];
    metloc = coldsc[9];
    nullok = coldsc[7] == 1;
    if (colidx < 1 || colidx > ncols) {
	recno = zzekrp2n_(handle, &segdsc[1], recptr);
	dashlu_(handle, &unit);
	chkin_("ZZEKRD08", (ftnlen)8);
	setmsg_("Column index = #; valid range is 1:#.", (ftnlen)37);
	errint_("#", &colidx, (ftnlen)1);
	errint_("#", &nrec, (ftnlen)1);
	sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
	chkout_("ZZEKRD08", (ftnlen)8);
	return 0;
    }

/*     Read the metadata block.  There are two items in the block: */

/*        1) The base address of the first page of the data */
/*        2) The base address of the null flag array, if nulls are */
/*           permitted. */

    i__1 = metloc + 1;
    i__2 = metloc + 2;
    dasrdi_(handle, &i__1, &i__2, mdat);
    datbas = mdat[0];
    nflbas = mdat[1];

/*     If null values are permitted, the first step is to get */
/*     the null flag for the value of interest.  Compute the */
/*     address of this flag. */

/*     There are CPSIZE null flags per page, and each page has size */
/*     PGSIZC.  The null flags start at the beginning of the page. */

    if (nullok) {
	q = (*recptr - 1) / 1014;
	r__ = *recptr - q * 1014;
	offset = r__ + (q << 10);
	addrss = nflbas + offset;
	dasrdc_(handle, &addrss, &addrss, &c__1, &c__1, cflag, (ftnlen)1);
	*isnull = *(unsigned char *)cflag == 'T';
	if (*isnull) {
	    return 0;
	}
    }

/*     If we're still here, we'll read the data value. */

    *isnull = FALSE_;

/*     The address calculation for the value is analogous to that */
/*     for the null flag. */

    q = (*recptr - 1) / 126;
    r__ = *recptr - q * 126;
    offset = r__ + (q << 7);
    addrss = datbas + offset;
    dasrdd_(handle, &addrss, &addrss, dval);
    return 0;
} /* zzekrd08_ */
コード例 #15
0
ファイル: lgrind.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure LGRIND (Lagrange polynomial interpolation with derivative) */
/* Subroutine */ int lgrind_(integer *n, doublereal *xvals, doublereal *yvals,
	 doublereal *work, doublereal *x, doublereal *p, doublereal *dp)
{
    /* System generated locals */
    integer xvals_dim1, yvals_dim1, work_dim1, work_offset, i__1, i__2, i__3, 
	    i__4, i__5, i__6, i__7;

    /* Builtin functions */
    integer s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer i__, j;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    doublereal denom;
    extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
    doublereal c1, c2;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *, 
	    ftnlen);
    extern logical return_(void);

/* $ Abstract */

/*     Evaluate a Lagrange interpolating polynomial for a specified */
/*     set of coordinate pairs, at a specified abscissa value. */
/*     Return the value of both polynomial and derivative. */

/* $ 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 */

/*     INTERPOLATION */
/*     POLYNOMIAL */

/* $ Declarations */
/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     N          I   Number of points defining the polynomial. */
/*     XVALS      I   Abscissa values. */
/*     YVALS      I   Ordinate values. */
/*     WORK      I-O  Work space array. */
/*     X          I   Point at which to interpolate the polynomial. */
/*     P          O   Polynomial value at X. */
/*     DP         O   Polynomial derivative at X. */

/* $ Detailed_Input */

/*     N              is the number of points defining the polynomial. */
/*                    The arrays XVALS and YVALS contain N elements. */


/*     XVALS, */
/*     YVALS          are arrays of abscissa and ordinate values that */
/*                    together define N ordered pairs.  The set of points */

/*                       ( XVALS(I), YVALS(I) ) */

/*                    define the Lagrange polynomial used for */
/*                    interpolation.  The elements of XVALS must be */
/*                    distinct and in increasing order. */


/*     WORK           is an N x 2 work space array, where N is the same */
/*                    dimension as that of XVALS and YVALS.  It is used */
/*                    by this routine as a scratch area to hold */
/*                    intermediate results. */


/*     X              is the abscissa value at which the interpolating */
/*                    polynomial is to be evaluated. */

/* $ Detailed_Output */

/*     P              is the value at X of the unique polynomial of */
/*                    degree N-1 that fits the points in the plane */
/*                    defined by XVALS and YVALS. */

/*     DP             is the derivative at X of the interpolating */
/*                    polynomial described above. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)  If any two elements of the array XVALS are equal the error */
/*         SPICE(DIVIDEBYZERO) will be signaled. */

/*     2)  If N is less than 1, the error SPICE(INVALIDSIZE) is */
/*         signaled. */

/*     3)  This routine does not attempt to ward off or diagnose */
/*         arithmetic overflows. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     Given a set of N distinct abscissa values and corresponding */
/*     ordinate values, there is a unique polynomial of degree N-1, often */
/*     called the `Lagrange polynomial', that fits the graph defined by */
/*     these values.  The Lagrange polynomial can be used to interpolate */
/*     the value of a function at a specified point, given a discrete */
/*     set of values of the function. */

/*     Users of this routine must choose the number of points to use */
/*     in their interpolation method.  The authors of Reference [1] have */
/*     this to say on the topic: */

/*        Unless there is solid evidence that the interpolating function */
/*        is close in form to the true function f, it is a good idea to */
/*        be cautious about high-order interpolation.  We */
/*        enthusiastically endorse interpolations with 3 or 4 points, we */
/*        are perhaps tolerant of 5 or 6; but we rarely go higher than */
/*        that unless there is quite rigorous monitoring of estimated */
/*        errors. */

/*     The same authors offer this warning on the use of the */
/*     interpolating function for extrapolation: */

/*        ...the dangers of extrapolation cannot be overemphasized: */
/*        An interpolating function, which is perforce an extrapolating */
/*        function, will typically go berserk when the argument x is */
/*        outside the range of tabulated values by more than the typical */
/*        spacing of tabulated points. */

/* $ Examples */

/*     1)  Fit a cubic polynomial through the points */

/*             ( -1, -2 ) */
/*             (  0, -7 ) */
/*             (  1, -8 ) */
/*             (  3, 26 ) */

/*         and evaluate this polynomial at x = 2. */


/*            PROGRAM TEST_LGRIND */

/*            DOUBLE PRECISION      P */
/*            DOUBLE PRECISION      DP */
/*            DOUBLE PRECISION      XVALS (4) */
/*            DOUBLE PRECISION      YVALS (4) */
/*            DOUBLE PRECISION      WORK  (4,2) */
/*            INTEGER               N */

/*            N         =   4 */

/*            XVALS(1)  =  -1 */
/*            XVALS(2)  =   0 */
/*            XVALS(3)  =   1 */
/*            XVALS(4)  =   3 */

/*            YVALS(1)  =  -2 */
/*            YVALS(2)  =  -7 */
/*            YVALS(3)  =  -8 */
/*            YVALS(4)  =  26 */

/*            CALL LGRIND ( N, XVALS, YVALS, WORK, 2.D0, P, DP ) */

/*            WRITE (*,*) 'P, DP = ', P, DP */
/*            END */


/*        The returned value of P should be 1.D0, since the */
/*        unique cubic polynomial that fits these points is */

/*                       3       2 */
/*           f(x)   =   x   +  2x  - 4x  - 7 */


/*        The returned value of DP should be 1.6D1, since the */
/*        derivative of f(x) is */

/*             '         2 */
/*           f (x)  =  3x   +  4x  - 4 */


/*        We also could have invoked LGRIND with the reference */

/*           CALL LGRIND ( N, XVALS, YVALS, YVALS, 2.D0, P, DP ) */

/*        if we wished to; in this case YVALS would have been */
/*        modified on output. */


/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     [1]  "Numerical Recipes---The Art of Scientific Computing" by */
/*           William H. Press, Brian P. Flannery, Saul A. Teukolsky, */
/*           William T. Vetterling (see sections 3.0 and 3.1). */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.1, 10-JAN-2014 (NJB) */

/*        Updated description of the workspace array: now the array WORK */
/*        is not described as being allowed to coincide with the input */
/*        YVALS. Such overlap would be a violation of the ANSI Fortran */
/*        77 standard. Corrected a spelling error in header */
/*        documentation. */

/* -    SPICELIB Version 1.0.0, 20-AUG-2002 (NJB) */

/* -& */
/* $ Index_Entries */

/*     interpolate function using Lagrange polynomial */
/*     Lagrange interpolation */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Check in only if an error is detected. */

    /* Parameter adjustments */
    work_dim1 = *n;
    work_offset = work_dim1 + 1;
    yvals_dim1 = *n;
    xvals_dim1 = *n;

    /* Function Body */
    if (return_()) {
	return 0;
    }

/*     No data, no interpolation. */

    if (*n < 1) {
	chkin_("LGRIND", (ftnlen)6);
	setmsg_("Array size must be positive; was #.", (ftnlen)35);
	errint_("#", n, (ftnlen)1);
	sigerr_("SPICE(INVALIDSIZE)", (ftnlen)18);
	chkout_("LGRIND", (ftnlen)6);
	return 0;
    }

/*     We're going to compute the value of our interpolating polynomial */
/*     at X by taking advantage of a recursion relation between */
/*     Lagrange polynomials of order n+1 and order n.  The method works */
/*     as follows: */

/*        Define */

/*           P               (x) */
/*            i(i+1)...(i+j) */

/*        to be the unique Lagrange polynomial that interpolates our */
/*        input function at the abscissa values */

/*           x ,  x   , ... x   . */
/*            i    i+1       i+j */


/*        Then we have the recursion relation */

/*           P              (x)  = */
/*            i(i+1)...(i+j) */

/*                                  x - x */
/*                                   i */
/*                                 -----------  *  P                (x) */
/*                                  x - x           (i+1)...(i+j) */
/*                                   i   i+j */


/*                                  x  -  x */
/*                                         i+j */
/*                               + -----------  *  P                (x) */
/*                                  x  -  x         i(i+1)...(i+j-1) */
/*                                   i     i+j */


/*        Repeated application of this relation allows us to build */
/*        successive columns, in left-to-right order, of the */
/*        triangular table */


/*           P (x) */
/*            1 */
/*                    P  (x) */
/*                     12 */
/*           P (x)             P   (x) */
/*            2                 123 */
/*                    P  (x) */
/*                     23               . */
/*                             P   (x) */
/*           .                  234            . */
/*           . */
/*           .        .                               . */
/*                    . */
/*                    .        .                           P      (x) */
/*                             .                      .     12...N */
/*                             . */
/*                                             . */

/*                                      . */


/*                             P           (x) */
/*                              (N-2)(N-1)N */
/*                    P     (x) */
/*                     (N-1)N */
/*           P (x) */
/*            N */


/*        and after N-1 steps arrive at our desired result, */


/*           P       (x). */
/*            12...N */


/*     The computation is easier to do than to describe. */


/*     We'll use the scratch array WORK to contain the current column of */
/*     our interpolation table.  To start out with, WORK(I) will contain */

/*        P (x). */
/*         I */

/*     For columns 2...N of the table, we'll also carry along the */
/*     derivative at X of each interpolating polynomial.  This will */
/*     allow us to find the derivative of the Lagrange polynomial */
/*     at X. */

    i__1 = *n;
    for (i__ = 1; i__ <= i__1; ++i__) {
	work[(i__2 = i__ + work_dim1 - work_offset) < work_dim1 << 1 && 0 <= 
		i__2 ? i__2 : s_rnge("work", i__2, "lgrind_", (ftnlen)381)] = 
		yvals[(i__3 = i__ - 1) < yvals_dim1 && 0 <= i__3 ? i__3 : 
		s_rnge("yvals", i__3, "lgrind_", (ftnlen)381)];
	work[(i__2 = i__ + (work_dim1 << 1) - work_offset) < work_dim1 << 1 &&
		 0 <= i__2 ? i__2 : s_rnge("work", i__2, "lgrind_", (ftnlen)
		382)] = 0.;
    }

/*     Compute columns 2 through N of the table.  Note that DENOM must */
/*     be non-zero, or else a divide-by-zero error will occur. */

    i__1 = *n - 1;
    for (j = 1; j <= i__1; ++j) {
	i__2 = *n - j;
	for (i__ = 1; i__ <= i__2; ++i__) {
	    denom = xvals[(i__3 = i__ - 1) < xvals_dim1 && 0 <= i__3 ? i__3 : 
		    s_rnge("xvals", i__3, "lgrind_", (ftnlen)394)] - xvals[(
		    i__4 = i__ + j - 1) < xvals_dim1 && 0 <= i__4 ? i__4 : 
		    s_rnge("xvals", i__4, "lgrind_", (ftnlen)394)];
	    if (denom == 0.) {
		chkin_("LGRIND", (ftnlen)6);
		setmsg_("XVALS(#) = XVALS(#) = #", (ftnlen)23);
		errint_("#", &i__, (ftnlen)1);
		i__3 = i__ + j;
		errint_("#", &i__3, (ftnlen)1);
		errdp_("#", &xvals[(i__3 = i__ - 1) < xvals_dim1 && 0 <= i__3 
			? i__3 : s_rnge("xvals", i__3, "lgrind_", (ftnlen)402)
			], (ftnlen)1);
		sigerr_("SPICE(DIVIDEBYZERO)", (ftnlen)19);
		chkout_("LGRIND", (ftnlen)6);
		return 0;
	    }
	    c1 = *x - xvals[(i__3 = i__ + j - 1) < xvals_dim1 && 0 <= i__3 ? 
		    i__3 : s_rnge("xvals", i__3, "lgrind_", (ftnlen)409)];
	    c2 = xvals[(i__3 = i__ - 1) < xvals_dim1 && 0 <= i__3 ? i__3 : 
		    s_rnge("xvals", i__3, "lgrind_", (ftnlen)410)] - *x;

/*           Use the chain rule to compute the derivatives.  Do this */
/*           before computing the function value, because the latter */
/*           computation will overwrite the first column of WORK. */

	    work[(i__3 = i__ + (work_dim1 << 1) - work_offset) < work_dim1 << 
		    1 && 0 <= i__3 ? i__3 : s_rnge("work", i__3, "lgrind_", (
		    ftnlen)417)] = (c1 * work[(i__4 = i__ + (work_dim1 << 1) 
		    - work_offset) < work_dim1 << 1 && 0 <= i__4 ? i__4 : 
		    s_rnge("work", i__4, "lgrind_", (ftnlen)417)] + c2 * work[
		    (i__5 = i__ + 1 + (work_dim1 << 1) - work_offset) < 
		    work_dim1 << 1 && 0 <= i__5 ? i__5 : s_rnge("work", i__5, 
		    "lgrind_", (ftnlen)417)] + (work[(i__6 = i__ + work_dim1 
		    - work_offset) < work_dim1 << 1 && 0 <= i__6 ? i__6 : 
		    s_rnge("work", i__6, "lgrind_", (ftnlen)417)] - work[(
		    i__7 = i__ + 1 + work_dim1 - work_offset) < work_dim1 << 
		    1 && 0 <= i__7 ? i__7 : s_rnge("work", i__7, "lgrind_", (
		    ftnlen)417)])) / denom;

/*           Compute the Ith entry in the Jth column. */

	    work[(i__3 = i__ + work_dim1 - work_offset) < work_dim1 << 1 && 0 
		    <= i__3 ? i__3 : s_rnge("work", i__3, "lgrind_", (ftnlen)
		    423)] = (c1 * work[(i__4 = i__ + work_dim1 - work_offset) 
		    < work_dim1 << 1 && 0 <= i__4 ? i__4 : s_rnge("work", 
		    i__4, "lgrind_", (ftnlen)423)] + c2 * work[(i__5 = i__ + 
		    1 + work_dim1 - work_offset) < work_dim1 << 1 && 0 <= 
		    i__5 ? i__5 : s_rnge("work", i__5, "lgrind_", (ftnlen)423)
		    ]) / denom;
	}
    }

/*     Our results are sitting in WORK(1,1) and WORK(1,2) at this point. */

    *p = work[(i__1 = work_dim1 + 1 - work_offset) < work_dim1 << 1 && 0 <= 
	    i__1 ? i__1 : s_rnge("work", i__1, "lgrind_", (ftnlen)432)];
    *dp = work[(i__1 = (work_dim1 << 1) + 1 - work_offset) < work_dim1 << 1 &&
	     0 <= i__1 ? i__1 : s_rnge("work", i__1, "lgrind_", (ftnlen)433)];
    return 0;
} /* lgrind_ */
コード例 #16
0
ファイル: gfrfov.c プロジェクト: TomCrowley-ME/me_sim_test
/* $Procedure      GFRFOV ( GF, is ray in FOV? ) */
/* Subroutine */ int gfrfov_(char *inst, doublereal *raydir, char *rframe, 
	char *abcorr, char *obsrvr, doublereal *step, doublereal *cnfine, 
	doublereal *result, ftnlen inst_len, ftnlen rframe_len, ftnlen 
	abcorr_len, ftnlen obsrvr_len)
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    extern /* Subroutine */ int chkin_(char *, ftnlen), errdp_(char *, 
	    doublereal *, ftnlen);
    extern integer sized_(doublereal *);
    extern logical gfbail_();
    extern /* Subroutine */ int gfrefn_(), gfrepf_(), gfrepi_();
    extern /* Subroutine */ int gffove_(char *, char *, doublereal *, char *, 
	    char *, char *, char *, doublereal *, U_fp, U_fp, logical *, U_fp,
	     U_fp, U_fp, logical *, L_fp, doublereal *, doublereal *, ftnlen, 
	    ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);
    extern /* Subroutine */ int gfrepu_(), gfstep_();
    extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *, 
	    integer *, ftnlen), sigerr_(char *, ftnlen);
    extern logical return_(void);
    extern /* Subroutine */ int chkout_(char *, ftnlen), gfsstp_(doublereal *)
	    ;

/* $ Abstract */

/*     Determine time intervals when a specified ray intersects the */
/*     space bounded by the field-of-view (FOV) of a specified */
/*     instrument. */

/* $ 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 */

/*     CK */
/*     FRAMES */
/*     GF */
/*     KERNEL */
/*     NAIF_IDS */
/*     PCK */
/*     SPK */
/*     TIME */
/*     WINDOWS */

/* $ Keywords */

/*     EVENT */
/*     FOV */
/*     GEOMETRY */
/*     INSTRUMENT */
/*     SEARCH */
/*     WINDOW */

/* $ Declarations */
/* $ Abstract */

/*     This file contains public, global parameter declarations */
/*     for the SPICELIB Geometry Finder (GF) subsystem. */

/* $ 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 */

/*     GF */

/* $ Keywords */

/*     GEOMETRY */
/*     ROOT */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */
/*     L.E. Elson        (JPL) */
/*     E.D. Wright       (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 08-SEP-2009 (EDW) */

/*       Added NWRR parameter. */
/*       Added NWUDS parameter. */

/* -    SPICELIB Version 1.0.0, 21-FEB-2009 (NJB) (LSE) (EDW) */

/* -& */

/*     Root finding parameters: */

/*     CNVTOL is the default convergence tolerance used by the */
/*     high-level GF search API routines. This tolerance is */
/*     used to terminate searches for binary state transitions: */
/*     when the time at which a transition occurs is bracketed */
/*     by two times that differ by no more than CNVTOL, the */
/*     transition time is considered to have been found. */

/*     Units are TDB seconds. */


/*     NWMAX is the maximum number of windows allowed for user-defined */
/*     workspace array. */

/*        DOUBLE PRECISION      WORK   ( LBCELL : MW, NWMAX ) */

/*     Currently no more than twelve windows are required; the three */
/*     extra windows are spares. */

/*     Callers of GFEVNT can include this file and use the parameter */
/*     NWMAX to declare the second dimension of the workspace array */
/*     if necessary. */


/*     Callers of GFIDST should declare their workspace window */
/*     count using NWDIST. */


/*     Callers of GFSEP should declare their workspace window */
/*     count using NWSEP. */


/*     Callers of GFRR should declare their workspace window */
/*     count using NWRR. */


/*     Callers of GFUDS should declare their workspace window */
/*     count using NWUDS. */


/*     ADDWIN is a parameter used to expand each interval of the search */
/*     (confinement) window by a small amount at both ends in order to */
/*     accommodate searches using equality constraints. The loaded */
/*     kernel files must accommodate these expanded time intervals. */


/*     FRMNLN is a string length for frame names. */


/*     NVRMAX is the maximum number of vertices if FOV type is "POLYGON" */


/*     FOVTLN -- maximum length for FOV string. */


/*     Specify the character strings that are allowed in the */
/*     specification of field of view shapes. */


/*     Character strings that are allowed in the */
/*     specification of occultation types: */


/*     Occultation target shape specifications: */


/*     Specify the number of supported occultation types and occultation */
/*     type string length: */


/*     Instrument field-of-view (FOV) parameters */

/*     Maximum number of FOV boundary vectors: */


/*     FOV shape parameters: */

/*        circle */
/*        ellipse */
/*        polygon */
/*        rectangle */


/*     End of file gf.inc. */

/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  -------------------------------------------------- */
/*     MARGIN     P   Minimum complement of FOV cone angle. */
/*     LBCELL     P   SPICE Cell lower bound. */
/*     CNVTOL     P   Convergence tolerance. */
/*     MAXVRT     P   Maximum number of FOV boundary vertices. */
/*     INST       I   Name of the instrument. */
/*     RAYDIR     I   Ray's direction vector. */
/*     RFRAME     I   Reference frame of ray's direction vector. */
/*     ABCORR     I   Aberration correction flag. */
/*     OBSRVR     I   Name of the observing body. */
/*     STEP       I   Step size in seconds for finding FOV events. */
/*     CNFINE     I   SPICE window to which the search is restricted. */
/*     RESULT     O   SPICE window containing results. */


/* $ Detailed_Input */


/*     INST       indicates the name of an instrument, such as a */
/*                spacecraft-mounted framing camera, the field of view */
/*                (FOV) of which is to be used for an target intersection */
/*                search: the direction from the observer to a target */
/*                is represented by a ray, and times when the specified */
/*                ray intersects the region of space bounded by the FOV */
/*                are sought. */

/*                The position of the instrument designated by INST is */
/*                considered to coincide with that of the ephemeris */
/*                object designated by the input argument OBSRVR (see */
/*                description below). */

/*                INST must have a corresponding NAIF ID and a frame */
/*                defined, as is normally done in a frame kernel. It */
/*                must also have an associated reference frame and a FOV */
/*                shape, boresight and boundary vertices (or reference */
/*                vector and reference angles) defined, as is usually */
/*                done in an instrument kernel. */

/*                See the header of the SPICELIB routine GETFOV for a */
/*                description of the required parameters associated with */
/*                an instrument. */


/*     RAYDIR     is the direction vector associated with a ray */
/*                representing a target. The ray emanates from the */
/*                location of the ephemeris object designated by the */
/*                input argument OBSRVR and is expressed relative to the */
/*                reference frame designated by RFRAME (see descriptions */
/*                below). */


/*     RFRAME     is the name of the reference frame associated with */
/*                the input ray's direction vector RAYDIR. */

/*                Since light time corrections are not supported for */
/*                rays, the orientation of the frame is always evaluated */
/*                at the epoch associated with the observer, as opposed */
/*                to the epoch associated with the light-time corrected */
/*                position of the frame center. */

/*                Case and leading or trailing blanks bracketing a */
/*                non-blank frame name are not significant in the string */
/*                RFRAME. */


/*     ABCORR     indicates the aberration corrections to be applied */
/*                when computing the ray's direction. */

/*                The supported aberration correction options are */

/*                   'NONE'          No correction. */
/*                   'S'             Stellar aberration correction, */
/*                                   reception case. */
/*                   'XS'            Stellar aberration correction, */
/*                                   transmission case. */

/*                For detailed information, see the geometry finder */
/*                required reading, gf.req. */

/*                Case, leading and trailing blanks are not significant */
/*                in the string ABCORR. */


/*     OBSRVR     is the name of the body from which the target */
/*                represented by RAYDIR is observed. The instrument */
/*                designated by INST is treated as if it were co-located */
/*                with the observer. */
/*                Optionally, you may supply the integer NAIF ID code */
/*                for the body as a string. */

/*                Case and leading or trailing blanks are not */
/*                significant in the string OBSRVR. */


/*     STEP       is the step size to be used in the search. STEP must */
/*                be shorter than any interval, within the confinement */
/*                window, over which the specified condition is met. In */
/*                other words, STEP must be shorter than the shortest */
/*                visibility event that the user wishes to detect. STEP */
/*                also must be shorter than the minimum duration */
/*                separating any two visibility events. However, STEP */
/*                must not be *too* short, or the search will take an */
/*                unreasonable amount of time. */

/*                The choice of STEP affects the completeness but not */
/*                the precision of solutions found by this routine; the */
/*                precision is controlled by the convergence tolerance. */
/*                See the discussion of the parameter CNVTOL for */
/*                details. */

/*                STEP has units of seconds. */


/*     CNFINE     is a SPICE window that confines the time period over */
/*                which the specified search is conducted. CNFINE may */
/*                consist of a single interval or a collection of */
/*                intervals. */

/*                The endpoints of the time intervals comprising CNFINE */
/*                are interpreted as seconds past J2000 TDB. */

/*                See the Examples section below for a code example */
/*                that shows how to create a confinement window. */

/*                CNFINE must be initialized by the caller via the */
/*                SPICELIB routine SSIZED. */

/* $ Detailed_Output */


/*     RESULT     is a SPICE window representing the set of time */
/*                intervals, within the confinement period, when the */
/*                input ray is "visible"; that is, when the ray is */
/*                contained in the space bounded by the specified */
/*                instrument's field of view. */

/*                The endpoints of the time intervals comprising RESULT */
/*                are interpreted as seconds past J2000 TDB. */

/*                If RESULT is non-empty on input, its contents */
/*                will be discarded before GFRFOV conducts its */
/*                search. */

/* $ Parameters */

/*     LBCELL     is the lower bound for SPICE cell arrays. */

/*     CNVTOL     is the convergence tolerance used for finding */
/*                endpoints of the intervals comprising the result */
/*                window. CNVTOL is used to determine when binary */
/*                searches for roots should terminate: when a root is */
/*                bracketed within an interval of length CNVTOL; the */
/*                root is considered to have been found. */

/*                The accuracy, as opposed to precision, of roots found */
/*                by this routine depends on the accuracy of the input */
/*                data. In most cases, the accuracy of solutions will be */
/*                inferior to their precision. */

/*     MAXVRT     is the maximum number of vertices that may be used */
/*                to define the boundary of the specified instrument's */
/*                field of view. */

/*     MARGIN     is a small positive number used to constrain the */
/*                orientation of the boundary vectors of polygonal */
/*                FOVs. Such FOVs must satisfy the following constraints: */

/*                   1)  The boundary vectors must be contained within */
/*                       a right circular cone of angular radius less */
/*                       than than (pi/2) - MARGIN radians; in other */
/*                       words, there must be a vector A such that all */
/*                       boundary vectors have angular separation from */
/*                       A of less than (pi/2)-MARGIN radians. */

/*                   2)  There must be a pair of boundary vectors U, V */
/*                       such that all other boundary vectors lie in */
/*                       the same half space bounded by the plane */
/*                       containing U and V. Furthermore, all other */
/*                       boundary vectors must have orthogonal */
/*                       projections onto a specific plane normal to */
/*                       this plane (the normal plane contains the angle */
/*                       bisector defined by U and V) such that the */
/*                       projections have angular separation of at least */
/*                       2*MARGIN radians from the plane spanned by U */
/*                       and V. */

/*                 MARGIN is currently set to 1.D-12. */


/*     See INCLUDE file gf.inc for declarations and descriptions of */
/*     parameters used throughout the GF system. */

/* $ Exceptions */


/*     1)  In order for this routine to produce correct results, */
/*         the step size must be appropriate for the problem at hand. */
/*         Step sizes that are too large may cause this routine to miss */
/*         roots; step sizes that are too small may cause this routine */
/*         to run unacceptably slowly and in some cases, find spurious */
/*         roots. */

/*         This routine does not diagnose invalid step sizes, except */
/*         that if the step size is non-positive, the error */
/*         SPICE(INVALIDSTEPSIZE) will be signaled. */

/*     2)  Due to numerical errors, in particular, */

/*            - Truncation error in time values */
/*            - Finite tolerance value */
/*            - Errors in computed geometric quantities */

/*         it is *normal* for the condition of interest to not always be */
/*         satisfied near the endpoints of the intervals comprising the */
/*         result window. */

/*         The result window may need to be contracted slightly by the */
/*         caller to achieve desired results. The SPICE window routine */
/*         WNCOND can be used to contract the result window. */

/*     3)  If the observer's name cannot be mapped to an ID code, the */
/*         error SPICE(IDCODENOTFOUND) is signaled. */

/*     4)  If the aberration correction flag calls for light time */
/*         correction, the error SPICE(INVALIDOPTION) is signaled. */

/*     5)  If the ray's direction vector is zero, the error */
/*         SPICE(ZEROVECTOR) is signaled. */

/*     6)  If the instrument name INST does not have corresponding NAIF */
/*         ID code, the error will be diagnosed by a routine in the call */
/*         tree of this routine. */

/*     7)  If the FOV parameters of the instrument are not present in */
/*         the kernel pool, the error will be be diagnosed by routines */
/*         in the call tree of this routine. */

/*     8)  If the FOV boundary has more than MAXVRT vertices, the error */
/*         will be be diagnosed by routines in the call tree of this */
/*         routine. */

/*     9)  If the instrument FOV is polygonal, and this routine cannot */
/*         find a ray R emanating from the FOV vertex such that maximum */
/*         angular separation of R and any FOV boundary vector is within */
/*         the limit (pi/2)-MARGIN radians, the error will be diagnosed */
/*         by a routine in the call tree of this routine. If the FOV */
/*         is any other shape, the same error check will be applied with */
/*         the instrument boresight vector serving the role of R. */

/*     10) If the loaded kernels provide insufficient data to compute a */
/*         requested state vector, the error will be diagnosed by a */
/*         routine in the call tree of this routine. */

/*     11) If an error occurs while reading an SPK or other kernel file, */
/*         the error will be diagnosed by a routine in the call tree */
/*         of this routine. */

/*     12) If the output SPICE window RESULT has insufficient capacity */
/*         to contain the number of intervals on which the specified */
/*         visibility condition is met, the error will be diagnosed */
/*         by a routine in the call tree of this routine. If the result */
/*         window has size less than 2, the error SPICE(WINDOWTOOSMALL) */
/*         will be signaled by this routine. */

/* $ Files */

/*     Appropriate SPICE kernels must be loaded by the calling program */
/*     before this routine is called. */

/*     The following data are required: */

/*        - SPK data:  ephemeris data for the observer for the period */
/*          defined by the confinement window 'CNFINE' must be loaded. */
/*          If aberration corrections are used, the state of the */
/*          observer relative to the solar system barycenter must be */
/*          calculable from the available ephemeris data. Typically */
/*          ephemeris data are made available by loading one or more SPK */
/*          files via FURNSH. */

/*        - Data defining the reference frame associated with the */
/*          instrument designated by INST must be available in the kernel */
/*          pool. Additionally the name INST must be associated with an */
/*          ID code. Normally these data are  made available by loading */
/*          a frame kernel via FURNSH. */

/*        - IK data: the kernel pool must contain data such that */
/*          the SPICELIB routine GETFOV may be called to obtain */
/*          parameters for INST. Normally such data are provided by */
/*          an IK via FURNSH. */

/*     The following data may be required: */

/*        - CK data: if the instrument frame is fixed to a spacecraft, */
/*          at least one CK file will be needed to permit transformation */
/*          of vectors between that frame and the J2000 frame. */

/*        - SCLK data: if a CK file is needed, an associated SCLK */
/*          kernel is required to enable conversion between encoded SCLK */
/*          (used to time-tag CK data) and barycentric dynamical time */
/*          (TDB). */

/*        - Since the input ray direction may be expressed in any */
/*          frame, FKs, CKs, SCLK kernels, PCKs, and SPKs may be */
/*          required to map the direction to the J2000 frame. */

/*     Kernel data are normally loaded once per program run, NOT every */
/*     time this routine is called. */

/* $ Particulars */

/*     This routine determines a set of one or more time intervals when */
/*     the specified ray in contained within the field of view of a */
/*     specified instrument. We'll use the term "visibility event" to */
/*     designate such an appearance. The set of time intervals resulting */
/*     from the search is returned as a SPICE window. */

/*     This routine provides a simpler, but less flexible, interface */
/*     than does the SPICELIB routine GFFOVE for conducting searches for */
/*     visibility events. Applications that require support for progress */
/*     reporting, interrupt handling, non-default step or refinement */
/*     functions, or non-default convergence tolerance should call */
/*     GFFOVE rather than this routine. */

/*     Below we discuss in greater detail aspects of this routine's */
/*     solution process that are relevant to correct and efficient use */
/*     of this routine in user applications. */


/*     The Search Process */
/*     ================== */

/*     The search for visibility events is treated as a search for state */
/*     transitions: times are sought when the state of the ray */
/*     changes from "not visible" to "visible" or vice versa. */

/*     Step Size */
/*     ========= */

/*     Each interval of the confinement window is searched as follows: */
/*     first, the input step size is used to determine the time */
/*     separation at which the visibility state will be sampled. */
/*     Starting at the left endpoint of an interval, samples will be */
/*     taken at each step. If a state change is detected, a root has */
/*     been bracketed; at that point, the "root"--the time at which the */
/*     state change occurs---is found by a refinement process, for */
/*     example, via binary search. */

/*     Note that the optimal choice of step size depends on the lengths */
/*     of the intervals over which the visibility state is constant: */
/*     the step size should be shorter than the shortest visibility event */
/*     duration and the shortest period between visibility events, within */
/*     the confinement window. */

/*     Having some knowledge of the relative geometry of the ray and */
/*     observer can be a valuable aid in picking a reasonable step size. */
/*     In general, the user can compensate for lack of such knowledge by */
/*     picking a very short step size; the cost is increased computation */
/*     time. */

/*     Note that the step size is not related to the precision with which */
/*     the endpoints of the intervals of the result window are computed. */
/*     That precision level is controlled by the convergence tolerance. */


/*     Convergence Tolerance */
/*     ===================== */

/*     Once a root has been bracketed, a refinement process is used to */
/*     narrow down the time interval within which the root must lie. */
/*     This refinement process terminates when the location of the root */
/*     has been determined to within an error margin called the */
/*     "convergence tolerance." The convergence tolerance used by this */
/*     routine is set via the parameter CNVTOL. */

/*     The value of CNVTOL is set to a "tight" value so that the */
/*     tolerance doesn't become the limiting factor in the accuracy of */
/*     solutions found by this routine. In general the accuracy of input */
/*     data will be the limiting factor. */

/*     To use a different tolerance value, a lower-level GF routine such */
/*     as GFFOVE  must be called. Making the tolerance tighter than */
/*     CNVTOL is unlikely to be useful, since the results are unlikely */
/*     to be more accurate. Making the tolerance looser will speed up */
/*     searches somewhat, since a few convergence steps will be omitted. */
/*     However, in most cases, the step size is likely to have a much */
/*     greater effect on processing time than would the convergence */
/*     tolerance. */


/*     The Confinement Window */
/*     ====================== */

/*     The simplest use of the confinement window is to specify a time */
/*     interval within which a solution is sought. However, the */
/*     confinement window can, in some cases, be used to make searches */
/*     more efficient. Sometimes it's possible to do an efficient search */
/*     to reduce the size of the time period over which a relatively */
/*     slow search of interest must be performed. For an example, see */
/*     the program CASCADE in the GF Example Programs chapter of the GF */
/*     Required Reading, gf.req. */

/* $ Examples */


/*     The numerical results shown for these examples may differ across */
/*     platforms. The results depend on the SPICE kernels used as */
/*     input, the compiler and supporting libraries, and the machine */
/*     specific arithmetic implementation. */


/*     1) This example is an extension of example #1 in the */
/*        header of */

/*           GFTFOV */

/*        The problem statement for that example is */

/*           Search for times when Saturn's satellite Phoebe is within */
/*           the FOV of the Cassini narrow angle camera */
/*           (CASSINI_ISS_NAC). To simplify the problem, restrict the */
/*           search to a short time period where continuous Cassini bus */
/*           attitude data are available. */

/*           Use a step size of 10 seconds to reduce chances of missing */
/*           short visibility events. */

/*        Here we search the same confinement window for times when a */
/*        selected background star is visible. We use the FOV of the */
/*        Cassini ISS wide angle camera (CASSINI_ISS_WAC) to enhance the */
/*        probability of viewing the star. */

/*        The star we'll use has catalog number 6000 in the Hipparcos */
/*        Catalog. The star's J2000 right ascension and declination, */
/*        proper motion, and parallax are taken from that catalog. */

/*        Use the meta-kernel from the GFTFOV example: */


/*           KPL/MK */

/*           File name: gftfov_ex1.tm */

/*           This meta-kernel is intended to support operation of SPICE */
/*           example programs. The kernels shown here should not be */
/*           assumed to contain adequate or correct versions of data */
/*           required by SPICE-based user applications. */

/*           In order for an application to use this meta-kernel, the */
/*           kernels referenced here must be present in the user's */
/*           current working directory. */

/*           The names and contents of the kernels referenced */
/*           by this meta-kernel are as follows: */

/*              File name                     Contents */
/*              ---------                     -------- */
/*              naif0009.tls                  Leapseconds */
/*              cpck05Mar2004.tpc             Satellite orientation and */
/*                                            radii */
/*              981005_PLTEPH-DE405S.bsp      Planetary ephemeris */
/*              020514_SE_SAT105.bsp          Satellite ephemeris */
/*              030201AP_SK_SM546_T45.bsp     Spacecraft ephemeris */
/*              cas_v37.tf                    Cassini FK */
/*              04135_04171pc_psiv2.bc        Cassini bus CK */
/*              cas00084.tsc                  Cassini SCLK kernel */
/*              cas_iss_v09.ti                Cassini IK */


/*           \begindata */

/*              KERNELS_TO_LOAD = ( 'naif0009.tls', */
/*                                  'cpck05Mar2004.tpc', */
/*                                  '981005_PLTEPH-DE405S.bsp', */
/*                                  '020514_SE_SAT105.bsp', */
/*                                  '030201AP_SK_SM546_T45.bsp', */
/*                                  'cas_v37.tf', */
/*                                  '04135_04171pc_psiv2.bc', */
/*                                  'cas00084.tsc', */
/*                                  'cas_iss_v09.ti'            ) */
/*           \begintext */



/*        Example code begins here. */


/*           PROGRAM EX1 */
/*           IMPLICIT NONE */
/*     C */
/*     C     SPICELIB functions */
/*     C */
/*           DOUBLE PRECISION      J1950 */
/*           DOUBLE PRECISION      J2000 */
/*           DOUBLE PRECISION      JYEAR */
/*           DOUBLE PRECISION      RPD */

/*           INTEGER               WNCARD */

/*     C */
/*     C     Local parameters */
/*     C */
/*           CHARACTER*(*)         META */
/*           PARAMETER           ( META   = 'gftfov_ex1.tm' ) */

/*           CHARACTER*(*)         TIMFMT */
/*           PARAMETER           ( TIMFMT = */
/*          .      'YYYY-MON-DD HR:MN:SC.######::TDB (TDB)' ) */


/*           DOUBLE PRECISION      AU */
/*           PARAMETER           ( AU     = 149597870.693D0 ) */

/*           INTEGER               LBCELL */
/*           PARAMETER           ( LBCELL = -5 ) */

/*           INTEGER               MAXWIN */
/*           PARAMETER           ( MAXWIN = 10000 ) */

/*           INTEGER               CORLEN */
/*           PARAMETER           ( CORLEN = 10 ) */

/*           INTEGER               BDNMLN */
/*           PARAMETER           ( BDNMLN = 36 ) */

/*           INTEGER               FRNMLN */
/*           PARAMETER           ( FRNMLN = 32 ) */

/*           INTEGER               TIMLEN */
/*           PARAMETER           ( TIMLEN = 35 ) */

/*           INTEGER               LNSIZE */
/*           PARAMETER           ( LNSIZE = 80 ) */

/*     C */
/*     C     Local variables */
/*     C */
/*           CHARACTER*(CORLEN)    ABCORR */
/*           CHARACTER*(BDNMLN)    INST */
/*           CHARACTER*(LNSIZE)    LINE */
/*           CHARACTER*(BDNMLN)    OBSRVR */
/*           CHARACTER*(FRNMLN)    RFRAME */
/*           CHARACTER*(TIMLEN)    TIMSTR ( 2 ) */

/*           DOUBLE PRECISION      CNFINE ( LBCELL : MAXWIN ) */
/*           DOUBLE PRECISION      DEC */
/*           DOUBLE PRECISION      DECEPC */
/*           DOUBLE PRECISION      DECPM */
/*           DOUBLE PRECISION      DECDEG */
/*           DOUBLE PRECISION      DECDG0 */
/*           DOUBLE PRECISION      DTDEC */
/*           DOUBLE PRECISION      DTRA */
/*           DOUBLE PRECISION      ENDPT  ( 2 ) */
/*           DOUBLE PRECISION      ET0 */
/*           DOUBLE PRECISION      ET1 */
/*           DOUBLE PRECISION      LT */
/*           DOUBLE PRECISION      PARLAX */
/*           DOUBLE PRECISION      PLXDEG */
/*           DOUBLE PRECISION      POS    ( 3 ) */
/*           DOUBLE PRECISION      PSTAR  ( 3 ) */
/*           DOUBLE PRECISION      RA */
/*           DOUBLE PRECISION      RADEG */
/*           DOUBLE PRECISION      RADEG0 */
/*           DOUBLE PRECISION      RAEPC */
/*           DOUBLE PRECISION      RAPM */
/*           DOUBLE PRECISION      RAYDIR ( 3 ) */
/*           DOUBLE PRECISION      RESULT ( LBCELL : MAXWIN ) */
/*           DOUBLE PRECISION      RSTAR */
/*           DOUBLE PRECISION      STEPSZ */
/*           DOUBLE PRECISION      T */

/*           INTEGER               CATNO */
/*           INTEGER               I */
/*           INTEGER               J */
/*           INTEGER               N */

/*     C */
/*     C     Load kernels. */
/*     C */
/*           CALL FURNSH ( META ) */

/*     C */
/*     C     Initialize windows. */
/*     C */
/*           CALL SSIZED ( MAXWIN, CNFINE ) */
/*           CALL SSIZED ( MAXWIN, RESULT ) */

/*     C */
/*     C     Insert search time interval bounds into the */
/*     C     confinement window. */
/*     C */
/*           CALL STR2ET ( '2004 JUN 11 06:30:00 TDB', ET0 ) */
/*           CALL STR2ET ( '2004 JUN 11 12:00:00 TDB', ET1 ) */

/*           CALL WNINSD ( ET0, ET1, CNFINE ) */

/*     C */
/*     C     Initialize inputs for the search. */
/*     C */
/*           INST   = 'CASSINI_ISS_WAC' */

/*     C */
/*     C     Create a unit direction vector pointing from */
/*     c     observer to star. We'll assume the direction */
/*     C     is constant during the confinement window, and */
/*     C     we'll use et0 as the epoch at which to compute the */
/*     C     direction from the spacecraft to the star. */
/*     C */
/*     C     The data below are for the star with catalog */
/*     C     number 6000 in the Hipparcos catalog. Angular */
/*     C     units are degrees; epochs have units of Julian */
/*     C     years and have a reference epoch of J1950. */
/*     C     The reference frame is J2000. */
/*     C */
/*           CATNO  = 6000 */

/*           PLXDEG = 0.000001056D0 */

/*           RADEG0 = 19.290789927D0 */
/*           RAPM   = -0.000000720D0 */
/*           RAEPC  = 41.2000D0 */

/*           DECDG0 =  2.015271007D0 */
/*           DECPM  =  0.000001814D0 */
/*           DECEPC = 41.1300D0 */

/*           RFRAME = 'J2000' */

/*     C */
/*     C     Correct the star's direction for proper motion. */
/*     C */
/*     C     The argument t represents et0 as Julian years */
/*     C     past J1950. */
/*     C */
/*           T      =      ET0/JYEAR() */
/*          .         +  ( J2000()- J1950() ) / 365.25D0 */

/*           DTRA   = T - RAEPC */
/*           DTDEC  = T - DECEPC */

/*           RADEG  = RADEG0  +  DTRA  * RAPM */
/*           DECDEG = DECDG0  +  DTDEC * DECPM */

/*           RA     = RADEG  * RPD() */
/*           DEC    = DECDEG * RPD() */

/*           CALL RADREC ( 1.D0, RA, DEC, PSTAR ) */

/*     C */
/*     C     Correct star position for parallax applicable at */
/*     C     the Cassini orbiter's position. (The parallax effect */
/*     C     is negligible in this case; we're simply demonstrating */
/*     C     the computation.) */
/*     C */
/*           PARLAX = PLXDEG * RPD() */
/*           RSTAR  = AU / TAN(PARLAX) */

/*     C */
/*     C     Scale the star's direction vector by its distance from */
/*     C     the solar system barycenter. Subtract off the position */
/*     C     of the spacecraft relative to the solar system barycenter; */
/*     C     the result is the ray's direction vector. */
/*     C */
/*           CALL VSCLIP ( RSTAR, PSTAR ) */

/*           CALL SPKPOS ( 'CASSINI', ET0, 'J2000',  'NONE', */
/*          .              'SOLAR SYSTEM BARYCENTER', POS,  LT ) */

/*           CALL VSUB   ( PSTAR, POS, RAYDIR ) */

/*     C */
/*     C     Correct the star direction for stellar aberration when */
/*     C     we conduct the search. */
/*     C */
/*           ABCORR = 'S' */
/*           OBSRVR = 'CASSINI' */
/*           STEPSZ = 10.D0 */

/*           WRITE (*,*) ' ' */
/*           WRITE (*,*) 'Instrument:              '//INST */
/*           WRITE (*,*) 'Star''s catalog number:  ', CATNO */
/*           WRITE (*,*) ' ' */

/*     C */
/*     C     Perform the search. */
/*     C */
/*           CALL GFRFOV ( INST,   RAYDIR, RFRAME, ABCORR, */
/*          .              OBSRVR, STEPSZ, CNFINE, RESULT ) */

/*           N = WNCARD( RESULT ) */

/*           IF ( N .EQ. 0 ) THEN */

/*              WRITE (*,*) 'No FOV intersection found.' */

/*           ELSE */

/*              WRITE (*,*) */
/*          .   ' Visibility start time              Stop time' */

/*              DO I = 1, N */

/*                 CALL WNFETD ( RESULT, I, ENDPT(1), ENDPT(2) ) */

/*                 DO J = 1, 2 */
/*                    CALL TIMOUT ( ENDPT(J), TIMFMT, TIMSTR(J) ) */
/*                 END DO */

/*                 LINE( :3) = ' ' */
/*                 LINE(2: ) = TIMSTR(1) */
/*                 LINE(37:) = TIMSTR(2) */

/*                 WRITE (*,*) LINE */

/*              END DO */

/*           END IF */

/*           WRITE (*,*) ' ' */
/*           END */


/*        When this program was executed on a PC/Linux/g77 platform, the */
/*        output was: */


/*  Instrument:              CASSINI_ISS_WAC */
/*  Star's catalog number:   6000 */

/*   Visibility start time              Stop time */
/*   2004-JUN-11 06:30:00.000000 (TDB)  2004-JUN-11 12:00:00.000000 (TDB) */


/*     The star is visible throughout the confinement window. */


/* $ Restrictions */

/*     The kernel files to be used by GFRFOV must be loaded (normally via */
/*     the SPICELIB routine FURNSH) before GFRFOV is called. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman  (JPL) */
/*     L.S. Elson    (JPL) */
/*     E.D. Wright   (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.0  15-APR-2009 (NJB) (LSE) (EDW) */

/* -& */
/* $ Index_Entries */

/*     GF ray in instrument FOV search */

/* -& */
/* $ Revisions */

/*     None. */

/* -& */

/*     SPICELIB functions */


/*     External routines */


/*     Interrupt handler: */


/*     Routines to set step size, refine transition times */
/*     and report work: */


/*     Local parameters */


/*     Geometric quantity  bail switch: */


/*     Progress report switch: */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    }
    chkin_("GFRFOV", (ftnlen)6);

/*     Note to maintenance programmer: input exception checks */
/*     are delegated to GFFOVE. If the implementation of that */
/*     routine changes, or if this routine is modified to call */
/*     a different routine in place of GFFOVE, then the error */
/*     handling performed by GFFOVE will have to be performed */
/*     here or in a routine called by this routine. */

/*     Check the result window's size. */

    if (sized_(result) < 2) {
	setmsg_("Result window size must be at least 2 but was #.", (ftnlen)
		48);
	i__1 = sized_(result);
	errint_("#", &i__1, (ftnlen)1);
	sigerr_("SPICE(WINDOWTOOSMALL)", (ftnlen)21);
	chkout_("GFRFOV", (ftnlen)6);
	return 0;
    }

/*     Check step size. */

    if (*step <= 0.) {
	setmsg_("Step size must be positive but was #.", (ftnlen)37);
	errdp_("#", step, (ftnlen)1);
	sigerr_("SPICE(INVALIDSTEP)", (ftnlen)18);
	chkout_("GFRFOV", (ftnlen)6);
	return 0;
    }

/*     Set the step size. */

    gfsstp_(step);

/*     Look for solutions. */

    gffove_(inst, "RAY", raydir, " ", rframe, abcorr, obsrvr, &c_b13, (U_fp)
	    gfstep_, (U_fp)gfrefn_, &c_false, (U_fp)gfrepi_, (U_fp)gfrepu_, (
	    U_fp)gfrepf_, &c_false, (L_fp)gfbail_, cnfine, result, inst_len, (
	    ftnlen)3, (ftnlen)1, rframe_len, abcorr_len, obsrvr_len);
    chkout_("GFRFOV", (ftnlen)6);
    return 0;
} /* gfrfov_ */
コード例 #17
0
ファイル: zzspkflt.c プロジェクト: msanrivo/coft
/* $Procedure ZZSPKFLT ( SPK function, light time and rate ) */
/* Subroutine */ int zzspkflt_(S_fp trgsub, doublereal *et, char *ref, char *
	abcorr, doublereal *stobs, doublereal *starg, doublereal *lt, 
	doublereal *dlt, ftnlen ref_len, ftnlen abcorr_len)
{
    /* Initialized data */

    static logical pass1 = TRUE_;
    static char prvcor[5] = "     ";

    /* System generated locals */
    doublereal d__1, d__2, d__3, d__4;

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

    /* Local variables */
    doublereal dist;
    extern doublereal vdot_(doublereal *, doublereal *);
    static logical xmit;
    extern /* Subroutine */ int zzvalcor_(char *, logical *, ftnlen);
    doublereal a, b, c__;
    integer i__;
    extern /* Subroutine */ int vaddg_(doublereal *, doublereal *, integer *, 
	    doublereal *);
    integer refid;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    doublereal epoch;
    extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
    static logical usecn;
    extern /* Subroutine */ int vlcom_(doublereal *, doublereal *, doublereal 
	    *, doublereal *, doublereal *), vsubg_(doublereal *, doublereal *,
	     integer *, doublereal *);
    doublereal lterr;
    static logical uselt;
    extern doublereal vnorm_(doublereal *);
    doublereal prvlt;
    extern logical failed_(void);
    extern doublereal clight_(void);
    logical attblk[15];
    extern doublereal touchd_(doublereal *);
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen);
    doublereal ctrssb[6];
    integer ltsign;
    extern /* Subroutine */ int irfnum_(char *, integer *, ftnlen), setmsg_(
	    char *, ftnlen);
    doublereal ssbtrg[6];
    integer trgctr;
    extern /* Subroutine */ int spkssb_(integer *, doublereal *, char *, 
	    doublereal *, ftnlen);
    integer numitr;
    extern logical return_(void);
    logical usestl;
    doublereal sttctr[6];

/* $ 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. */

/*     Return the state (position and velocity) of a target body */
/*     relative to an observer, optionally corrected for light time, */
/*     expressed relative to an inertial reference frame. An input */
/*     subroutine provides the state of the target relative to its */
/*     center of motion. */

/* $ 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 */
/* $ Abstract */

/*     Include file zzabcorr.inc */

/*     SPICE private file intended solely for the support of SPICE */
/*     routines.  Users should not include this file directly due */
/*     to the volatile nature of this file */

/*     The parameters below define the structure of an aberration */
/*     correction attribute block. */

/* $ 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. */

/* $ Parameters */

/*     An aberration correction attribute block is an array of logical */
/*     flags indicating the attributes of the aberration correction */
/*     specified by an aberration correction string.  The attributes */
/*     are: */

/*        - Is the correction "geometric"? */

/*        - Is light time correction indicated? */

/*        - Is stellar aberration correction indicated? */

/*        - Is the light time correction of the "converged */
/*          Newtonian" variety? */

/*        - Is the correction for the transmission case? */

/*        - Is the correction relativistic? */

/*    The parameters defining the structure of the block are as */
/*    follows: */

/*       NABCOR    Number of aberration correction choices. */

/*       ABATSZ    Number of elements in the aberration correction */
/*                 block. */

/*       GEOIDX    Index in block of geometric correction flag. */

/*       LTIDX     Index of light time flag. */

/*       STLIDX    Index of stellar aberration flag. */

/*       CNVIDX    Index of converged Newtonian flag. */

/*       XMTIDX    Index of transmission flag. */

/*       RELIDX    Index of relativistic flag. */

/*    The following parameter is not required to define the block */
/*    structure, but it is convenient to include it here: */

/*       CORLEN    The maximum string length required by any aberration */
/*                 correction string */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 18-DEC-2004 (NJB) */

/* -& */
/*     Number of aberration correction choices: */


/*     Aberration correction attribute block size */
/*     (number of aberration correction attributes): */


/*     Indices of attributes within an aberration correction */
/*     attribute block: */


/*     Maximum length of an aberration correction string: */


/*     End of include file zzabcorr.inc */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     TRGSUB     I   Target body state subroutine. */
/*     ET         I   Observer epoch. */
/*     REF        I   Inertial reference frame of output state. */
/*     ABCORR     I   Aberration correction flag. */
/*     STOBS      I   State of the observer relative to the SSB. */
/*     STARG      O   State of target. */
/*     LT         O   One way light time between observer and target. */
/*     DLT        O   Derivative of light time with respect to time. */

/* $ Detailed_Input */

/*     TRGSUB      is the name of an external subroutine that returns */
/*                 the geometric state of the target body relative to a */
/*                 center of motion, expressed in the inertial reference */
/*                 frame REF, at the epoch ET. */

/*                 The calling sequence of TRGSUB is */

/*                    SUBROUTINE TRGSUB ( ET, REF, TRGCTR, STATE ) */

/*                    DOUBLE PRECISION      ET */
/*                    CHARACTER*(*)         REF */
/*                    INTEGER               TRGCTR */
/*                    DOUBLE PRECISION      STATE ( 6 ) */

/*                    The inputs of TRGSUB are ET and REF; the outputs */
/*                    are TRGCTR and STATE. STATE is the geometric state */
/*                    of the target relative to the returned center of */
/*                    motion at ET, expressed in the frame REF. */

/*                 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 input state STOBS and the output state STARG are */
/*                 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. */


/*     ABCORR      indicates the aberration corrections to be applied to */
/*                 the state of the target body to account for one-way */
/*                 light time. See the discussion in the Particulars */
/*                 section for recommendations on how to choose */
/*                 aberration corrections. */

/*                 If ABCORR includes the stellar aberration correction */
/*                 symbol '+S', this flag is simply ignored. Aside from */
/*                 the possible presence of this symbol, 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 the Particulars section */
/*                               of SPKEZR for details.) The solution */
/*                               invoked by the 'LT' option uses one */
/*                               iteration. */

/*                    '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. */

/*                 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. */

/*                    'XCN'      "Transmission" case:  converged */
/*                               Newtonian light time 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. */


/*     STOBS       is the geometric (uncorrected) state of the observer */
/*                 relative to the solar system barycenter at epoch ET. */
/*                 STOBS is a 6-vector: the first three components of */
/*                 STOBS represent a Cartesian position vector; the last */
/*                 three components represent the corresponding velocity */
/*                 vector. STOBS is expressed relative to the inertial */
/*                 reference frame designated by REF. */

/*                 Units are always km and km/sec. */

/* $ 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 aberration, 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. */

/*                 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 light time, then LT is the one-way light time */
/*                 between the observer and the light time-corrected */
/*                 target location. */

/*     DLT         is the derivative with respect to barycentric */
/*                 dynamical time of the one way light time between */
/*                 target and observer: */

/*                    DLT = d(LT)/d(ET) */

/*                 DLT can also be described as the rate of change of */
/*                 one way light time. DLT is unitless, since LT and */
/*                 ET both have units of TDB seconds. */

/*                 If the observer and target are at the same position, */
/*                 then DLT is set to zero. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1) For the convenience of the caller, the input aberration */
/*        correction flag can call for stellar aberration correction via */
/*        inclusion of the '+S' suffix. This portion of the aberration */
/*        correction flag is ignored if present. */

/*     2) If ABCORR calls for stellar aberration but not light */
/*        time corrections, the error SPICE(NOTSUPPORTED) is */
/*        signaled. */

/*     3) If ABCORR calls for relativistic light time corrections, the */
/*        error SPICE(NOTSUPPORTED) is signaled. */

/*     4) If the value of ABCORR is not recognized, the error */
/*        is diagnosed by a routine in the call tree of this */
/*        routine. */

/*     5) If the reference frame requested is not a recognized */
/*        inertial reference frame, the error SPICE(UNKNOWNFRAME) */
/*        is signaled. */

/*     6) 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. */

/*     7) If the observer and target are at the same position, */
/*        then DLT is set to zero. This situation could arise, */
/*        for example, when the observer is Mars and the target */
/*        is the Mars barycenter. */

/*     8) If a division by zero error would occur in the computation */
/*        of DLT, the error SPICE(DIVIDEBYZERO) is signaled. */

/* $ 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 */

/*     This routine supports higher-level routines that can */
/*     perform both light time and stellar aberration corrections */
/*     and that use target states provided by subroutines rather */
/*     than by the conventional, public SPK APIs. For example, this */
/*     routine can be used for objects having fixed positions */
/*     on the surfaces of planets. */

/* $ Examples */

/*     See usage in ZZSPKFAP. */

/* $ Restrictions */

/*     1) This routine must not be called by routines of the SPICE */
/*        frame subsystem. It must not be called by any portion of */
/*        the SPK subsystem other than the private SPK function-based */
/*        component. */

/*     2) The input subroutine TRGSUB must not call this routine. */
/*        or any of the supporting, private SPK routines */

/*     3)  When possible, the routine SPKGEO should be used instead of */
/*         this routine to compute geometric states. SPKGEO introduces */
/*         less round-off error when the observer and target have common */
/*         center that is closer to both objects than is the solar */
/*         system barycenter. */

/*     4)  Unlike most other SPK state computation routines, this */
/*         routine requires that the output state be relative to an */
/*         inertial reference frame. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 04-JUL-2014 (NJB) */

/*        Discussion of light time corrections was updated. Assertions */
/*        that converged light time corrections are unlikely to be */
/*        useful were removed. */

/*     Last update was 22-FEB-2012 (NJB) */

/* -& */
/* $ Index_Entries */

/*     low-level light time correction */
/*     light-time corrected state from spk file */
/*     get light-time corrected state */

/* -& */
/* $ Revisions */

/*     None. */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     TOL is the tolerance used for a division-by-zero test */
/*     performed prior to computation of DLT. */


/*     Convergence limit: */


/*     Maximum number of light time iterations for any */
/*     aberration correction: */


/*     Local variables */


/*     Saved variables */


/*     Initial values */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    }
    chkin_("ZZSPKFLT", (ftnlen)8);
    if (pass1 || 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. */

	zzvalcor_(abcorr, attblk, abcorr_len);
	if (failed_()) {
	    chkout_("ZZSPKFLT", (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 is .TRUE. when the correction is for transmitted */
/*           radiation. */

/*           USELT is .TRUE. when any type of light time correction */
/*           (normal or converged Newtonian) is specified. */

/*           USECN indicates converged Newtonian light time correction. */

/*        The above definitions are consistent with those used by */
/*        ZZVALCOR. */

	xmit = attblk[4];
	uselt = attblk[1];
	usecn = attblk[3];
	usestl = attblk[2];
	pass1 = 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(UNKNOWNFRAME)", (ftnlen)19);
	chkout_("ZZSPKFLT", (ftnlen)8);
	return 0;
    }

/*     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. */

    (*trgsub)(et, ref, &trgctr, sttctr, ref_len);
    spkssb_(&trgctr, et, ref, ctrssb, ref_len);
    if (failed_()) {
	chkout_("ZZSPKFLT", (ftnlen)8);
	return 0;
    }
    vaddg_(ctrssb, sttctr, &c__6, ssbtrg);
    vsubg_(ssbtrg, stobs, &c__6, starg);
    dist = vnorm_(starg);
    *lt = dist / clight_();
    if (*lt == 0.) {

/*        This can happen only if the observer and target are at the */
/*        same position. We don't consider this an error, but we're not */
/*        going to compute the light time derivative. */

	*dlt = 0.;
	chkout_("ZZSPKFLT", (ftnlen)8);
	return 0;
    }
    if (! uselt) {

/*        This is a special case: we're not using light time */
/*        corrections, so the derivative */
/*        of light time is just */

/*           (1/c) * d(VNORM(STARG))/dt */

	*dlt = vdot_(starg, &starg[3]) / (dist * clight_());

/*        LT and DLT are both set, so we can return. */

	chkout_("ZZSPKFLT", (ftnlen)8);
	return 0;
    }

/*     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 it is. */

/*     Determine the sign of the light time offset. */

    if (xmit) {
	ltsign = 1;
    } else {
	ltsign = -1;
    }

/*     Let NUMITR be the number of iterations we'll perform to */
/*     compute the light time. */

    if (usecn) {
	numitr = 5;
    } else {
	numitr = 1;
    }
    i__ = 0;
    lterr = 1.;
    while(i__ < numitr && lterr > 1e-17) {

/*        LT was set either prior to this loop or */
/*        during the previous loop iteration. */

	d__1 = *et + ltsign * *lt;
	epoch = touchd_(&d__1);
	(*trgsub)(&epoch, ref, &trgctr, sttctr, ref_len);
	spkssb_(&trgctr, &epoch, ref, ctrssb, ref_len);
	if (failed_()) {
	    chkout_("ZZSPKFLT", (ftnlen)8);
	    return 0;
	}
	vaddg_(ctrssb, sttctr, &c__6, ssbtrg);
	vsubg_(ssbtrg, stobs, &c__6, starg);
	prvlt = *lt;
	d__1 = vnorm_(starg) / clight_();
	*lt = touchd_(&d__1);

/*        LTERR is the magnitude of the change between the current */
/*        estimate of light time and the previous estimate, relative to */
/*        the previous light time corrected epoch. */

/* Computing MAX */
	d__3 = 1., d__4 = abs(epoch);
	d__2 = (d__1 = *lt - prvlt, abs(d__1)) / max(d__3,d__4);
	lterr = touchd_(&d__2);
	++i__;
    }

/*     At this point, STARG contains the light time corrected */
/*     state of the target relative to the observer. */

/*     Compute the derivative of light time with respect */
/*     to time: dLT/dt.  Below we derive the formula for */
/*     this quantity for the reception case. Let */

/*        POBS be the position of the observer relative to the */
/*        solar system barycenter. */

/*        VOBS be the velocity of the observer relative to the */
/*        solar system barycenter. */

/*        PTARG be the position of the target relative to the */
/*        solar system barycenter. */

/*        VTARG be the velocity of the target relative to the */
/*        solar system barycenter. */

/*        S be the sign of the light time correction. S is */
/*        negative for the reception case. */

/*     The light-time corrected position of the target relative to */
/*     the observer at observation time ET, given the one-way */
/*     light time LT is: */

/*         PTARG(ET+S*LT) - POBS(ET) */

/*     The light-time corrected velocity of the target relative to */
/*     the observer at observation time ET is */

/*         VTARG(ET+S*LT)*( 1 + S*d(LT)/d(ET) ) - VOBS(ET) */

/*     We need to compute dLT/dt. Below, we use the facts that, */
/*     for a time-dependent vector X(t), */

/*          ||X||     = <X,X> ** (1/2) */

/*        d(||X||)/dt = (1/2)<X,X>**(-1/2) * 2 * <X,dX/dt> */

/*                    = <X,X>**(-1/2) *  <X,dX/dt> */

/*                    = <X,dX/dt> / ||X|| */

/*     Newtonian light time equation: */

/*        LT     =   (1/c) * || PTARG(ET+S*LT) - POBS(ET)|| */

/*     Differentiate both sides: */

/*        dLT/dt =   (1/c) * ( 1 / || PTARG(ET+S*LT) - POBS(ET) || ) */

/*                  * < PTARG(ET+S*LT) - POBS(ET), */
/*                      VTARG(ET+S*LT)*(1+S*d(LT)/d(ET)) - VOBS(ET) > */


/*               = (1/c) * ( 1 / || PTARG(ET+S*LT) - POBS(ET) || ) */

/*                 * (  < PTARG(ET+S*LT) - POBS(ET), */
/*                        VTARG(ET+S*LT) - VOBS(ET) > */

/*                   +  < PTARG(ET+S*LT) - POBS(ET), */
/*                        VTARG(ET+S*LT)           > * (S*d(LT)/d(ET))  ) */

/*     Let */

/*        A =   (1/c) * ( 1 / || PTARG(ET+S*LT) - POBS(ET) || ) */

/*        B =   < PTARG(ET+S*LT) - POBS(ET), VTARG(ET+S*LT) - VOBS(ET) > */

/*        C =   < PTARG(ET+S*LT) - POBS(ET), VTARG(ET+S*LT) > */

/*     Then */

/*        d(LT)/d(ET) =  A * ( B  +  C * S*d(LT)/d(ET) ) */

/*     which implies */

/*        d(LT)/d(ET) =  A*B / ( 1 - S*C*A ) */



    a = 1. / (clight_() * vnorm_(starg));
    b = vdot_(starg, &starg[3]);
    c__ = vdot_(starg, &ssbtrg[3]);

/*     For physically realistic target velocities, S*C*A cannot equal 1. */
/*     We'll check for this case anyway. */

    if (ltsign * c__ * a > .99999999989999999) {
	setmsg_("Target range rate magnitude is approximately the speed of l"
		"ight. The light time derivative cannot be computed.", (ftnlen)
		110);
	sigerr_("SPICE(DIVIDEBYZERO)", (ftnlen)19);
	chkout_("ZZSPKFLT", (ftnlen)8);
	return 0;
    }

/*     Compute DLT: the rate of change of light time. */

    *dlt = a * b / (1. - ltsign * c__ * a);

/*     Overwrite the velocity portion of the output state */
/*     with the light-time corrected velocity. */

    d__1 = ltsign * *dlt + 1.;
    vlcom_(&d__1, &ssbtrg[3], &c_b19, &stobs[3], &starg[3]);
    chkout_("ZZSPKFLT", (ftnlen)8);
    return 0;
} /* zzspkflt_ */
コード例 #18
0
ファイル: spkw17.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure      SPKW17 ( SPK, write a type 17 segment ) */
/* Subroutine */ int spkw17_(integer *handle, integer *body, integer *center, 
	char *frame, doublereal *first, doublereal *last, char *segid, 
	doublereal *epoch, doublereal *eqel, doublereal *rapol, doublereal *
	decpol, ftnlen frame_len, ftnlen segid_len)
{
    /* System generated locals */
    integer i__1;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    doublereal a, h__;
    integer i__;
    doublereal k;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    doublereal descr[5];
    extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *);
    integer value;
    extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen), dafada_(
	    doublereal *, integer *), dafbna_(integer *, doublereal *, char *,
	     ftnlen), dafena_(void);
    extern logical failed_(void);
    doublereal record[12];
    extern integer lastnb_(char *, ftnlen);
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *, 
	    ftnlen), spkpds_(integer *, integer *, char *, integer *, 
	    doublereal *, doublereal *, doublereal *, ftnlen);
    extern logical return_(void);
    doublereal ecc;

/* $ Abstract */

/*     Write an SPK segment of type 17 given a type 17 data record. */

/* $ 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 */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   Handle of an SPK file open for writing. */
/*     BODY       I   Body code for ephemeris object. */
/*     CENTER     I   Body code for the center of motion of the body. */
/*     FRAME      I   The reference frame of the states. */
/*     FIRST      I   First valid time for which states can be computed. */
/*     LAST       I   Last valid time for which states can be computed. */
/*     SEGID      I   Segment identifier. */
/*     EPOCH      I   Epoch of elements in seconds past J2000 */
/*     EQEL       I   Array of equinoctial elements */
/*     RAPOL      I   Right Ascension of the pole of the reference plane */
/*     DECPOL     I   Declination of the pole of the reference plane */

/* $ Detailed_Input */

/*     HANDLE      is the file handle of an SPK file that has been */
/*                 opened for writing. */

/*     BODY        is the NAIF ID for the body whose states are */
/*                 to be recorded in an SPK file. */

/*     CENTER      is the NAIF ID for the center of motion associated */
/*                 with BODY. */

/*     FRAME       is the reference frame that states are referenced to, */
/*                 for example 'J2000'. */

/*     FIRST       are the bounds on the ephemeris times, expressed as */
/*     LAST        seconds past J2000. */

/*     SEGID       is the segment identifier. An SPK segment identifier */
/*                 may contain up to 40 characters. */

/*     EPOCH      is the epoch of equinoctial elements in seconds */
/*                past the J2000 epoch. */

/*     EQEL       is an array of 9 double precision numbers that */
/*                are the equinoctial elements for some orbit relative */
/*                to the equatorial frame of a central body. */

/*                ( The z-axis of the equatorial frame is the direction */
/*                  of the pole of the central body relative to FRAME. */
/*                  The x-axis is given by the cross product of the */
/*                  Z-axis of FRAME with the direction of the pole of */
/*                  the central body.  The Y-axis completes a right */
/*                  handed frame. ) */

/*                The specific arrangement of the elements is spelled */
/*                out below.  The following terms are used in the */
/*                discussion of elements of EQEL */

/*                    INC  --- inclination of the orbit */
/*                    ARGP --- argument of periapse */
/*                    NODE --- longitude of the ascending node */
/*                    E    --- eccentricity of the orbit */

/*                EQEL(1) is the semi-major axis (A) of the orbit in km. */

/*                EQEL(2) is the value of H at the specified epoch. */
/*                        ( E*SIN(ARGP+NODE) ). */

/*                EQEL(3) is the value of K at the specified epoch */
/*                        ( E*COS(ARGP+NODE) ). */

/*                EQEL(4) is the mean longitude (MEAN0+ARGP+NODE)at */
/*                        the epoch of the elements measured in radians. */

/*                EQEL(5) is the value of P (TAN(INC/2)*SIN(NODE))at */
/*                        the specified epoch. */

/*                EQEL(6) is the value of Q (TAN(INC/2)*COS(NODE))at */
/*                        the specified epoch. */

/*                EQEL(7) is the rate of the longitude of periapse */
/*                        (dARGP/dt + dNODE/dt ) at the epoch of */
/*                        the elements.  This rate is assumed to hold */
/*                        for all time. The rate is measured in */
/*                        radians per second. */

/*                EQEL(8) is the derivative of the mean longitude */
/*                        ( dM/dt + dARGP/dt + dNODE/dt ).  This */
/*                        rate is assumed to be constant and is */
/*                        measured in radians/second. */

/*                EQEL(9) is the rate of the longitude of the ascending */
/*                        node ( dNODE/dt).  This rate is measured */
/*                        in radians per second. */

/*     RAPOL      Right Ascension of the pole of the reference plane */
/*                relative to FRAME measured in radians. */

/*     DECPOL     Declination of the pole of the reference plane */
/*                relative to FRAME measured in radians. */

/* $ Detailed_Output */

/*     None.  A type 17 segment is written to the file attached */
/*     to HANDLE. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1) If the semi-major axis is less than or equal to zero, the error */
/*        'SPICE(BADSEMIAXIS)' is signalled. */

/*     2) If the eccentricity of the orbit corresponding to the values */
/*        of H and K ( EQEL(2) and EQEL(3) ) is greater than 0.9 the */
/*        error 'SPICE(ECCOUTOFRANGE)' is signalled. */

/*     3) If the segment identifier has more than 40 non-blank characters */
/*        the error 'SPICE(SEGIDTOOLONG)' is signalled. */

/*     4) If the segment identifier contains non-printing characters */
/*        the error 'SPICE(NONPRINTABLECHARS)' is signalled. */

/*     5) If there are inconsistencies in the BODY, CENTER, FRAME or */
/*        FIRST and LAST times, the problem will be diagnosed by */
/*        a routine in the call tree of this routine. */

/* $ Files */

/*     A new type 17 SPK segment is written to the SPK file attached */
/*     to HANDLE. */

/* $ Particulars */

/*     This routine writes an SPK type 17 data segment to the open SPK */
/*     file according to the format described in the type 17 section of */
/*     the SPK Required Reading. The SPK file must have been opened with */
/*     write access. */

/* $ Examples */

/*     Suppose that at time EPOCH you have the classical elements */
/*     of some BODY relative to the equatorial frame of some central */
/*     body CENTER. These can be converted to equinoctial elements */
/*     and stored in an SPK file as a type 17 segment so that this */
/*     body can be used within the SPK subsystem of the SPICE system. */

/*     Below is a list of the variables used to represent the */
/*     classical elements */

/*           Variable     Meaning */
/*           --------     ---------------------------------- */
/*           A            Semi-major axis in km */
/*           ECC          Eccentricity of orbit */
/*           INC          Inclination of orbit */
/*           NODE         Longitude of the ascending node at epoch */
/*           OMEGA        Argument of periapse at epoch */
/*           M            Mean anomaly at epoch */
/*           DMDT         Mean anomaly rate in radians/second */
/*           DNODE        Rate of change of longitude of ascending node */
/*                        in radians/second */
/*           DOMEGA       Rate of change of argument of periapse in */
/*                        radians/second */
/*           EPOCH        is the epoch of the elements in seconds past */
/*                        the J2000 epoch. */


/*        These elements are converted to equinoctial elements (in */
/*        the order compatible with type 17) as shown below. */

/*           EQEL(1) = A */
/*           EQEL(2) = ECC * DSIN ( OMEGA + NODE ) */
/*           EQEL(3) = ECC * DCOS ( OMEGA + NODE ) */

/*           EQEL(4) = M + OMEGA + NODE */

/*           EQEL(5) = TAN(INC/2.0D0) * DSIN(NODE) */
/*           EQEL(6) = TAN(INC/2.0D0) * DCOS(NODE) */

/*           EQEL(7) = DOMEGA */
/*           EQEL(8) = DOMEGA + DMDT + DNODE */
/*           EQEL(9) = DNODE */


/*     C */
/*     C     Now add the segment. */
/*     C */

/*           CALL SPKW17 ( HANDLE, BODY,  CENTER, FRAME,  FIRST, LAST, */
/*          .              SEGID,  EPOCH, EQEL,   RAPOL,  DECPOL ) */


/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     W.L. Taber      (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.1, 24-Jun-1999 (WLT) */

/*        Corrected typographical errors in the header. */

/* -    SPICELIB Version 1.0.0, 8-Jan-1997 (WLT) */

/* -& */
/* $ Index_Entries */

/*     Write a type 17 spk segment */

/* -& */

/*     SPICELIB Functions */


/*     Local Variables */


/*     Segment descriptor size */


/*     Segment identifier size */


/*     SPK data type */


/*     Range of printing characters */


/*     Number of items in a segment */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    }
    chkin_("SPKW17", (ftnlen)6);

/*     Fetch the various entities from the inputs and put them into */
/*     the data record, first the epoch. */

    record[0] = *epoch;

/*     The trajectory pole vector. */

    moved_(eqel, &c__9, &record[1]);
    record[10] = *rapol;
    record[11] = *decpol;
    a = record[1];
    h__ = record[2];
    k = record[3];
    ecc = sqrt(h__ * h__ + k * k);

/*     Check all the inputs here for obvious failures.  It's much */
/*     better to check them now and quit than it is to get a bogus */
/*     segment into an SPK file and diagnose it later. */

    if (a <= 0.) {
	setmsg_("The semimajor axis supplied to the SPK type 17 evaluator wa"
		"s non-positive.  This value must be positive. The value supp"
		"lied was #.", (ftnlen)130);
	errdp_("#", &a, (ftnlen)1);
	sigerr_("SPICE(BADSEMIAXIS)", (ftnlen)18);
	chkout_("SPKW17", (ftnlen)6);
	return 0;
    } else if (ecc > .9) {
	setmsg_("The eccentricity supplied for a type 17 segment is greater "
		"than 0.9.  It must be less than 0.9.The value supplied to th"
		"e type 17 evaluator was #. ", (ftnlen)146);
	errdp_("#", &ecc, (ftnlen)1);
	sigerr_("SPICE(BADECCENTRICITY)", (ftnlen)22);
	chkout_("SPKW17", (ftnlen)6);
	return 0;
    }

/*     Make sure the segment identifier is not too long. */

    if (lastnb_(segid, segid_len) > 40) {
	setmsg_("Segment identifier contains more than 40 characters.", (
		ftnlen)52);
	sigerr_("SPICE(SEGIDTOOLONG)", (ftnlen)19);
	chkout_("SPKW17", (ftnlen)6);
	return 0;
    }

/*     Make sure the segment identifier has only printing characters. */

    i__1 = lastnb_(segid, segid_len);
    for (i__ = 1; i__ <= i__1; ++i__) {
	value = *(unsigned char *)&segid[i__ - 1];
	if (value < 32 || value > 126) {
	    setmsg_("The segment identifier contains the nonprintable charac"
		    "ter having ascii code #.", (ftnlen)79);
	    errint_("#", &value, (ftnlen)1);
	    sigerr_("SPICE(NONPRINTABLECHARS)", (ftnlen)24);
	    chkout_("SPKW17", (ftnlen)6);
	    return 0;
	}
    }

/*     All of the obvious checks have been performed on the input */
/*     record.  Create the segment descriptor. (FIRST and LAST are */
/*     checked by SPKPDS as well as consistency between BODY and CENTER). */

    spkpds_(body, center, frame, &c__17, first, last, descr, frame_len);
    if (failed_()) {
	chkout_("SPKW17", (ftnlen)6);
	return 0;
    }

/*     Begin a new segment. */

    dafbna_(handle, descr, segid, segid_len);
    if (failed_()) {
	chkout_("SPKW17", (ftnlen)6);
	return 0;
    }
    dafada_(record, &c__12);
    if (! failed_()) {
	dafena_();
    }
    chkout_("SPKW17", (ftnlen)6);
    return 0;
} /* spkw17_ */
コード例 #19
0
ファイル: ckr04.c プロジェクト: Dbelsa/coft
/* $Procedure      CKR04 ( C-kernel, read pointing record, data type 4 ) */
/* Subroutine */ int ckr04_(integer *handle, doublereal *descr, doublereal *
	sclkdp, doublereal *tol, logical *needav, doublereal *record, logical 
	*found)
{
    /* System generated locals */
    integer i__1, i__2;

    /* Builtin functions */
    integer s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer nrec, ends, indx;
    doublereal lbnd1, lbnd2, rbnd1;
    integer k;
    extern /* Subroutine */ int chkin_(char *, ftnlen), cknr04_(integer *, 
	    doublereal *, integer *), dafus_(doublereal *, integer *, integer 
	    *, doublereal *, integer *);
    doublereal value;
    logical exist;
    doublereal midpt1, midpt2;
    extern logical failed_(void);
    integer numall;
    extern /* Subroutine */ int sigerr_(char *, ftnlen);
    integer numcft[7];
    extern /* Subroutine */ int chkout_(char *, ftnlen), sgfpkt_(integer *, 
	    doublereal *, integer *, integer *, doublereal *, integer *), 
	    sgfrvi_(integer *, doublereal *, doublereal *, doublereal *, 
	    integer *, logical *);
    doublereal clkout;
    extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *, 
	    integer *, ftnlen);
    extern logical return_(void);
    doublereal dcd[2];
    integer icd[6];
    extern /* Subroutine */ int zzck4d2i_(doublereal *, integer *, doublereal 
	    *, integer *);
    doublereal rad1, rad2;

/* $ Abstract */

/*     Read a single data record from a type 4 CK segment. */

/* $ 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 */

/*     CK */
/*     DAF */

/* $ Keywords */

/*     POINTING */

/* $ Declarations */
/* $ Abstract */

/*     Declarations of the CK data type specific and general CK low */
/*     level routine parameters. */

/* $ 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 */

/*     CK.REQ */

/* $ Keywords */

/*     CK */

/* $ Restrictions */

/*     1) If new CK types are added, the size of the record passed */
/*        between CKRxx and CKExx must be registered as separate */
/*        parameter. If this size will be greater than current value */
/*        of the CKMRSZ parameter (which specifies the maximum record */
/*        size for the record buffer used inside CKPFS) then it should */
/*        be assigned to CKMRSZ as a new value. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */
/*     B.V. Semenov      (JPL) */

/* $ Literature_References */

/*     CK Required Reading. */

/* $ Version */

/* -    SPICELIB Version 3.0.0, 27-JAN-2014 (NJB) */

/*        Updated to support CK type 6. Maximum degree for */
/*        type 5 was updated to be consistent with the */
/*        maximum degree for type 6. */

/* -    SPICELIB Version 2.0.0, 19-AUG-2002 (NJB) */

/*        Updated to support CK type 5. */

/* -    SPICELIB Version 1.0.0, 05-APR-1999 (BVS) */

/* -& */

/*     Number of quaternion components and number of quaternion and */
/*     angular rate components together. */


/*     CK Type 1 parameters: */

/*     CK1DTP   CK data type 1 ID; */

/*     CK1RSZ   maximum size of a record passed between CKR01 */
/*              and CKE01. */


/*     CK Type 2 parameters: */

/*     CK2DTP   CK data type 2 ID; */

/*     CK2RSZ   maximum size of a record passed between CKR02 */
/*              and CKE02. */


/*     CK Type 3 parameters: */

/*     CK3DTP   CK data type 3 ID; */

/*     CK3RSZ   maximum size of a record passed between CKR03 */
/*              and CKE03. */


/*     CK Type 4 parameters: */

/*     CK4DTP   CK data type 4 ID; */

/*     CK4PCD   parameter defining integer to DP packing schema that */
/*              is applied when seven number integer array containing */
/*              polynomial degrees for quaternion and angular rate */
/*              components packed into a single DP number stored in */
/*              actual CK records in a file; the value of must not be */
/*              changed or compatibility with existing type 4 CK files */
/*              will be lost. */

/*     CK4MXD   maximum Chebychev polynomial degree allowed in type 4 */
/*              records; the value of this parameter must never exceed */
/*              value of the CK4PCD; */

/*     CK4SFT   number of additional DPs, which are not polynomial */
/*              coefficients, located at the beginning of a type 4 */
/*              CK record that passed between routines CKR04 and CKE04; */

/*     CK4RSZ   maximum size of type 4 CK record passed between CKR04 */
/*              and CKE04; CK4RSZ is computed as follows: */

/*                 CK4RSZ = ( CK4MXD + 1 ) * QAVSIZ + CK4SFT */


/*     CK Type 5 parameters: */


/*     CK5DTP   CK data type 5 ID; */

/*     CK5MXD   maximum polynomial degree allowed in type 5 */
/*              records. */

/*     CK5MET   number of additional DPs, which are not polynomial */
/*              coefficients, located at the beginning of a type 5 */
/*              CK record that passed between routines CKR05 and CKE05; */

/*     CK5MXP   maximum packet size for any subtype.  Subtype 2 */
/*              has the greatest packet size, since these packets */
/*              contain a quaternion, its derivative, an angular */
/*              velocity vector, and its derivative.  See ck05.inc */
/*              for a description of the subtypes. */

/*     CK5RSZ   maximum size of type 5 CK record passed between CKR05 */
/*              and CKE05; CK5RSZ is computed as follows: */

/*                 CK5RSZ = ( CK5MXD + 1 ) * CK5MXP + CK5MET */


/*     CK Type 6 parameters: */


/*     CK6DTP   CK data type 6 ID; */

/*     CK6MXD   maximum polynomial degree allowed in type 6 */
/*              records. */

/*     CK6MET   number of additional DPs, which are not polynomial */
/*              coefficients, located at the beginning of a type 6 */
/*              CK record that passed between routines CKR06 and CKE06; */

/*     CK6MXP   maximum packet size for any subtype.  Subtype 2 */
/*              has the greatest packet size, since these packets */
/*              contain a quaternion, its derivative, an angular */
/*              velocity vector, and its derivative.  See ck06.inc */
/*              for a description of the subtypes. */

/*     CK6RSZ   maximum size of type 6 CK record passed between CKR06 */
/*              and CKE06; CK6RSZ is computed as follows: */

/*                 CK6RSZ = CK6MET + ( CK6MXD + 1 ) * ( CK6PS3 + 1 ) */

/*              where CK6PS3 is equal to the parameter CK06PS3 defined */
/*              in ck06.inc. Note that the subtype having the largest */
/*              packet size (subtype 2) does not give rise to the */
/*              largest record size, because that type is Hermite and */
/*              requires half the window size used by subtype 3 for a */
/*              given polynomial degree. */


/*     The parameter CK6PS3 must be in sync with C06PS3 defined in */
/*     ck06.inc. */



/*     Maximum record size that can be handled by CKPFS. This value */
/*     must be set to the maximum of all CKxRSZ parameters (currently */
/*     CK5RSZ.) */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   File handle. */
/*     DESCR      I   Segment descriptor. */
/*     SCLKDP     I   Pointing request time. */
/*     TOL        I   Time tolerance. */
/*     NEEDAV     I   Angular velocity request flag. */
/*     RECORD     O   Pointing data record. */
/*     FOUND      O   True when a record covering SCLKDP is found. */

/* $ Detailed_Input */

/*     HANDLE     is the integer handle of the CK file containing the */
/*                segment. */

/*     DESCR      is the descriptor of the segment. */

/*     SCLKDP     is the encoded spacecraft clock time for which */
/*                pointing is being requested. */

/*     TOL        is a time tolerance, measured in the same units as */
/*                encoded spacecraft clock. */

/*                When SCLKDP falls within the bounds of one of the */
/*                interpolation intervals then the tolerance has no */
/*                effect because pointing will be returned at the */
/*                request time. */

/*                However, if the request time is not in one of the */
/*                intervals, then the tolerance is used to determine */
/*                if pointing at one of the interval endpoints should */
/*                be returned. */

/*     NEEDAV     is true if angular velocity is requested. */

/* $ Detailed_Output */

/*     RECORD     is the record that CKE04 will evaluate to determine */
/*                the pointing and it includes parameters: */

/*                --------------------------------------------------- */
/*                |    Encoded onboard time which is the closest    | */
/*                |  to SCLKDP and belongs to one of approximation  | */
/*                |                   intervals                     | */
/*                --------------------------------------------------- */
/*                |       encoded SCLK time of the midpoint of      | */
/*                |             interpolation interval              | */
/*                --------------------------------------------------- */
/*                |          radii of interpolation interval        | */
/*                |    expressed as double precision SCLK ticks     | */
/*                --------------------------------------------------- */
/*                |         Number of coefficients for q0           | */
/*                --------------------------------------------------- */
/*                |         Number of coefficients for q1           | */
/*                --------------------------------------------------- */
/*                |         Number of coefficients for q2           | */
/*                --------------------------------------------------- */
/*                |         Number of coefficients for q3           | */
/*                --------------------------------------------------- */
/*                |         Number of coefficients for AV1          | */
/*                --------------------------------------------------- */
/*                |         Number of coefficients for AV2          | */
/*                --------------------------------------------------- */
/*                |         Number of coefficients for AV3          | */
/*                --------------------------------------------------- */
/*                |               q0 Cheby coefficients             | */
/*                --------------------------------------------------- */
/*                |               q1 Cheby coefficients             | */
/*                --------------------------------------------------- */
/*                |               q2 Cheby coefficients             | */
/*                --------------------------------------------------- */
/*                |               q3 Cheby coefficients             | */
/*                --------------------------------------------------- */
/*                |         AV1 Cheby coefficients (optional)       | */
/*                --------------------------------------------------- */
/*                |         AV2 Cheby coefficients (optional)       | */
/*                --------------------------------------------------- */
/*                |         AV3 Cheby coefficients (optional)       | */
/*                --------------------------------------------------- */

/*     FOUND    is true if a record was found to satisfy the pointing */
/*              request. This occurs when the time for which pointing */
/*              is requested falls inside one of the interpolation */
/*              intervals, or when the request time is within the */
/*              tolerance of an interval endpoint. */

/* $ Parameters */

/*     See 'ckparam.inc'. */

/* $ Exceptions */

/*     1)  If the specified handle does not belong to an open DAF file, */
/*         an error is diagnosed by a routine that this routine calls. */

/*     2)  If the specified descriptor does not belong a segment */
/*         data in which are organized in accordance with generic */
/*         segment architecture, an error is diagnosed by DAF generic */
/*         segment routines that this routine calls. */

/*     3)  If DESCR is not a valid descriptor of a segment in the CK */
/*         file specified by HANDLE, the results of this routine are */
/*         unpredictable. */

/*     4)  If the segment is not of data type 4, as specified in the */
/*         third integer component of the segment descriptor, then */
/*         the error SPICE(WRONGDATATYPE) is signalled. */

/*     5)  If angular velocity data was requested but the segment */
/*         contains no such data, the error SPICE(NOAVDATA) is */
/*         signalled. */

/* $ Files */

/*     See argument HANDLE. */

/* $ Particulars */

/*     See the CK Required Reading file for a detailed description of */
/*     the structure of a type 4 pointing segment. */

/*     When the time for which pointing was requested falls within an */
/*     interpolation interval, then FOUND will be true and RECORD will */
/*     contain the set of Chebychev polynomial coefficients for the */
/*     time interval that brackets the request time. CKE04 will */
/*     evaluate RECORD to give pointing at the request time. */

/*     However, when the request time is not within any of the */
/*     interpolation intervals, then FOUND will be true only if the */
/*     interval endpoint closest to the request time is within the */
/*     tolerance specified by the user. In this case RECORD will */
/*     contain the set of Chebychev polynomial coefficients for the */
/*     time interval one of the ends of which was within tolerance */
/*     from the request time, and CKE04 will evaluate RECORD to give */
/*     pointing at the time associated with that interval end time. */


/* $ Examples */

/*     The CKRnn routines are usually used in tandem with the CKEnn */
/*     routines, which evaluate the record returned by CKRnn to give */
/*     the pointing information and output time. */

/*     The following code fragment searches through all of the segments */
/*     in a file applicable to the Mars Global Surveyor spacecraft bus */
/*     that are of data type 4, for a particular spacecraft clock time. */
/*     It then evaluates the pointing for that epoch and prints the */
/*     result. */

/*     C */
/*     C     CK parameters include file. */
/*     C */
/*           INCLUDE               'ckparam.inc' */
/*     C */
/*     C     Declarations */
/*     C */
/*           CHARACTER*(20)        SCLKCH */
/*           CHARACTER*(20)        SCTIME */
/*           CHARACTER*(40)        IDENT */

/*           DOUBLE PRECISION      AV     ( 3 ) */
/*           DOUBLE PRECISION      CLKOUT */
/*           DOUBLE PRECISION      CMAT   ( 3, 3 ) */
/*           DOUBLE PRECISION      DCD    ( 2 ) */
/*           DOUBLE PRECISION      DESCR  ( 5 ) */
/*           DOUBLE PRECISION      RECORD ( CK4RSZ ) */
/*           DOUBLE PRECISION      SCLKDP */
/*           DOUBLE PRECISION      TOL */

/*           INTEGER               HANDLE */
/*           INTEGER               I */
/*           INTEGER               ICD    ( 6 ) */
/*           INTEGER               INST */
/*           INTEGER               SC */

/*           LOGICAL               FND */
/*           LOGICAL               NEEDAV */
/*           LOGICAL               SFND */
/*     C */
/*     C     Initial values. */
/*     C */
/*           SC     = -94 */
/*           INST   = -94000 */
/*           NEEDAV = .FALSE. */
/*     C */
/*     C     Load the MGS SCLK kernel and the C-kernel. */
/*     C */
/*           CALL FURNSH( 'MGS_SCLK.TSC' ) */
/*           CALL DAFOPR( 'MGS_CK4.BC', HANDLE ) */
/*     C */
/*     C     Get the spacecraft clock time. Then encode it for use */
/*     C     in the C-kernel. */
/*     C */
/*           CALL PROMPT( 'Enter SCLK string: ', SCLKCH ) */
/*           CALL SCENCD( SC, SCLKCH, SCLKDP ) */
/*     C */
/*     C     Use a tolerance of 2 seconds (half of the nominal */
/*     C     separation between MGS pointing instances ). */
/*     C */
/*           CALL SCTIKS ( SC, '0000000002:000', TOL ) */
/*     C */
/*     C     Search from the beginning of the CK file through all */
/*     C     of the segments. */
/*     C */
/*           CALL DAFBFS( HANDLE ) */
/*           CALL DAFFNA( SFND   ) */

/*           FND = .FALSE. */

/*           DO WHILE ( ( SFND ) .AND. ( .NOT. FND ) ) */
/*     C */
/*     C        Get the segment identifier and descriptor. */
/*     C */
/*              CALL DAFGN( IDENT ) */
/*              CALL DAFGS( DESCR ) */
/*     C */
/*     C        Unpack the segment descriptor into its integer and */
/*     C        double precision components. */
/*     C */
/*              CALL DAFUS( DESCR, 2, 6, DCD, ICD ) */
/*     C */
/*     C        Determine if this segment should be processed. */
/*     C */
/*              IF ( ( INST          .EQ. ICD( 1 ) ) .AND. */
/*          .        ( SCLKDP + TOL  .GE. DCD( 1 ) ) .AND. */
/*          .        ( SCLKDP - TOL  .LE. DCD( 2 ) ) .AND. */
/*          .        ( CK4DTP        .EQ. ICD( 3 ) )      ) THEN */
/*     C */
/*     C           Find CK 4 record covering requested time. */
/*     C */
/*                 CALL CKR04( HANDLE, DESCR, SCLKDP, TOL, NEEDAV, */
/*          .                  RECORD, FND ) */

/*                 IF ( FND ) THEN */
/*     C */
/*     C              Compute pointing using found CK 4 record. */
/*     C */
/*                    CALL CKE04( NEEDAV, RECORD, CMAT, AV, CLKOUT) */

/*                    CALL SCDECD( SC, CLKOUT, SCTIME ) */

/*                    WRITE (*,*) */
/*                    WRITE (*,*) 'Segment identifier: ', IDENT */
/*                    WRITE (*,*) */
/*                    WRITE (*,*) 'Pointing returned for time: ', */
/*          .                      SCTIME */
/*                    WRITE (*,*) */
/*                    WRITE (*,*) 'C-matrix:' */
/*                    WRITE (*,*) */
/*                    WRITE (*,*) ( CMAT(1,I), I = 1, 3 ) */
/*                    WRITE (*,*) ( CMAT(2,I), I = 1, 3 ) */
/*                    WRITE (*,*) ( CMAT(3,I), I = 1, 3 ) */
/*                    WRITE (*,*) */

/*                 END IF */

/*              END IF */

/*              CALL DAFFNA ( SFND ) */

/*           END DO */

/* $ Restrictions */

/*     1) The file containing the segment should be opened for read */
/*        or write access either by CKLPF, DAFOPR, or DAFOPW. */

/*     2) The record returned by this routine is intended to be */
/*        evaluated by CKE04. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     Y.K. Zaiko     (JPL) */
/*     B.V. Semenov   (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.0.2, 18-APR-2014 (BVS) */

/*        Minor header edits. */

/* -    SPICELIB Version 1.0.1, 22-AUG-2006 (EDW) */

/*        Replaced references to LDPOOL with references */
/*        to FURNSH. */

/* -    SPICELIB Version 1.0.0, 05-MAY-1999 (YKZ) (BVS) */

/* -& */
/* $ Index_Entries */

/*     read record from type_4 CK segment */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("CKR04", (ftnlen)5);
    }

/*     Set initial value of the found flag to "NOT FOUND". */

    *found = FALSE_;

/*     We need to unpack and analyze descriptor components. The */
/*     unpacked descriptor contains the following information */
/*     about the segment: */

/*        DCD(1)  Initial encoded SCLK */
/*        DCD(2)  Final encoded SCLK */
/*        ICD(1)  Instrument */
/*        ICD(2)  Inertial reference frame */
/*        ICD(3)  Data type */
/*        ICD(4)  Angular velocity flag */
/*        ICD(5)  Initial address of segment data */
/*        ICD(6)  Final address of segment data */

    dafus_(descr, &c__2, &c__6, dcd, icd);

/*     Check if the segment is type 4. Signal an error if it's not. */

    if (icd[2] != 4) {
	setmsg_("The segment is not a type 4 segment.  Type is #", (ftnlen)47)
		;
	errint_("#", &icd[2], (ftnlen)1);
	sigerr_("SPICE(WRONGDATATYPE)", (ftnlen)20);
	chkout_("CKR04", (ftnlen)5);
	return 0;
    }
    if (*needav) {

/*        Signal an error if angular velocities are required but */
/*        they are not present in the segment. */

	if (icd[3] != 1) {
	    setmsg_("Segment does not contain angular velocity data.", (
		    ftnlen)47);
	    sigerr_("SPICE(NOAVDATA)", (ftnlen)15);
	    chkout_("CKR04", (ftnlen)5);
	    return 0;
	}
    }

/*     Get number of records (packets) in the segment. */

    cknr04_(handle, descr, &nrec);

/*     Locate the last time in the set of reference epochs less than or */
/*     equal to the input SCLKDP. */

    sgfrvi_(handle, descr, sclkdp, &value, &indx, &exist);
    if (failed_()) {
	chkout_("CKR04", (ftnlen)5);
	return 0;
    }
    if (! exist) {

/*        We didn't find reference value with means that SCLKDP is */
/*        less than the left bound of the first interpolation interval. */
/*        Fetch the first record. */

	indx = 1;
	sgfpkt_(handle, descr, &indx, &indx, record, &ends);
	if (failed_()) {
	    chkout_("CKR04", (ftnlen)5);
	    return 0;
	}
	midpt1 = record[0];
	rad1 = record[1];

/*        Check whether SCLKDP is within TOL of the left bound of the */
/*        first interval. */

	lbnd1 = midpt1 - rad1 - *tol;
	if (*sclkdp >= lbnd1) {
	    *found = TRUE_;
	    clkout = midpt1 - rad1;
	}
    } else {

/*        We found reference value. */

	if (indx >= nrec) {

/*           The SCLKDP is greater than the left bound of the last */
/*           interpolation interval. Fetch the last record. */

	    indx = nrec;
	    sgfpkt_(handle, descr, &indx, &indx, record, &ends);
	    if (failed_()) {
		chkout_("CKR04", (ftnlen)5);
		return 0;
	    }
	    midpt1 = record[0];
	    rad1 = record[1];

/*           Check whether SCLKDP is within TOL of the right bound of */
/*           the last interval. */

	    rbnd1 = midpt1 + rad1 + *tol;
	    if (*sclkdp <= rbnd1) {
		*found = TRUE_;

/*              Check whether SCLKDP falls between right bound of the */
/*              last interval and right bound + TOL. */

		rbnd1 = midpt1 + rad1;
		if (*sclkdp >= rbnd1) {
		    clkout = midpt1 + rad1;
		} else {

/*                 SCLKDP belongs to the last interval */

		    clkout = *sclkdp;
		}
	    }
	} else if (indx >= 1 && indx < nrec) {

/*           The SCLKDP lies between left bound of the first interval */
/*           and the right bound of the interval before the last */
/*           interval. Fetch the found record. */

	    sgfpkt_(handle, descr, &indx, &indx, record, &ends);
	    if (failed_()) {
		chkout_("CKR04", (ftnlen)5);
		return 0;
	    }
	    midpt1 = record[0];
	    rad1 = record[1];

/*           Check whether SCLKDP belongs to current interval. */

	    rbnd1 = midpt1 + rad1;
	    if (*sclkdp <= rbnd1) {
		*found = TRUE_;
		clkout = *sclkdp;
	    } else {

/*              SCLKDP doesn't belong to current interval. Fetch the */
/*              next packet. */

		i__1 = indx + 1;
		i__2 = indx + 1;
		sgfpkt_(handle, descr, &i__1, &i__2, record, &ends);
		if (failed_()) {
		    chkout_("CKR04", (ftnlen)5);
		    return 0;
		}
		midpt2 = record[0];
		rad2 = record[1];

/*              Find the closest interval bound for SCLKDP. */

		rbnd1 = midpt1 + rad1;
		lbnd2 = midpt2 - rad2;
		if (*sclkdp - rbnd1 <= lbnd2 - *sclkdp) {

/*                 SCLKDP is closer to the right bound of current */
/*                 interval. Check whether it's within TOL of it. */

		    rbnd1 = midpt1 + rad1 + *tol;
		    if (*sclkdp <= rbnd1) {
			*found = TRUE_;
			clkout = midpt1 + rad1;

/*                    At this point we need to re-read our current */
/*                    record because it was overwritten by the next */
/*                    record. No FAILED() check here -- we already */
/*                    fetched this packet successfully one call to */
/*                    SGFPKT ago. */

			sgfpkt_(handle, descr, &indx, &indx, record, &ends);
		    }
		} else {

/*                 SCLKDP is closer to the left bound of the next */
/*                 interval. Check whether it's within TOL of it. */

		    lbnd2 = midpt2 - rad2 - *tol;
		    if (*sclkdp >= lbnd2) {
			*found = TRUE_;
			++indx;
			clkout = midpt2 - rad2;
		    }
		}
	    }
	}
    }

/*     If we found the interval on segment the SCLKDP belongs to, then */

    if (*found) {

/*        Decode numbers of polynomial coefficients. */

	zzck4d2i_(&record[2], &c__7, &c_b18, numcft);

/*        Count total number of coefficients. */

	numall = 0;
	for (k = 1; k <= 7; ++k) {
	    numall += numcft[(i__1 = k - 1) < 7 && 0 <= i__1 ? i__1 : s_rnge(
		    "numcft", i__1, "ckr04_", (ftnlen)668)];
	}

/*        Move coefficients to the right and insert numbers of */
/*        coefficients into output RECORD. */

	for (k = numall; k >= 1; --k) {
	    record[k + 9] = record[k + 2];
	}
	for (k = 1; k <= 7; ++k) {
	    record[k + 2] = (doublereal) numcft[(i__1 = k - 1) < 7 && 0 <= 
		    i__1 ? i__1 : s_rnge("numcft", i__1, "ckr04_", (ftnlen)
		    680)];
	}
	record[2] = record[1];
	record[1] = record[0];

/*        Insert CLKOUT into output RECORD */

	record[0] = clkout;
    }

/*     All done. */

    chkout_("CKR04", (ftnlen)5);
    return 0;
} /* ckr04_ */
コード例 #20
0
ファイル: remlac.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure      REMLAC ( Remove elements from a character array ) */
/* Subroutine */ int remlac_(integer *ne, integer *loc, char *array, integer *
	na, ftnlen array_len)
{
    /* System generated locals */
    integer i__1;

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

    /* Local variables */
    integer i__;
    extern /* Subroutine */ int chkin_(char *, ftnlen), sigerr_(char *, 
	    ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen), 
	    errint_(char *, integer *, ftnlen);
    extern logical return_(void);

/* $ Abstract */

/*      Remove one or more elements from a character array at the */
/*      indicated location. */

/* $ 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 */

/*      ARRAY,  ASSIGNMENT */

/* $ Declarations */
/* $ Brief_I/O */

/*      VARIABLE  I/O  DESCRIPTION */
/*      --------  ---  -------------------------------------------------- */
/*      NE         I   Number of elements to be removed. */
/*      LOC        I   Location of the first removed element. */
/*      ARRAY     I/O  Input/output array. */
/*      NA        I/O  Number of elements in the input/output array. */

/* $ Detailed_Input */

/*      NE          is the number of elements to be removed. */

/*      LOC         is the location in the array at which the first */
/*                  element is to be removed. */

/*      ARRAY       on input, is the original array. */

/*      NA          on input, is the number of elements in ARRAY. */

/* $ Detailed_Output */

/*      ARRAY       on output, is the original array with elements */
/*                  LOC through LOC+NE-1 removed. Succeeding elements */
/*                  are moved forward to fill the vacated spaces. */

/*      NA          on output, is the number of elements in ARRAY. */

/* $ Parameters */

/*     None. */

/* $ Particulars */

/*      The elements in positions LOC through LOC+NE-1 are overwritten */
/*      as the elements beginning at LOC+NE are moved back. */

/* $ Examples */

/*      Let */

/*            NA = 7      ARRAY(1) = 'The' */
/*                        ARRAY(2) = 'boy' */
/*                        ARRAY(3) = 'in' */
/*                        ARRAY(4) = 'the' */
/*                        ARRAY(5) = 'park' */
/*                        ARRAY(6) = 'fell' */
/*                        ARRAY(7) = 'down' */

/*      Then the call */

/*            CALL REMLAC ( 3, 3, ARRAY, NA ) */

/*      yields the following result: */

/*            NA = 4      ARRAY(1) = 'The' */
/*                        ARRAY(2) = 'boy' */
/*                        ARRAY(3) = 'fell' */
/*                        ARRAY(4) = 'down' */


/*      The following calls would signal errors: */

/*      CALL REMLAC ( 3,  1, ARRAY, -1 ) */
/*      CALL REMLAC ( 3, -1, ARRAY,  7 ) */
/*      CALL REMLAC ( 3,  6, ARRAY,  7 ) */

/* $ Restrictions */

/*      None. */

/* $ Exceptions */

/*      1) If LOC is not in the interval [1, NA], the error */
/*         SPICE(INVALIDINDEX) is signalled. */

/*      2) If the number of elements to be removed is greater than the */
/*         number of elements that can be removed, the error */
/*         SPICE(NONEXISTELEMENTS) is signalled. */

/*      3) If NE is less than one, the array is not modified. */

/*      4) If NA is less than one, any location is invalid, and the */
/*         error SPICE(INVALIDINDEX) is signalled. */

/* $ Files */

/*      None. */

/* $ Author_and_Institution */

/*      H.A. Neilan     (JPL) */
/*      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 */

/*     remove elements from a character array */

/* -& */
/* $ Revisions */

/* -     Beta Version 2.0.0, 1-JAN-1989 (HAN) */

/*         Code was added to handle the following exceptinoal */
/*         inputs. */

/*         If the dimension of the array is less than one, any */
/*         value of LOC is invalid. The old verison did not check */
/*         the dimension of the array, and as a result, its output */
/*         was unpredictable. */

/*         If the location at which the elements are to be removed is */
/*         not in the interval [1, NA], an error is signalled. */
/*         Locations not within that interval refer to non-existent */
/*         array elements. The old routine did not signal an error. */
/*         It just returned the original array. */

/*         If the number of elements to be removed is greater than the */
/*         number of elements can be removed, an error is signalled. */
/*         In the old version, only those elements that could be */
/*         removed were removed, and no error was signalled. */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("REMLAC", (ftnlen)6);
    }

/*     If LOC does not point to an actual element, signal an error and */
/*     check out. If the dimension of the array is less than one, any */
/*     value of LOC is invalid, and an error is signalled. */

    if (*loc < 1 || *loc > *na) {
	setmsg_("Location was *.", (ftnlen)15);
	errint_("*", loc, (ftnlen)1);
	sigerr_("SPICE(INVALIDINDEX)", (ftnlen)19);
	chkout_("REMLAC", (ftnlen)6);
	return 0;

/*     Don't try to remove non-existent elements. */

    } else if (*ne > *na - *loc + 1) {
	setmsg_("Trying to remove non-existent elements.", (ftnlen)39);
	sigerr_("SPICE(NONEXISTELEMENTS)", (ftnlen)23);
	chkout_("REMLAC", (ftnlen)6);
	return 0;

/*     If there are elements to be removed, remove them. Otherwise, */
/*     do not modify the array. */

    } else if (*ne > 0) {

/*        Move the elements forward. */

	i__1 = *na - *ne;
	for (i__ = *loc; i__ <= i__1; ++i__) {
	    s_copy(array + (i__ - 1) * array_len, array + (i__ + *ne - 1) * 
		    array_len, array_len, array_len);
	}

/*        Update the number of elements in the array. */

	*na -= *ne;
    }
    chkout_("REMLAC", (ftnlen)6);
    return 0;
} /* remlac_ */
コード例 #21
0
/* $Procedure      PARCML ( Parse command line ) */
/* Subroutine */ int parcml_(char *line, integer *nkeys, char *clkeys, 
	logical *clflag, char *clvals, logical *found, char *unprsd, ftnlen 
	line_len, ftnlen clkeys_len, ftnlen clvals_len, ftnlen unprsd_len)
{
    /* System generated locals */
    address a__1[2];
    integer i__1, i__2[2];
    char ch__1[2049];

    /* 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);

    /* Local variables */
    static char hkey[2048];
    static integer i__;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    static char hline[2048];
    extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
    static integer clidx;
    static char lngwd[2048], uline[2048];
    extern integer rtrim_(char *, ftnlen);
    extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
    extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
    static integer begpos;
    static char hlngwd[2048];
    static integer pclidx, endpos;
    extern /* Subroutine */ int chkout_(char *, ftnlen), nextwd_(char *, char 
	    *, char *, ftnlen, ftnlen, ftnlen);
    extern logical return_(void);
    extern integer pos_(char *, char *, integer *, ftnlen, ftnlen);

/* $ Abstract */

/*     Parse a command-line like string in the "key value key value ..." */
/*     format with keys provided in any order and any letter case */
/*     (lower, upper, mixed) and return values of requested keys. */

/* $ 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 */

/*     PARSING */

/* $ Declarations */
/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  -------------------------------------------------- */
/*     LINE      I/O  Input command-line like string. */
/*     NKEYS      I   Number of keys to look for. */
/*     CLKEYS     I   Keys to look for. */
/*     CLFLAG     O   "A particular key found" flags. */
/*     CLVALS     O   Key values. */
/*     FOUND      O   "At least one key found" flag. */
/*     UNPRSD     O   Beginning part of the LINE that was not parsed */
/*     LLNSIZ     P   Size of longest sub-string that can be processed. */

/* $ Detailed_Input */

/*     LINE        is the input command-line like string in the "key */
/*                 value key value ..." format. The line should start */
/*                 with one of the keys provided in CLKEYS as the */
/*                 routine ignores any words before the first recognized */
/*                 key. */

/*                 To avoid limiting the size of the input string that */
/*                 can be processed, this routine uses LINE as the work */
/*                 buffer; it modifies LINE in the process of execution, */
/*                 and sets it to blank before return. */

/*     NKEYS       is the number of keys to look for provided in the */
/*                 CLKEYS array. */

/*     CLKEYS      is an array of keys to look for. Individual keys */
/*                 must be left-justified string consisting of any */
/*                 printable the characters except lower-case letters */
/*                 and blanks. */

/* $ Detailed_Output */

/*     LINE        is set to blank on the output. */

/*     CLFLAG      are the "key found" flags; set to TRUE if */
/*                 corresponding key was found. */

/*     CLVALS      are the key values; if a key wasn't found, its value */
/*                 set to a blank string. */

/*     FOUND       is set to .TRUE. if at least one key was found. */
/*                 Otherwise it is set to .FALSE. */

/*     UNPRSD      is the beginning part of the LINE, preceeding the */
/*                 first recognized key, that was ignored by this */
/*                 routine. */

/* $ Parameters */

/*     LLNSIZ      is the size of the internal buffer that holds a */
/*                 portion of the input string that is being examined. */
/*                 It limits the maximum total length of a front and */
/*                 back blank-padded, blank-separated sub-string */
/*                 containing a key, the value that follows it, and the */
/*                 next key (e.g. ' key value key ') that this routine */
/*                 can correctly process. */

/* $ Exceptions */

/*     None. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     This routine modifies the input string. It returns it set to */
/*     blank. */

/*     The case of the keys in the input string is not significant. */

/*     The order of keys in the input string is not significant. */

/*     If any key appears in the string more than once, only the */
/*     last value of that key is returned. */

/*     The part of the line from the start up to the first recognized */
/*     key is returned in the UNPRSD argument. */

/* $ Examples */

/*     If CLKEYS are */

/*        CLKEYS(1) = '-SETUP' */
/*        CLKEYS(2) = '-TO' */
/*        CLKEYS(3) = '-FROM' */
/*        CLKEYS(4) = '-HELP' */

/*     then: */

/*     line '-setup my.file -FROM utc -TO sclk' */
/*     will be parsed as */

/*        CLFLAG(1) = .TRUE.       CLVALS(1) = 'my.file' */
/*        CLFLAG(2) = .TRUE.       CLVALS(2) = 'utc' */
/*        CLFLAG(3) = .TRUE.       CLVALS(3) = 'sclk' */
/*        CLFLAG(4) = .FALSE.      CLVALS(4) = ' ' */
/*        UNPRSD    = ' ' */
/*        FOUND = .TRUE. */

/*     line '-bogus -setup my.file -FROM utc -TO sclk' */
/*     will be parsed as */

/*        CLFLAG(1) = .TRUE.       CLVALS(1) = 'my.file' */
/*        CLFLAG(2) = .TRUE.       CLVALS(2) = 'utc' */
/*        CLFLAG(3) = .TRUE.       CLVALS(3) = 'sclk' */
/*        CLFLAG(4) = .FALSE.      CLVALS(4) = ' ' */
/*        UNPRSD    = '-bogus' */
/*        FOUND = .TRUE. */

/*     line 'why not -setup my.file -FROM utc -TO sclk' */
/*     will be parsed as */

/*        CLFLAG(1) = .TRUE.       CLVALS(1) = 'my.file' */
/*        CLFLAG(2) = .TRUE.       CLVALS(2) = 'utc' */
/*        CLFLAG(3) = .TRUE.       CLVALS(3) = 'sclk' */
/*        CLFLAG(4) = .FALSE.      CLVALS(4) = ' ' */
/*        UNPRSD    = 'why not' */
/*        FOUND = .TRUE. */

/*     line '-SETUP my.file -setup your.file' */
/*     will be parsed as */

/*        CLFLAG(1) = .TRUE.       CLVALS(1) = 'your.file' */
/*        CLFLAG(2) = .FALSE.      CLVALS(2) = ' ' */
/*        CLFLAG(3) = .FALSE.      CLVALS(3) = ' ' */
/*        CLFLAG(4) = .FALSE.      CLVALS(4) = ' ' */
/*        UNPRSD    = ' ' */
/*        FOUND = .TRUE. */

/*     line '-setup my.file -SeTuP your.file' */
/*     will be parsed as */

/*        CLFLAG(1) = .TRUE.       CLVALS(1) = 'your.file' */
/*        CLFLAG(2) = .FALSE.      CLVALS(2) = ' ' */
/*        CLFLAG(3) = .FALSE.      CLVALS(3) = ' ' */
/*        CLFLAG(4) = .FALSE.      CLVALS(4) = ' ' */
/*        UNPRSD    = ' ' */
/*        FOUND = .TRUE. */

/*     line '-help' */
/*     will be parsed as */

/*        CLFLAG(1) = .FALSE.      CLVALS(1) = ' ' */
/*        CLFLAG(2) = .FALSE.      CLVALS(2) = ' ' */
/*        CLFLAG(3) = .FALSE.      CLVALS(3) = ' ' */
/*        CLFLAG(4) = .TRUE.       CLVALS(4) = ' ' */
/*        UNPRSD    = ' ' */
/*        FOUND = .TRUE. */

/*     and so on. */

/* $ Restrictions */

/*     This routine cannot process input lines with any ' -key value */
/*     -key ' sub-string that is longer than LLNSIZ. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     B.V. Semenov    (JPL) */

/* $ Version */

/* -    SUPPORT Version 1.0.0, 15-FEB-2012 (BVS) */

/* -& */

/*     Local variables. */


/*     Save everything to prevent potential memory problems in f2c'ed */
/*     version. */


/*     SPICELIB functions. */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("PARCML", (ftnlen)6);
    }

/*     Set initial values of keys to blanks and flags to .FALSE. */

    i__1 = *nkeys;
    for (i__ = 1; i__ <= i__1; ++i__) {
	clflag[i__ - 1] = FALSE_;
	s_copy(clvals + (i__ - 1) * clvals_len, " ", clvals_len, (ftnlen)1);
    }
    *found = FALSE_;

/*     Parsing loop. We will set the sub-string buffer HLINE to as many */
/*     characters from the input line as it will fit, starting with the */
/*     initial part of the line on the first iteration and resetting to */
/*     sub-strings starting at the first character of each value after */
/*     the previous key-value pair was processed, and will pick at HLINE */
/*     word by word looking for recognized keys. The loop will */
/*     continue until we reach the end of the string -- all key-value */
/*     pairs were processed and the sub-string buffer HLINE was set to */
/*     blank. */

    s_copy(hline, line, (ftnlen)2048, line_len);
    pclidx = 0;
    clidx = 0;
    s_copy(unprsd, line, unprsd_len, line_len);
    while(s_cmp(hline, " ", (ftnlen)2048, (ftnlen)1) != 0) {

/*        Get next word; uppercase it; look for it in the input keys */
/*        array. */

	nextwd_(hline, lngwd, hline, (ftnlen)2048, (ftnlen)2048, (ftnlen)2048)
		;
	ucase_(lngwd, hlngwd, (ftnlen)2048, (ftnlen)2048);
	clidx = isrchc_(hlngwd, nkeys, clkeys, (ftnlen)2048, clkeys_len);

/*        Is the token that we found a recognized key? */

	if (clidx != 0) {

/*           Yes, it is. Is it the first key that we have found? */

	    if (pclidx != 0) {

/*              No it is not. We need to save the value of the previous */
/*              key. */

/*              Compute the begin and end positions of the sub-string */
/*              that contains the previous value by looking for the */
/*              previous and current keys in the upper-cased remainder of */
/*              the input line. */

/*              The begin position is the position of the previous key */
/*              plus its length. The end position is the position of the */
/*              front-n-back blank-padded current key. */

		ucase_(line, uline, line_len, (ftnlen)2048);
		begpos = pos_(uline, clkeys + (pclidx - 1) * clkeys_len, &
			c__1, (ftnlen)2048, rtrim_(clkeys + (pclidx - 1) * 
			clkeys_len, clkeys_len)) + rtrim_(clkeys + (pclidx - 
			1) * clkeys_len, clkeys_len);
/* Writing concatenation */
		i__2[0] = 1, a__1[0] = " ";
		i__2[1] = rtrim_(clkeys + (clidx - 1) * clkeys_len, 
			clkeys_len), a__1[1] = clkeys + (clidx - 1) * 
			clkeys_len;
		s_cat(hkey, a__1, i__2, &c__2, (ftnlen)2048);
/* Writing concatenation */
		i__2[0] = 2048, a__1[0] = uline;
		i__2[1] = 1, a__1[1] = " ";
		s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2049);
		endpos = pos_(ch__1, hkey, &begpos, (ftnlen)2049, rtrim_(hkey,
			 (ftnlen)2048) + 1);

/*              Extract the value, left-justify it, and RTRIM it. Set */
/*              "value found" flag to .TRUE. */

		s_copy(clvals + (pclidx - 1) * clvals_len, line + (begpos - 1)
			, clvals_len, endpos - (begpos - 1));
		ljust_(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 
			1) * clvals_len, clvals_len, clvals_len);
		s_copy(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 
			1) * clvals_len, clvals_len, rtrim_(clvals + (pclidx 
			- 1) * clvals_len, clvals_len));
		clflag[pclidx - 1] = TRUE_;

/*              Check whether we already parsed the whole line. It will */
/*              be so if the remainder of the buffer holding the */
/*              sub-string that we examine word-by-word is a blank */
/*              string. */

		if (s_cmp(hline, " ", (ftnlen)2048, (ftnlen)1) != 0) {

/*                 No, we did not parse the whole line yet. There is */
/*                 more stuff to parse and we reset the temporary */
/*                 sub-string buffer to hold the part of the input string */
/*                 starting with the first character after the current */
/*                 key -- the end position plus the length of the */
/*                 current key. */


		    i__1 = endpos + 1 + rtrim_(clkeys + (clidx - 1) * 
			    clkeys_len, clkeys_len) - 1;
		    s_copy(hline, line + i__1, (ftnlen)2048, line_len - i__1);
		}

/*              Now reset the line to its portion starting with the */
/*              first character of the current key. */

		i__1 = endpos;
		s_copy(line, line + i__1, line_len, line_len - i__1);
	    } else {

/*              This is the first key that we have found. Set UNPRSD */
/*              to the part of the line from the start to this key. */

		ucase_(line, uline, line_len, (ftnlen)2048);
/* Writing concatenation */
		i__2[0] = 1, a__1[0] = " ";
		i__2[1] = rtrim_(clkeys + (clidx - 1) * clkeys_len, 
			clkeys_len), a__1[1] = clkeys + (clidx - 1) * 
			clkeys_len;
		s_cat(hkey, a__1, i__2, &c__2, (ftnlen)2048);
/* Writing concatenation */
		i__2[0] = 1, a__1[0] = " ";
		i__2[1] = 2048, a__1[1] = uline;
		s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2049);
		begpos = pos_(ch__1, hkey, &c__1, (ftnlen)2049, rtrim_(hkey, (
			ftnlen)2048) + 1);
		if (begpos <= 1) {
		    s_copy(unprsd, " ", unprsd_len, (ftnlen)1);
		} else {
		    s_copy(unprsd, line, unprsd_len, begpos - 1);
		}
	    }

/*           Save the current key index in as previous. */

	    pclidx = clidx;
	}
    }

/*     If we found at least one recognized key, we need to save the last */
/*     value. */

    if (pclidx != 0) {

/*        Set "found any" output flag and "found previous key" flags to */
/*        .TRUE. */

	*found = TRUE_;
	clflag[pclidx - 1] = TRUE_;

/*        Check if there was any value following the last key (there was */
/*        if the non-blank length of what's left in the line starting */
/*        with the last key if greater than the non-blank length of the */
/*        last key). */

	if (rtrim_(line, line_len) > rtrim_(clkeys + (pclidx - 1) * 
		clkeys_len, clkeys_len)) {

/*           Compute begin position of, extract, left justify and */
/*           RTRIM the last value. */

	    ucase_(line, uline, line_len, (ftnlen)2048);
	    begpos = pos_(uline, clkeys + (pclidx - 1) * clkeys_len, &c__1, (
		    ftnlen)2048, rtrim_(clkeys + (pclidx - 1) * clkeys_len, 
		    clkeys_len)) + rtrim_(clkeys + (pclidx - 1) * clkeys_len, 
		    clkeys_len);
	    s_copy(clvals + (pclidx - 1) * clvals_len, line + (begpos - 1), 
		    clvals_len, line_len - (begpos - 1));
	    ljust_(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 1) *
		     clvals_len, clvals_len, clvals_len);
	    s_copy(clvals + (pclidx - 1) * clvals_len, clvals + (pclidx - 1) *
		     clvals_len, clvals_len, rtrim_(clvals + (pclidx - 1) * 
		    clvals_len, clvals_len));
	} else {

/*           The key was the last thing on the line. So, it's value is */
/*           blank. */

	    s_copy(clvals + (pclidx - 1) * clvals_len, " ", clvals_len, (
		    ftnlen)1);
	}
    }
    chkout_("PARCML", (ftnlen)6);
    return 0;
} /* parcml_ */
コード例 #22
0
ファイル: zzddhrmu.c プロジェクト: Dbelsa/coft
/* $Procedure ZZDDHRMU ( Private --- DDH Remove Unit ) */
/* Subroutine */ int zzddhrmu_(integer *uindex, integer *nft, integer *utcst, 
	integer *uthan, logical *utlck, integer *utlun, integer *nut)
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    integer i__;
    extern /* Subroutine */ int chkin_(char *, ftnlen), sigerr_(char *, 
	    ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen), 
	    errint_(char *, integer *, ftnlen), reslun_(integer *);

/* $ 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. */

/*     Remove an entry from the unit table. */

/* $ 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 */

/*     PRIVATE */

/* $ Declarations */

/* $ Abstract */

/*     Parameter declarations for the DAF/DAS handle manager. */

/* $ 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 */

/*     DAF, DAS */

/* $ Keywords */

/*     PRIVATE */

/* $ Particulars */

/*     This include file contains parameters defining limits and */
/*     integer codes that are utilized in the DAF/DAS handle manager */
/*     routines. */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     F.S. Turner       (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 2.5.0, 10-MAR-2014 (BVS) */

/*        Updated for SUN-SOLARIS-64BIT-INTEL. */

/* -    SPICELIB Version 2.4.0, 10-MAR-2014 (BVS) */

/*        Updated for PC-LINUX-64BIT-IFORT. */

/* -    SPICELIB Version 2.3.0, 10-MAR-2014 (BVS) */

/*        Updated for PC-CYGWIN-GFORTRAN. */

/* -    SPICELIB Version 2.2.0, 10-MAR-2014 (BVS) */

/*        Updated for PC-CYGWIN-64BIT-GFORTRAN. */

/* -    SPICELIB Version 2.1.0, 10-MAR-2014 (BVS) */

/*        Updated for PC-CYGWIN-64BIT-GCC_C. */

/* -    SPICELIB Version 2.0.0, 12-APR-2012 (BVS) */

/*        Increased FTSIZE (from 1000 to 5000). */

/* -    SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */

/*        Updated for SUN-SOLARIS-INTEL. */

/* -    SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */

/*        Updated for SUN-SOLARIS-INTEL-CC_C. */

/* -    SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */

/*        Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */

/* -    SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */

/*        Updated for SUN-SOLARIS-64BIT-NATIVE_C. */

/* -    SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */

/*        Updated for PC-WINDOWS-64BIT-IFORT. */

/* -    SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */

/*        Updated for PC-LINUX-64BIT-GFORTRAN. */

/* -    SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */

/*        Updated for PC-64BIT-MS_C. */

/* -    SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */

/*        Updated for MAC-OSX-64BIT-INTEL_C. */

/* -    SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */

/*        Updated for MAC-OSX-64BIT-IFORT. */

/* -    SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */

/*        Updated for MAC-OSX-64BIT-GFORTRAN. */

/* -    SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */

/*        Updated for PC-LINUX-GFORTRAN. */

/* -    SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */

/*        Updated for MAC-OSX-GFORTRAN. */

/* -    SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */

/*        Updated for PC-LINUX-IFORT. */

/* -    SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */

/*        Updated for PC-LINUX-64BIT-GCC_C. */

/* -    SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */

/*        Updated for MAC-OSX-INTEL_C. */

/* -    SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */

/*        Updated for MAC-OSX-IFORT. */

/* -    SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */

/*        Updated for PC-WINDOWS-IFORT. */

/* -    SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */

/*        Updated for SUN-SOLARIS-64BIT-GCC_C. */

/* -    SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */

/*        Updated for PC-CYGWIN_C. */

/* -    SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */

/*        Updated for PC-CYGWIN. */

/* -    SPICELIB Version 1.0.1, 17-JUL-2002 */

/*        Added MAC-OSX environments. */

/* -    SPICELIB Version 1.0.0, 07-NOV-2001 */

/* -& */

/*     Unit and file table size parameters. */

/*     FTSIZE     is the maximum number of files (DAS and DAF) that a */
/*                user may have open simultaneously. */


/*     RSVUNT     is the number of units protected from being locked */
/*                to a particular handle by ZZDDHHLU. */


/*     SCRUNT     is the number of units protected for use by scratch */
/*                files. */


/*     UTSIZE     is the maximum number of logical units this manager */
/*                will utilize at one time. */


/*     Access method enumeration.  These parameters are used to */
/*     identify which access method is associated with a particular */
/*     handle.  They need to be synchronized with the STRAMH array */
/*     defined in ZZDDHGSD in the following fashion: */

/*        STRAMH ( READ   ) = 'READ' */
/*        STRAMH ( WRITE  ) = 'WRITE' */
/*        STRAMH ( SCRTCH ) = 'SCRATCH' */
/*        STRAMH ( NEW    ) = 'NEW' */

/*     These values are used in the file table variable FTAMH. */


/*     Binary file format enumeration.  These parameters are used to */
/*     identify which binary file format is associated with a */
/*     particular handle.  They need to be synchronized with the STRBFF */
/*     array defined in ZZDDHGSD in the following fashion: */

/*        STRBFF ( BIGI3E ) = 'BIG-IEEE' */
/*        STRBFF ( LTLI3E ) = 'LTL-IEEE' */
/*        STRBFF ( VAXGFL ) = 'VAX-GFLT' */
/*        STRBFF ( VAXDFL ) = 'VAX-DFLT' */

/*     These values are used in the file table variable FTBFF. */


/*     Some random string lengths... more documentation required. */
/*     For now this will have to suffice. */


/*     Architecture enumeration.  These parameters are used to identify */
/*     which file architecture is associated with a particular handle. */
/*     They need to be synchronized with the STRARC array defined in */
/*     ZZDDHGSD in the following fashion: */

/*        STRARC ( DAF ) = 'DAF' */
/*        STRARC ( DAS ) = 'DAS' */

/*     These values will be used in the file table variable FTARC. */


/*     For the following environments, record length is measured in */
/*     characters (bytes) with eight characters per double precision */
/*     number. */

/*     Environment: Sun, Sun FORTRAN */
/*     Source:      Sun Fortran Programmer's Guide */

/*     Environment: PC, MS FORTRAN */
/*     Source:      Microsoft Fortran Optimizing Compiler User's Guide */

/*     Environment: Macintosh, Language Systems FORTRAN */
/*     Source:      Language Systems FORTRAN Reference Manual, */
/*                  Version 1.2, page 12-7 */

/*     Environment: PC/Linux, g77 */
/*     Source:      Determined by experiment. */

/*     Environment: PC, Lahey F77 EM/32 Version 4.0 */
/*     Source:      Lahey F77 EM/32 Language Reference Manual, */
/*                  page 144 */

/*     Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */
/*     Source:      FORTRAN/9000 Reference-Series 700 Computers, */
/*                  page 5-110 */

/*     Environment: NeXT Mach OS (Black Hardware), */
/*                  Absoft Fortran Version 3.2 */
/*     Source:      NAIF Program */


/*     The following parameter defines the size of a string used */
/*     to store a filenames on this target platform. */


/*     The following parameter controls the size of the character record */
/*     buffer used to read data from non-native files. */

/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  -------------------------------------------------- */
/*     UINDEX     I   Row index to remove from the unit table. */
/*     NFT        I   Number of entries in the file table. */
/*     UTCST, */
/*     UTHAN, */
/*     UTLCK, */
/*     UTLUN     I/O  Unit table. */
/*     NUT       I/O  Number of entries in the unit table. */

/* $ Detailed_Input */

/*     HANDLE     is the index of the row in the unit table for the */
/*                unit to remove. */

/*     NFT        is the number of entries in the file table after */
/*                the file whose unit is about to be disconnected */
/*                has been removed. */

/*     UTCST, */
/*     UTHAN, */
/*     UTLCK, */
/*     UTLUN,     are the cost, handle, locked, and logical unit columns */
/*                of the unit table respectively. */

/*     NUT        is the number of entries in the unit table. */

/* $ Detailed_Output */

/*     UTCST, */
/*     UTHAN, */
/*     UTLCK, */
/*     UTLUN,     are the cost, handle, locked, and logical unit columns */
/*                of the unit table respectively.  The contents will */
/*                change, for specifics see the Particulars section */
/*                below. */

/*     NUT        is the number of entries in the unit table.  Depending */
/*                on the state of the file table, this may or may not */
/*                change.  See the $Particulars section below for */
/*                details. */

/* $ Parameters */

/*     None. */

/* $ Files */

/*     None. */

/* $ Exceptions */

/*     1) SPICE(INDEXOUTOFRANGE) is signaled when the input UINDEX is */
/*        either greater than NUT or less than 1. */

/*     2) If NUT is 0 on input, then this module simply returns. */

/* $ Particulars */

/*     This routine only manipulates the contents of the unit table. */
/*     It is utilized to delete an entry in the unit table that is */
/*     the result of a file 'unload' or close operation. */

/*     If the number of files listed in the file table exceeds the */
/*     number of entries in the unit table, then this module will */
/*     reserve the logical unit listed in the row to remove, zero */
/*     out the cost and return.  In this event, NUT will remain */
/*     unchanged. */

/*     However, if there are less files in the file table than the */
/*     number of entries in the unit table, then this routine removes */
/*     the row and compresses the unit table, as one would expect. */

/*     The file attached to UNIT is not closed by this routine, the */
/*     closure should occur before invoking this module. */

/* $ Examples */

/*     See ZZDDHHLU for sample usage. */

/* $ Restrictions */

/*     1) This routine operates when an error condition introduced */
/*        by a prior call to SIGERR exists.  It calls no routines */
/*        that return on entry when proper inputs are provided. */
/*        Any updates to this routine must preserve this behavior. */

/*     2) The file attached to the unit that is to be removed should */
/*        already have been removed from the file table.  This is */
/*        necessary so the value of NFT reflects the number of files */
/*        available after the removal. */

/*     3) The logical unit in UTLUN(UINDEX) must be closed or buffered */
/*        externally prior to calling this routine.  Knowledge of its */
/*        value could be lost otherwise. */

/* $ Author_and_Institution */

/*     F.S. Turner     (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 05-NOV-2001 (FST) */


/* -& */

/*     Local Variables */


/*     First check to see if NUT is 0.  If so, just return, as there */
/*     are no rows to remove. */

    if (*nut == 0) {
	return 0;
    }

/*     Check to see if we found the UINDEX in the unit table. */
/*     If not, use discovery check-in, signal an error and return. */

    if (*uindex > *nut || *uindex < 1) {
	chkin_("ZZDDHRMU", (ftnlen)8);
	setmsg_("Attempt to remove row # from the unit table failed because "
		"valid row indices range from 1 to NUT.", (ftnlen)97);
	errint_("#", uindex, (ftnlen)1);
	errint_("#", nut, (ftnlen)1);
	sigerr_("SPICE(INDEXOUTOFRANGE)", (ftnlen)22);
	chkout_("ZZDDHRMU", (ftnlen)8);
	return 0;
    }

/*     We have found the row we need to remove from the table. */
/*     Check to see whether we are to remove this row or simply */
/*     mark it as zero cost and reserve the unit.  We know this */
/*     is the case when NFT is greater than or equal to NUT. */

    if (*nft >= *nut) {

/*        Zero the cost, clear the handle, and unlock the unit. */

	utcst[*uindex - 1] = 0;
	uthan[*uindex - 1] = 0;
	utlck[*uindex - 1] = FALSE_;

/*        Reserve the unit for the handle manager's usage and */
/*        return. */

	reslun_(&utlun[*uindex - 1]);
	return 0;
    }

/*     If we reach here, then we have to remove the row from the */
/*     unit table and compress. */

    i__1 = *nut;
    for (i__ = *uindex + 1; i__ <= i__1; ++i__) {
	utcst[i__ - 2] = utcst[i__ - 1];
	uthan[i__ - 2] = uthan[i__ - 1];
	utlck[i__ - 2] = utlck[i__ - 1];
	utlun[i__ - 2] = utlun[i__ - 1];
    }

/*     Decrement NUT. */

    --(*nut);
    return 0;
} /* zzddhrmu_ */
コード例 #23
0
/* $Procedure      PODREC ( Pod, remove elements, character ) */
/* Subroutine */ int podrec_(integer *n, integer *loc, char *pod, ftnlen 
	pod_len)
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    extern /* Subroutine */ int chkin_(char *, ftnlen), scardc_(integer *, 
	    char *, ftnlen), remlac_(integer *, integer *, char *, integer *, 
	    ftnlen), podonc_(char *, integer *, integer *, ftnlen);
    integer offset, number;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), setmsg_(char *, ftnlen), errint_(char *, integer *, 
	    ftnlen);
    extern logical return_(void);
    integer end;

/* $ Abstract */

/*     Remove elements beginning at a specified location within the */
/*     active group of a pod. */

/* $ 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 */

/*     PODS */

/* $ Keywords */

/*     ARRAY */
/*     CELLS */
/*     PODS */

/* $ Declarations */
/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     N          I   Number of elements to remove. */
/*     LOC        I   Location of first element to be removed. */
/*     POD       I,O  Pod. */

/* $ Detailed_Input */

/*     N          is the number of elements to be removed from the */
/*                active group of POD. */

/*     LOC        is the location (within the active group of the pod) */
/*                of the first element to be removed. */

/*     POD        on input, is a pod. */

/* $ Detailed_Output */

/*     POD        on output, is the same pod, the active group of */
/*                which contains the elements preceding and following */
/*                the removed elements. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1) If N is not positive, the pod is not changed. */

/*     2) If the location of the last element to be removed (LOC+N-1) */
/*        is greater than the number of elements in the active group, */
/*        the pod is not changed, and the error SPICE(NOTENOUGHPEAS) */
/*        is signalled. */

/*     3) If the location specified for location is not in the range */
/*        [1,NC], where NC is the number of elements in the active */
/*        group of the pod, the pod is not changed, and the error */
/*        SPICE(BADPODLOCATION) is signalled. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     This routine allows you to remove elements from the active */
/*     group of a pod without having to worry about checking for */
/*     impossible requests beforehand, or updating the cardinality */
/*     afterwards. */

/* $ Examples */

/*     Elements can be removed from the active group of a pod */
/*     by hand, */

/*        CALL PODONC ( POD, OFFSET, NUMBER ) */
/*        END = OFFSET + NUMBER */

/*        CALL REMLAC ( N,   OFFSET + LOC, POD(1), END ) */
/*        CALL SCARDC ( END,               POD         ) */

/*     However, this is tedious, and it gets worse when you have to */
/*     check for impossible requests. PODRE accomplishes the same thing, */

/*        CALL PODIEC ( N, LOC, POD ) */

/*     more simply, and with error-handling built in. */

/* $ Restrictions */

/*     1) In any pod, only the active group should be accessed, */
/*        and its location should always be determined by PODBE */
/*        or PODON. Never assume that the active group begins */
/*        at POD(1). */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     W.L. Taber     (JPL) */
/*     I.M. Underwood (JPL) */

/* $ Version */

/* -    Beta Version 1.0.0, 15-JUL-1989 (WLT) (IMU) */


/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("PODREC", (ftnlen)6);
    }

/*     Three things can go `wrong': */

/*        1) No items to remove. */

/*        2) Too many items to remove. */

/*        3) No place to remove them from. */

    podonc_(pod, &offset, &number, pod_len);
    if (*n < 1) {
	chkout_("PODREC", (ftnlen)6);
	return 0;
    } else if (*loc + *n - 1 > number) {
	setmsg_("LOC = #; N = #; there are only # elements.", (ftnlen)42);
	errint_("#", loc, (ftnlen)1);
	errint_("#", n, (ftnlen)1);
	errint_("#", &number, (ftnlen)1);
	sigerr_("SPICE(NOTENOUGHPEAS)", (ftnlen)20);
	chkout_("PODREC", (ftnlen)6);
	return 0;
    } else if (*loc < 1 || *loc > number) {
	setmsg_("Location (#) must be in the range [1,#].", (ftnlen)40);
	errint_("#", loc, (ftnlen)1);
	errint_("#", &number, (ftnlen)1);
	sigerr_("SPICE(BADPODLOCATION)", (ftnlen)21);
	chkout_("PODREC", (ftnlen)6);
	return 0;
    }

/*     No problem. This is just like $Examples, above. */

    end = offset + number;
    i__1 = offset + *loc;
    remlac_(n, &i__1, pod + pod_len * 6, &end, pod_len);
    scardc_(&end, pod, pod_len);
    chkout_("PODREC", (ftnlen)6);
    return 0;
} /* podrec_ */
コード例 #24
0
ファイル: zzspkzp0.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure ZZSPKZP0 ( S/P Kernel, easy position ) */
/* Subroutine */ int zzspkzp0_(integer *targ, doublereal *et, char *ref, char 
	*abcorr, integer *obs, doublereal *ptarg, doublereal *lt, ftnlen 
	ref_len, ftnlen abcorr_len)
{
    /* Initialized data */

    static logical first = TRUE_;

    /* System generated locals */
    doublereal d__1;

    /* Local variables */
    static integer fj2000;
    extern /* Subroutine */ int zzrefch0_(integer *, integer *, doublereal *, 
	    doublereal *), zzspkpa0_(integer *, doublereal *, char *, 
	    doublereal *, char *, doublereal *, doublereal *, ftnlen, ftnlen);
    static doublereal temp[3], sobs[6];
    extern /* Subroutine */ int zzspkgp0_(integer *, doublereal *, char *, 
	    integer *, doublereal *, doublereal *, ftnlen), zzspksb0_(integer 
	    *, doublereal *, char *, doublereal *, ftnlen);
    static integer type__;
    static logical xmit;
    extern /* Subroutine */ int zznamfrm_(integer *, char *, integer *, char *
	    , integer *, ftnlen, ftnlen), zzctruin_(integer *);
    static integer i__;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    extern logical eqchr_(char *, char *, ftnlen, ftnlen);
    extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
    static logical found;
    static char svref[32];
    extern integer ltrim_(char *, ftnlen);
    static doublereal xform[9]	/* was [3][3] */;
    extern logical eqstr_(char *, char *, ftnlen, ftnlen);
    static doublereal postn[3];
    static integer svctr1[2];
    extern logical failed_(void);
    static integer center;
    extern /* Subroutine */ int namfrm_(char *, integer *, ftnlen), frinfo_(
	    integer *, integer *, integer *, integer *, logical *);
    static doublereal ltcent;
    extern /* Subroutine */ int sigerr_(char *, ftnlen);
    static integer reqfrm, typeid;
    extern /* Subroutine */ int chkout_(char *, ftnlen), setmsg_(char *, 
	    ftnlen);
    static integer svreqf;
    extern logical return_(void);
    extern /* Subroutine */ int mxv_(doublereal *, doublereal *, doublereal *)
	    ;

/* $ Abstract */

/*     Return the position of a target body relative to an observing */
/*     body, optionally corrected for light time (planetary aberration) */
/*     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 */
/*     NAIF_IDS */
/*     FRAMES */
/*     TIME */

/* $ Keywords */

/*     EPHEMERIS */

/* $ Declarations */
/* $ Abstract */

/*     The parameters below form an enumerated list of the recognized */
/*     frame types.  They are: INERTL, PCK, CK, TK, DYN.  The meanings */
/*     are outlined below. */

/* $ 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. */

/* $ Parameters */

/*     INERTL      an inertial frame that is listed in the routine */
/*                 CHGIRF and that requires no external file to */
/*                 compute the transformation from or to any other */
/*                 inertial frame. */

/*     PCK         is a frame that is specified relative to some */
/*                 INERTL frame and that has an IAU model that */
/*                 may be retrieved from the PCK system via a call */
/*                 to the routine TISBOD. */

/*     CK          is a frame defined by a C-kernel. */

/*     TK          is a "text kernel" frame.  These frames are offset */
/*                 from their associated "relative" frames by a */
/*                 constant rotation. */

/*     DYN         is a "dynamic" frame.  These currently are */
/*                 parameterized, built-in frames where the full frame */
/*                 definition depends on parameters supplied via a */
/*                 frame kernel. */

/*     ALL         indicates any of the above classes. This parameter */
/*                 is used in APIs that fetch information about frames */
/*                 of a specified class. */


/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */
/*     W.L. Taber      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 4.0.0, 08-MAY-2012 (NJB) */

/*       The parameter ALL was added to support frame fetch APIs. */

/* -    SPICELIB Version 3.0.0, 28-MAY-2004 (NJB) */

/*       The parameter DYN was added to support the dynamic frame class. */

/* -    SPICELIB Version 2.0.0, 12-DEC-1996 (WLT) */

/*        Various unused frames types were removed and the */
/*        frame time TK was added. */

/* -    SPICELIB Version 1.0.0, 10-DEC-1995 (WLT) */

/* -& */

/*     End of INCLUDE file frmtyp.inc */

/* $ Abstract */

/*     This include file defines the dimension of the counter */
/*     array used by various SPICE subsystems to uniquely identify */
/*     changes in their states. */

/* $ 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. */

/* $ Parameters */

/*     CTRSIZ      is the dimension of the counter array used by */
/*                 various SPICE subsystems to uniquely identify */
/*                 changes in their states. */

/* $ Author_and_Institution */

/*     B.V. Semenov    (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 29-JUL-2013 (BVS) */

/* -& */

/*     End of include file. */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     TARG       I   Target body NAIF ID code. */
/*     ET         I   Observer epoch. */
/*     REF        I   Reference frame of output position vector. */
/*     ABCORR     I   Aberration correction flag. */
/*     OBS        I   Observing body NAIF ID code. */
/*     PTARG      O   Position 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 position vector which points */
/*                 from the observer to the target. */

/*     ET          is the ephemeris time, expressed as seconds past */
/*                 J2000 TDB, at which the position of the target body */
/*                 relative to the observer is to be computed.  ET */
/*                 refers to time at the observer's location. */

/*     REF         is the name of the reference frame relative to which */
/*                 the output position vector should be expressed. This */
/*                 may be any frame supported by the SPICE system, */
/*                 including built-in frames (documented in the Frames */
/*                 Required Reading) and frames defined by a loaded */
/*                 frame kernel (FK). */

/*                 When REF designates a non-inertial frame, the */
/*                 orientation of the frame is evaluated at an epoch */
/*                 dependent on the selected aberration correction. See */
/*                 the description of the output position vector PTARG */
/*                 for details. */

/*     ABCORR      indicates the aberration corrections to be applied to */
/*                 the position 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 position 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 position of the target at */
/*                               the moment it emitted photons arriving */
/*                               at the observer at ET. */

/*                               The light time correction uses an */
/*                               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 */
/*                               position obtained with the 'LT' option */
/*                               to account for the observer's velocity */
/*                               relative to the solar system */
/*                               barycenter. The result is the apparent */
/*                               position of the target---the position */
/*                               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 */
/*                               below 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 */
/*                               position 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 */
/*                               position obtained with the 'XLT' option */
/*                               to account for the observer's velocity */
/*                               relative to the solar system */
/*                               barycenter. The computed target */
/*                               position 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. */

/*     OBS         is the NAIF ID code for the observing body. */

/* $ Detailed_Output */

/*     PTARG       is a Cartesian 3-vector representing the position of */
/*                 the target body relative to the specified observer. */
/*                 PTARG is corrected for the specified aberrations, and */
/*                 is expressed with respect to the reference frame */
/*                 specified by REF.  The three components of PTARG */
/*                 represent the x-, y- and z-components of the target's */
/*                 position. */

/*                 PTARG points from the observer's location at ET to */
/*                 the aberration-corrected location of the target. */
/*                 Note that the sense of this position vector is */
/*                 independent of the direction of radiation travel */
/*                 implied by the aberration correction. */

/*                 Units are always km. */

/*                 Non-inertial frames are treated as follows: letting */
/*                 LTCENT be the one-way light time between the observer */
/*                 and the central body associated with the frame, the */
/*                 orientation of the frame is evaluated at ET-LTCENT, */
/*                 ET+LTCENT, or ET depending on whether the requested */
/*                 aberration correction is, respectively, for received */
/*                 radiation, transmitted radiation, or is omitted. */
/*                 LTCENT is computed using the method indicated by */
/*                 ABCORR. */

/*     LT          is the one-way light time between the observer and */
/*                 target in seconds.  If the target position 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 name of target or observer cannot be translated to its */
/*        NAIF ID code, the error SPICE(IDCODENOTFOUND) is signaled. */

/*     2) If the reference frame REF is not a recognized reference */
/*        frame the error 'SPICE(UNKNOWNFRAME)' is signaled. */

/*     3) If the loaded kernels provide insufficient data to */
/*        compute the requested position vector, the deficiency will */
/*        be diagnosed by a routine in the call tree of this routine. */

/*     4) If an error occurs while reading an SPK or other kernel file, */
/*        the error  will be diagnosed by a routine in the call tree */
/*        of this routine. */

/*     5) If any of the required attributes of the reference frame REF */
/*        cannot be determined, 'SPICE(UNKNOWNFRAME2)' is signaled. */

/* $ Files */

/*     This routine computes positions using SPK files that have been */
/*     loaded into the SPICE system, normally via the kernel loading */
/*     interface routine FURNSH. See the routine FURNSH and the SPK */
/*     and KERNEL Required Reading for further information on loading */
/*     (and unloading) kernels. */

/*     If the output position PTARG is to be expressed relative to a */
/*     non-inertial frame, or if any of the ephemeris data used to */
/*     compute PTARG 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 position.  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 */

/*     This routine is part of the user interface to the SPICE ephemeris */
/*     system.  It allows you to retrieve position information for any */
/*     ephemeris object relative to any other in a reference frame that */
/*     is convenient for further computations. */

/*     Aberration corrections */
/*     ====================== */

/*     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. */

/*     One-way light time */
/*     ------------------ */

/*     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 relative to the solar system barycenter, 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. */

/*     Stellar aberration */
/*     ------------------ */

/*     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 does not include (the much smaller) */
/*     relativistic effects. */

/*     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 also 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. */

/*     One may 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 position vector derived directly from */
/*           data in an SPK file. */

/*              Use 'NONE'. */


/*        5) Use a geometric position vector as a low-accuracy estimate */
/*           of the apparent position for an application where execution */
/*           speed is critical. */

/*              Use 'NONE'. */


/*        6) While this routine cannot perform the relativistic */
/*           aberration corrections required to compute positions */
/*           with the highest possible accuracy, it can supply the */
/*           geometric positions 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 */
/*        ============== */

/*        SPKEZP 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 position vector is */

/*           T(ET) - O(ET) */



/*        Reception case */
/*        ============== */

/*        When any of the options 'LT', 'CN', 'LT+S', 'CN+S' is selected */
/*        for ABCORR, SPKEZP 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 */
/*        right hand side of the light-time equation (1) yields the */
/*        "one-iteration" estimate of the one-way light time ("LT"). */
/*        Repeating the process until the estimates of LT converge */
/*        yields the "converged Newtonian" light time estimate ("CN"). */

/*        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 light time corrected position vector is */

/*           T(ET-LT) - O(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. */


/*        Transmission case */
/*        ================== */

/*        When any of the options 'XLT', 'XCN', 'XLT+S', 'XCN+S' is */
/*        selected, SPKEZP 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 light-time corrected position vector is */

/*           T(ET+LT) - O(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. */


/*     Precision of light time corrections */
/*     =================================== */

/*        Corrections using one iteration of the light time solution */
/*        ---------------------------------------------------------- */

/*        When the requested aberration correction is 'LT', 'LT+S', */
/*        'XLT', or 'XLT+S', only one iteration is performed in the */
/*        algorithm used to compute LT. */

/*        The relative error in this computation */

/*           | LT_ACTUAL - LT_COMPUTED |  /  LT_ACTUAL */

/*        is at most */

/*            (V/C)**2 */
/*           ---------- */
/*            1 - (V/C) */

/*        which is well approximated by (V/C)**2, where V is the */
/*        velocity of the target relative to an inertial frame and C is */
/*        the speed of light. */

/*        For nearly all objects in the solar system V is less than 60 */
/*        km/sec. The value of C is ~300000 km/sec. Thus the */
/*        one-iteration solution for LT has a potential relative error */
/*        of not more than 4e-8. This is a potential light time error of */
/*        approximately 2e-5 seconds per astronomical unit of distance */
/*        separating the observer and target. Given the bound on V cited */
/*        above: */

/*           As long as the observer and target are separated by less */
/*           than 50 astronomical units, the error in the light time */
/*           returned using the one-iteration light time corrections is */
/*           less than 1 millisecond. */

/*           The magnitude of the corresponding position error, given */
/*           the above assumptions, may be as large as (V/C)**2 * the */
/*           distance between the observer and the uncorrected target */
/*           position: 300 km or equivalently 6 km/AU. */

/*        In practice, the difference between positions obtained using */
/*        one-iteration and converged light time is usually much smaller */
/*        than the value computed above and can be insignificant. For */
/*        example, for the spacecraft Mars Reconnaissance Orbiter and */
/*        Mars Express, the position error for the one-iteration light */
/*        time correction, applied to the spacecraft-to-Mars center */
/*        vector, is at the 1 cm level. */

/*        Comparison of results obtained using the one-iteration and */
/*        converged light time solutions is recommended when adequacy of */
/*        the one-iteration solution is in doubt. */


/*        Converged corrections */
/*        --------------------- */

/*        When the requested aberration correction is 'CN', 'CN+S', */
/*        'XCN', or 'XCN+S', as many iterations as are required for */
/*        convergence are performed in the computation of LT. Usually */
/*        the solution is found after three iterations. The relative */
/*        error present in this case is at most */

/*            (V/C)**4 */
/*           ---------- */
/*            1 - (V/C) */

/*        which is well approximated by (V/C)**4. */

/*           The precision of this computation (ignoring round-off */
/*           error) is better than 4e-11 seconds for any pair of objects */
/*           less than 50 AU apart, and having speed relative to the */
/*           solar system barycenter less than 60 km/s. */

/*           The magnitude of the corresponding position error, given */
/*           the above assumptions, may be as large as (V/C)**4 * the */
/*           distance between the observer and the uncorrected target */
/*           position: 1.2 cm at 50 AU or equivalently 0.24 mm/AU. */

/*        However, to very accurately model the light time between */
/*        target and observer one must take into account effects due to */
/*        general relativity. These may be as high as a few hundredths */
/*        of a millisecond for some objects. */


/*     Relativistic Corrections */
/*     ========================= */

/*     This routine does not attempt to perform either general or */
/*     special relativistic corrections in computing the various */
/*     aberration corrections.  For many applications relativistic */
/*     corrections are not worth the expense of added computation */
/*     cycles.  If however, your application requires these additional */
/*     corrections we suggest you consult the astronomical almanac (page */
/*     B36) for a discussion of how to carry out these corrections. */


/* $ Examples */

/*     1)  Load a planetary ephemeris SPK, then look up a series of */
/*         geometric positions of the moon relative to the earth, */
/*         referenced to the J2000 frame. */


/*               IMPLICIT NONE */
/*         C */
/*         C     Local constants */
/*         C */
/*               CHARACTER*(*)         FRAME */
/*               PARAMETER           ( FRAME  = 'J2000' ) */

/*               CHARACTER*(*)         ABCORR */
/*               PARAMETER           ( ABCORR = 'NONE' ) */

/*         C */
/*         C     The name of the SPK file shown here is fictitious; */
/*         C     you must supply the name of an SPK file available */
/*         C     on your own computer system. */
/*         C */
/*               CHARACTER*(*)         SPK */
/*               PARAMETER           ( SPK    = 'planet.bsp' ) */

/*         C */
/*         C     ET0 represents the date 2000 Jan 1 12:00:00 TDB. */
/*         C */
/*               DOUBLE PRECISION      ET0 */
/*               PARAMETER           ( ET0    = 0.0D0 ) */

/*         C */
/*         C     Use a time step of 1 hour; look up 100 positions. */
/*         C */
/*               DOUBLE PRECISION      STEP */
/*               PARAMETER           ( STEP   = 3600.0D0 ) */

/*               INTEGER               MAXITR */
/*               PARAMETER           ( MAXITR = 100 ) */

/*         C */
/*         C     The NAIF IDs of the earth and moon are 399 and 301 */
/*         C     respectively. */
/*         C */
/*               INTEGER               OBSRVR */
/*               PARAMETER           ( OBSRVR = 399 ) */

/*               INTEGER               TARGET */
/*               PARAMETER           ( TARGET = 301 ) */

/*         C */
/*         C     Local variables */
/*         C */
/*               DOUBLE PRECISION      ET */
/*               DOUBLE PRECISION      LT */
/*               DOUBLE PRECISION      POS ( 3 ) */

/*               INTEGER               I */

/*         C */
/*         C     Load the SPK file. */
/*         C */
/*               CALL FURNSH ( SPK ) */

/*         C */
/*         C     Step through a series of epochs, looking up a */
/*         C     position vector at each one. */
/*         C */
/*               DO I = 1, MAXITR */

/*                  ET = ET0 + (I-1)*STEP */

/*                  CALL SPKEZP ( TARGET, ET, FRAME, ABCORR, OBSRVR, */
/*              .                 POS,    LT                        ) */

/*                  WRITE (*,*) 'ET = ', ET */
/*                  WRITE (*,*) 'J2000 x-position (km):   ', POS(1) */
/*                  WRITE (*,*) 'J2000 y-position (km):   ', POS(2) */
/*                  WRITE (*,*) 'J2000 z-position (km):   ', POS(3) */
/*                  WRITE (*,*) ' ' */

/*               END DO */

/*               END */


/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     SPK Required Reading. */

/* $ Author_and_Institution */

/*     C.H. Acton      (JPL) */
/*     B.V. Semenov    (JPL) */
/*     N.J. Bachman    (JPL) */
/*     W.L. Taber      (JPL) */

/* $ Version */

/* -    SPICELIB Version 3.2.0, 03-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 23-SEP-2013 (BVS) */

/*        Bug fix: added a check and an exception for the FOUND flag */
/*        returned by FRINFO. */

/*        Updated to save the input frame name and POOL state counter */
/*        and to do frame name-ID conversion only if the counter has */
/*        changed. */

/* -    SPICELIB Version 3.1.1, 04-APR-2008 (NJB) */

/*        Corrected minor error in description of XLT+S aberration */
/*        correction. */

/* -    SPICELIB Version 3.1.0, 06-JAN-2005 (NJB) */

/*        Tests of routine FAILED() were added. */

/* -    SPICELIB Version 3.0.3, 12-DEC-2004 (NJB) */

/*        Minor header error was corrected. */

/* -    SPICELIB Version 3.0.2, 20-OCT-2003 (EDW) */

/*        Added mention that LT returns in seconds. */

/* -    SPICELIB Version 3.0.1, 29-JUL-2003 (NJB) (CHA) */

/*        Various minor header changes were made to improve clarity. */

/* -    SPICELIB Version 3.0.0, 31-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 1.0.0, 03-MAR-1999 (WLT) */

/* -& */
/* $ Index_Entries */

/*     using body names get position relative to an observer */
/*     get position relative observer corrected for aberrations */
/*     read ephemeris data */
/*     read trajectory data */

/* -& */
/* $ Revisions */

/* -    SPICELIB Version 4.1.0, 05-JAN-2005 (NJB) */

/*        Tests of routine FAILED() were added.  The new checks */
/*        are intended to prevent arithmetic operations from */
/*        being performed with uninitialized or invalid data. */

/* -& */


/*     SPICELIB functions */


/*     Local parameters */


/*     Saved frame name length. */


/*     Local variables */


/*     Saved frame name/ID item declarations. */


/*     Saved variables */


/*     Initial values */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("ZZSPKZP0", (ftnlen)8);
    }

/*     Get the frame id for J2000 on the first call to this routine. */

    if (first) {
	namfrm_("J2000", &fj2000, (ftnlen)5);

/*        Initialize counter. */

	zzctruin_(svctr1);
	first = FALSE_;
    }

/*     Decide whether the aberration correction is for received or */
/*     transmitted radiation. */

    i__ = ltrim_(abcorr, abcorr_len);
    xmit = eqchr_(abcorr + (i__ - 1), "X", (ftnlen)1, (ftnlen)1);

/*     If we only want geometric positions, then compute just that. */

/*     Otherwise, compute the state of the observer relative to */
/*     the SSB.  Then feed that position into SPKAPO to compute the */
/*     apparent position of the target body relative to the observer */
/*     with the requested aberration corrections. */

    if (eqstr_(abcorr, "NONE", abcorr_len, (ftnlen)4)) {
	zzspkgp0_(targ, et, ref, obs, ptarg, lt, ref_len);
    } else {

/*        Get the auxiliary information about the requested output */
/*        frame. */

	zznamfrm_(svctr1, svref, &svreqf, ref, &reqfrm, (ftnlen)32, ref_len);
	if (reqfrm == 0) {
	    setmsg_("The requested output frame '#' is not recognized by the"
		    " reference frame subsystem. Please check that the approp"
		    "riate kernels have been loaded and that you have correct"
		    "ly entered the name of the output frame. ", (ftnlen)208);
	    errch_("#", ref, (ftnlen)1, ref_len);
	    sigerr_("SPICE(UNKNOWNFRAME)", (ftnlen)19);
	    chkout_("ZZSPKZP0", (ftnlen)8);
	    return 0;
	}
	frinfo_(&reqfrm, &center, &type__, &typeid, &found);
	if (failed_()) {
	    chkout_("ZZSPKZP0", (ftnlen)8);
	    return 0;
	}
	if (! found) {
	    setmsg_("The requested output frame '#' is not recognized by the"
		    " reference frame subsystem. Please check that the approp"
		    "riate kernels have been loaded and that you have correct"
		    "ly entered the name of the output frame. ", (ftnlen)208);
	    errch_("#", ref, (ftnlen)1, ref_len);
	    sigerr_("SPICE(UNKNOWNFRAME2)", (ftnlen)20);
	    chkout_("ZZSPKZP0", (ftnlen)8);
	    return 0;
	}

/*        If we are dealing with an inertial frame, we can simply */
/*        call SPKSSB, SPKAPO and return. */

	if (type__ == 1) {
	    zzspksb0_(obs, et, ref, sobs, ref_len);
	    zzspkpa0_(targ, et, ref, sobs, abcorr, ptarg, lt, ref_len, 
		    abcorr_len);
	    chkout_("ZZSPKZP0", (ftnlen)8);
	    return 0;
	}

/*        Still here? */

/*        We are dealing with a non-inertial frame.  But we need to */
/*        do light time and stellar aberration in an inertial frame. */
/*        Get the "apparent" position of TARG in the intermediary */
/*        inertial reference frame J2000. */

/*        We also need the light time to the center of the frame. */

	zzspksb0_(obs, et, "J2000", sobs, (ftnlen)5);
	zzspkpa0_(targ, et, "J2000", sobs, abcorr, postn, lt, (ftnlen)5, 
		abcorr_len);
	if (failed_()) {
	    chkout_("ZZSPKZP0", (ftnlen)8);
	    return 0;
	}
	if (center == *obs) {
	    ltcent = 0.;
	} else if (center == *targ) {
	    ltcent = *lt;
	} else {
	    zzspkpa0_(&center, et, "J2000", sobs, abcorr, temp, &ltcent, (
		    ftnlen)5, abcorr_len);
	}

/*        If something went wrong (like we couldn't get the position of */
/*        the center relative to the observer) now it is time to quit. */

	if (failed_()) {
	    chkout_("ZZSPKZP0", (ftnlen)8);
	    return 0;
	}

/*        If the aberration corrections are for transmission, negate */
/*        the light time, since we wish to compute the orientation */
/*        of the non-inertial frame at an epoch later than ET by */
/*        the one-way light time. */

	if (xmit) {
	    ltcent = -ltcent;
	}

/*        Get the rotation from J2000 to the requested frame */
/*        and convert the position. */

	d__1 = *et - ltcent;
	zzrefch0_(&fj2000, &reqfrm, &d__1, xform);
	if (failed_()) {
	    chkout_("ZZSPKZP0", (ftnlen)8);
	    return 0;
	}
	mxv_(xform, postn, ptarg);
    }
    chkout_("ZZSPKZP0", (ftnlen)8);
    return 0;
} /* zzspkzp0_ */
コード例 #25
0
ファイル: readln.c プロジェクト: Boxx-Obspm/DOCKing_System
/* $Procedure      READLN ( Read a text line from a logical unit ) */
/* Subroutine */ int readln_(integer *unit, char *line, logical *eof, ftnlen 
	line_len)
{
    /* System generated locals */
    cilist ci__1;

    /* Builtin functions */
    integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);

    /* Local variables */
    extern /* Subroutine */ int chkin_(char *, ftnlen), errfnm_(char *, 
	    integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), setmsg_(char *, ftnlen);
    integer iostat;
    extern /* Subroutine */ int errint_(char *, integer *, ftnlen);

/* $ Abstract */

/*     This routine will read a single line of text from the Fortran */
/*     logical unit UNIT, reporting the end of file if it occurs. */

/* $ 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 */
/*     TEXT */
/*     FILES */

/* $ Declarations */


/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*      UNIT      I    The Fortran unit number to use for input. */
/*      LINE      O    The line read from the file. */
/*      EOF       O    A logical flag indicating the end of file. */

/* $ Detailed_Input */

/*     UNIT     The Fortran unit number for the input. This may */
/*              be either the unit number for the terminal, or the */
/*              unit number of a previously opened text file. */

/* $ Detailed_Output */

/*     LINE     On output, this will contain the next text line */
/*              encountered when reading from UNIT. */

/*              If the length of the character string LINE is shorter */
/*              than the length of the current line in the text file, the */
/*              line is truncated on the right by the Fortran READ */
/*              statement, filling LINE with the first LEN(LINE) */
/*              characters from the current line in the file. */

/*              If an error or the end of file occurs during the */
/*              attempt to read from UNIT, the value of this variable */
/*              is not guaranteed. */

/*     EOF      On output, this variable will be set to .TRUE. if the */
/*              end of file ( IOSTAT < 0 ) is encountered during the */
/*              attempt to read from unit UNIT. Otherwise, this */
/*              variable will be set to .FALSE.. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1)   If an error occurs while attempting to read from the text */
/*          file attached to UNIT, the error SPICE(FILEREADFAILED) will */
/*          be signalled. */

/*     This routine only checks in with the error handler in the event */
/*     that an error occurred. (Discovery check in) */

/* $ Files */

/*     None. */

/* $ Particulars */

/*      This routine will read a single line, a text record, from the */
/*      logical unit UNIT. UNIT may be the terminal, or it may be a */
/*      logical unit number obtained from a Fortran OPEN or INQUIRE */
/*      statement. This routine will set a logical flag, EOF, on output */
/*      if the end of the file is encountered during the read attempt. */

/* $ Examples */

/*      CALL READLN ( UNIT, LINE, EOF ) */

/*      IF ( EOF ) THEN */
/*         < The end of file, deal with it appropriately > */
/*      END IF */

/*      You now have a line of text from unit UNIT. */

/* $ Restrictions */

/*      None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     K.R. Gehringer (JPL) */

/* $ Version */

/* -    SPICELIB     1.0.0, 20-DEC-1995 (KRG) */

/*        The routine graduated */

/* -    Beta Version 1.0.1, 22-NOV-1994 (KRG) */

/*        Cleaned up the comments a little bit. No code changes. */

/* -    Beta Version 1.0.0, 17-DEC-1992 (KRG) */

/* -& */
/* $ Index_Entries */

/*      read a text line from a logical unit */

/* -& */

/*     Local variables */


/*     Standard SPICE error handling. */


/*     Read in the next line from the text file attached to UNIT. */

    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, line_len);
    if (iostat != 0) {
	goto L100001;
    }
    iostat = e_rsfe();
L100001:

/*     Check to see if we got a read error, and signal it if we did. */

    if (iostat > 0) {
	chkin_("READLN", (ftnlen)6);
	setmsg_("Error reading from file: #. IOSTAT = #.", (ftnlen)39);
	errfnm_("#", unit, (ftnlen)1);
	errint_("#", &iostat, (ftnlen)1);
	sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
	chkout_("READLN", (ftnlen)6);
	return 0;
    }

/*     Check to see if we got the end of file, and set the logical */
/*     flag EOF if we did. */

    if (iostat < 0) {
	*eof = TRUE_;
    } else {
	*eof = FALSE_;
    }
    return 0;
} /* readln_ */
コード例 #26
0
ファイル: appndc.c プロジェクト: Dbelsa/coft
/* $Procedure      APPNDC ( Append an item to a character cell ) */
/* Subroutine */ int appndc_(char *item, char *cell, ftnlen item_len, ftnlen 
	cell_len)
{
    /* Builtin functions */
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    extern integer cardc_(char *, ftnlen);
    extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
	     ftnlen, ftnlen);
    extern integer sizec_(char *, ftnlen);
    extern /* Subroutine */ int scardc_(integer *, char *, ftnlen);
    integer nwcard;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), setmsg_(char *, ftnlen);
    extern logical return_(void);

/* $ Abstract */

/*      Append an item to a character cell. */

/* $ 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 */

/*     CELLS */

/* $ Keywords */

/*     CELLS */

/* $ Declarations */
/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  -------------------------------------------------- */
/*     ITEM       I   The item to append. */
/*     CELL      I/O  The cell to which ITEM will be appended. */

/* $ Detailed_Input */

/*     ITEM       is a character string which is to be appended to CELL. */

/*     CELL       is a character cell to which ITEM will be appended. */

/* $ Detailed_Output */

/*     CELL       is a character cell in which the last element is ITEM. */

/* $ Parameters */

/*      None. */

/* $ Files */

/*     None. */

/* $ Exceptions */

/*     1) If the cell is not large enough to accommodate the addition */
/*        of a new element, the error SPICE(CELLTOOSMALL) is signalled. */

/*     2) If the length of the item is longer than the length of the */
/*        cell, ITEM is truncated on the right. */

/* $ Particulars */

/*     None. */

/* $ Examples */

/*      In the following example, the item 'PLUTO' is appended to */
/*      the character cell PLANETS. */

/*      Before appending 'PLUTO', the cell contains: */

/*      PLANETS (1) = 'MERCURY' */
/*      PLANETS (2) = 'VENUS' */
/*      PLANETS (3) = 'EARTH' */
/*      PLANTES (4) = 'MARS' */
/*      PLANETS (5) = 'JUPITER' */
/*      PLANETS (6) = 'SATURN' */
/*      PLANETS (7) = 'URANUS' */
/*      PLANETS (8) = 'NEPTUNE' */

/*      The call */

/*        CALL APPNDC ( 'PLUTO', PLANETS ) */

/*      appends the element 'PLUTO' at the location PLANETS (9), and the */
/*      cardinality is updated. */

/*      If the cell is not big enough to accomodate the addition of */
/*      the item, an error is signalled. In this case, the cell is not */
/*      altered. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     H.A. Neilan     (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, 31-JAN-1990 (HAN) */

/* -& */
/* $ Index_Entries */

/*     append an item to a character cell */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("APPNDC", (ftnlen)6);
    }

/*     Check to see if the cell can accomodate the addition of a */
/*     new item. If there is room, append the item to the cell and */
/*     reset the cardinality. If the cell cannot accomodate the */
/*     addition of a new item, signal an error. */

    nwcard = cardc_(cell, cell_len) + 1;
    if (nwcard <= sizec_(cell, cell_len)) {
	s_copy(cell + (nwcard + 5) * cell_len, item, cell_len, item_len);
	scardc_(&nwcard, cell, cell_len);
    } else {
	setmsg_("The cell cannot accomodate the addition of the item *.", (
		ftnlen)54);
	errch_("*", item, (ftnlen)1, item_len);
	sigerr_("SPICE(CELLTOOSMALL)", (ftnlen)19);
    }
    chkout_("APPNDC", (ftnlen)6);
    return 0;
} /* appndc_ */
コード例 #27
0
ファイル: setd.c プロジェクト: Dbelsa/coft
/* $Procedure            SETD ( Compare double precision sets ) */
logical setd_(doublereal *a, char *op, doublereal *b, ftnlen op_len)
{
    /* System generated locals */
    logical ret_val;

    /* Builtin functions */
    integer s_cmp(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    integer cond, carda, cardb;
    extern integer cardd_(doublereal *);
    extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
	     ftnlen, ftnlen);
    integer condab, condoa, condob, indexa, condeq, indexb, condgt, condlt;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), setmsg_(char *, ftnlen);
    extern logical return_(void);

/* $ Abstract */

/*     Given a relational operator, compare two double precision sets. */

/* $ 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 */

/*     CELLS, SETS */

/* $ Keywords */

/*     CELLS, SETS */

/* $ Declarations */
/* $ Brief_I/O */

/*      VARIABLE  I/O  DESCRIPTION */
/*      --------  ---  -------------------------------------------------- */
/*      A          I   First set. */
/*      OP         I   Comparison operator. */
/*      B          I   Second set. */

/*      The function returns the result of the comparison: A (OP) B. */

/* $ Detailed_Input */


/*      A           is a set. */


/*      OP          is a comparison operator, indicating the way in */
/*                  which the input sets are to be compared. OP may */
/*                  be any of the following: */

/*                      Operator             Meaning */
/*                      --------  ------------------------------------- */
/*                        '='     A = B is true if A and B are equal */
/*                                (contain the same elements). */

/*                        '<>'    A <> B is true if A and B are not */
/*                                equal. */

/*                        '<='    A <= B is true if A is a subset of B. */

/*                        '<'     A < B is true if A is a proper subset */
/*                                of B. */

/*                        '>='    A >= B is true if B is a subset of A. */

/*                        '>'     A > B is true if B is a proper subset */
/*                                of A. */

/*                        '&'     A & B is true if A and B have one or */
/*                                more elements in common. (The */
/*                                intersection of the two sets in */
/*                                non-empty.) */

/*                        '~'     A ~ B is true if A and B are disjoint */
/*                                sets. */

/*      B           is a set. */

/* $ Detailed_Output */

/*      The function returns the result of the comparison: A (OP) B. */

/* $ Parameters */

/*     None. */

/* $ Particulars */

/*      None. */

/* $ Examples */

/*      1) In the following example, SETx is used to repeat an operation */
/*         for as long as the integer set FINISHED remains a proper */
/*         subset of the integer set PLANNED. */

/*            DO WHILE ( SETx ( FINISHED, '<', PLANNED ) ) */
/*               . */
/*               . */
/*            END DO */


/*      2) In the following example, let the integer sets A, B, and C */
/*         contain the elements listed below. Let E be an empty integer */
/*         set. */

/*              A        B        C */
/*            ---      ---      --- */
/*              1        1        1 */
/*              2        3        3 */
/*              3 */
/*              4 */

/*      Then all of the following expressions are true. */

/*            SETI ( B, '=',  C )      "B is equal to C" */
/*            SETI ( A, '<>', C )      "A is not equal to C" */
/*            SETI ( A, '>',  B )      "A is a proper superset of B" */
/*            SETI ( B, '<=', C )      "B is a subset of C" */
/*            SETI ( C, '<=', B )      "C is a subset of B" */
/*            SETI ( A, '<=', A )      "A is a subset of A" */
/*            SETI ( E, '<=', B )      "E is a subset of B" */
/*            SETI ( E, '<',  B )      "E is a proper subset of B" */
/*            SETI ( E, '<=', E )      "E is a subset of E" */
/*            SETI ( A, '&',  B )      "A has elements in common with B." */
/*            SETI ( B, '&',  C )      "B has elements in common with C." */

/*      And all of the following are false. */

/*            SETI ( B, '<>',  C )      "B is not equal to C" */
/*            SETI ( A, '=',   C )      "A is equal to C" */
/*            SETI ( A, '<',   B )      "A is a proper subset of B" */
/*            SETI ( B, '<',   C )      "B is a proper subset of C" */
/*            SETI ( B, '>=',  A )      "B is a superset of A" */
/*            SETI ( A, '>',   A )      "A is a proper superset of A" */
/*            SETI ( E, '>=',  A )      "E is a superset of A" */
/*            SETI ( E, '<',   E )      "E is a proper subset of E" */
/*            SETI ( A, '~',   B )      "A and B are disjoint sets." */

/* $ Restrictions */

/*      None. */

/* $ Exceptions */

/*      If the set relational operator is not recognized, the error */
/*      SPICE(INVALIDOPERATION) is signalled. */

/* $ Files */

/*      None. */

/* $ Literature_References */

/*      None. */

/* $ Author_and_Institution */

/*      H.A. Neilan     (JPL) */
/*      W.L. Taber      (JPL) */
/*      I.M. Underwood  (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.1.0, 17-MAY-1994 (HAN) */

/*       Set the default function value to either 0, 0.0D0, .FALSE., */
/*       or blank depending on the type of the function. */

/* -    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 (WLT) (IMU) */

/* -& */
/* $ Index_Entries */

/*     compare d.p. sets */

/* -& */
/* $ Revisions */

/* -    Beta Version 2.0.0, 11-JAN-1989 (WLT) (HAN) */

/*       The old version was not compatible with the error handling */
/*       mechanism. Taking the difference of sets A and B caused an */
/*       overflow of the set DIFF, whose dimension was one. The method of */
/*       determining the function value has been redesigned, and the */
/*       difference of the sets is no longer computed. */

/*       The new routine recognizes two new operators, '~' and '&'. */
/*       If the operator is not recognized, an error is now signalled. */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	ret_val = FALSE_;
	return ret_val;
    } else {
	chkin_("SETD", (ftnlen)4);
	ret_val = FALSE_;
    }

/*     Obtain the cardinality of the sets. */

    carda = cardd_(a);
    cardb = cardd_(b);

/*     The easiest way to compare two sets is to list them side by side */
/*     as shown below: */

/*     Set A  Set B */
/*     -----  ----- */
/*       1      1 */
/*              2 */
/*       3      3 */
/*       4      4 */
/*       5 */
/*              6 */
/*       7      7 */

/*     When listed this way, one can easily determine intersections, */
/*     differences, and unions.  Moreover, to determine if one set */
/*     is a subset of another, if they are equal, etc, one can just */
/*     inspect the two lists. */

/*     We can mimick this in an algorithm.  The main trick is to figure */
/*     out how to list the sets in this way.  Once we know how to */
/*     list them, we can simply adapt the listing algorithm to get */
/*     a comparison algorithm. */

/*     By the time we get this far, we know that our sets have distinct */
/*     elements and they are ordered. To write out the list above, */
/*     we start at the beginning of both sets (they're ordered, */
/*     remember?).  Look at the next element of A and the next element */
/*     of B ( to start out ``next'' means ``first'' ).  If the item */
/*     from A is smaller it should be written and space should be left */
/*     in the B column. If they are the same write them both.  Otherwise, */
/*     the item from B is smaller, so  leave space in the A column and */
/*     write the item from B.  Continue until you run out of items in */
/*     one of the sets.  Then just write down all those remaining in the */
/*     other set in the appropriate column.  This is what the loop */
/*     below does. */


/*           NEXTA = 1 */
/*           NEXTB = 1 */

/*           DO WHILE (       ( NEXTA .LT. CARD(A) ) */
/*          .           .AND. ( NEXTB .LT. CARD(B) ) ) */

/*              IF ( A(NEXTA) .LT. B(NEXTB) ) THEN */

/*                 WRITE (UNIT,*) A(NEXTA),   SPACES */
/*                 NEXTA = NEXTA + 1 */

/*              ELSE IF ( A(NEXTA) .EQ. B(NEXTB) ) THEN */

/*                 WRITE (UNIT,*) A(NEXTA),   B(NEXTB) */
/*                 NEXTA = NEXTA + 1 */
/*                 NEXTB = NEXTB + 1 */

/*              ELSE */

/*                 WRITE (UNIT,*) SPACES, B(NEXTB) */
/*                 NEXTB = NEXTB + 1 */

/*              END IF */
/*           END DO */

/*           DO NEXTA = 1, CARD(A) */
/*              WRITE (UNIT,*) A(NEXTA),SPACES */
/*           END DO */

/*           DO NEXTB = 1, CARD(B) */
/*              WRITE (UNIT,*) B(NEXTB),SPACES */
/*           END DO */


/*     This also gives us a way to compare the elements of the two */
/*     sets one item at a time.  Instead of writing the items, we */
/*     can make a decision as to whether or not the sets have the */
/*     relationship we are interested in. */

/*     At the beginning of the loop we assume that the two sets are */
/*     related in the way we want.  Once the comparison has been made */
/*     we can decide if they are still related in that way.  If not, */
/*     we can RETURN .FALSE.  Using psuedo-code the loop is modified */
/*     as shown below. */

/*           NEXTA = 1 */
/*           NEXTB = 1 */

/*           DO WHILE (       ( NEXTA .LT. CARD(A) ) */
/*          .           .AND. ( NEXTB .LT. CARD(B) ) ) */

/*              IF ( A(NEXTA) .LT. B(NEXTB) ) THEN */

/*                 RELATED = RELATIONSHIP_OF_INTEREST(A<B) */
/*                 NEXTA   = NEXTA + 1 */

/*              ELSE IF ( A(NEXTA) .EQ. B(NEXTB) ) THEN */

/*                 RELATED = RELATIONSHIP_OF_INTEREST(A=B) */
/*                 NEXTA   = NEXTA + 1 */
/*                 NEXTB   = NEXTB + 1 */

/*              ELSE */

/*                 RELATED = RELATIONSHIP_OF_INTEREST(A>B) */
/*                 NEXTB   = NEXTB + 1 */

/*              END IF */

/*              IF ( SURE_NOW(RELATED) ) THEN */
/*                 RETURN with the correct value. */
/*              ELSE */
/*                 Keep going. */
/*              END IF */

/*           END DO */


/*     Using the cardinality of the two sets, some function */
/*     values can be determined right away. If the cardinality */
/*     is not enough, we need to set up some conditions for the */
/*     loop which compares the individual elements of the sets. */


/*     A cannot be a proper subset of B if the cardinality of A is */
/*     greater than or equal to the cardinality of B. */

    if (s_cmp(op, "<", op_len, (ftnlen)1) == 0) {
	if (carda >= cardb) {
	    ret_val = FALSE_;
	    chkout_("SETD", (ftnlen)4);
	    return ret_val;
	} else {
	    condlt = 0;
	    condeq = 1;
	    condgt = 1;
	    condoa = 0;
	    condob = 1;
	    condab = 1;
	}

/*     A cannot be a subset of B if A contains more elements than B. */

    } else if (s_cmp(op, "<=", op_len, (ftnlen)2) == 0) {
	if (carda > cardb) {
	    ret_val = FALSE_;
	    chkout_("SETD", (ftnlen)4);
	    return ret_val;
	} else {
	    condlt = 0;
	    condeq = 1;
	    condgt = 1;
	    condoa = 0;
	    condob = 1;
	    condab = 1;
	}

/*     If the cardinality of the two sets is not equal, there's no way */
/*     that the two sets could be equal. */

    } else if (s_cmp(op, "=", op_len, (ftnlen)1) == 0) {
	if (carda != cardb) {
	    ret_val = FALSE_;
	    chkout_("SETD", (ftnlen)4);
	    return ret_val;
	} else {
	    condlt = 0;
	    condeq = 1;
	    condgt = 0;
	    condoa = 0;
	    condob = 0;
	    condab = 1;
	}

/*     If the cardinality of the two sets is not equal, the sets */
/*     are not equal. */

    } else if (s_cmp(op, "<>", op_len, (ftnlen)2) == 0) {
	if (carda != cardb) {
	    ret_val = TRUE_;
	    chkout_("SETD", (ftnlen)4);
	    return ret_val;
	} else {
	    condlt = 2;
	    condeq = 1;
	    condgt = 2;
	    condoa = 0;
	    condob = 0;
	    condab = 0;
	}

/*     B cannot be a proper subset of A if the cardinality of A is less */
/*     than or equal to the cardinality of B. */

    } else if (s_cmp(op, ">", op_len, (ftnlen)1) == 0) {
	if (carda <= cardb) {
	    ret_val = FALSE_;
	    chkout_("SETD", (ftnlen)4);
	    return ret_val;
	} else {
	    condlt = 1;
	    condeq = 1;
	    condgt = 0;
	    condoa = 1;
	    condob = 0;
	    condab = 1;
	}

/*     B cannot be a subset of A if B contains more elements than A. */

    } else if (s_cmp(op, ">=", op_len, (ftnlen)2) == 0) {
	if (carda < cardb) {
	    ret_val = FALSE_;
	    chkout_("SETD", (ftnlen)4);
	    return ret_val;
	} else {
	    condlt = 1;
	    condeq = 1;
	    condgt = 0;
	    condoa = 1;
	    condob = 0;
	    condab = 1;
	}

/*     If the cardinality of one of the sets is zero, they can't */
/*     possibly have any elements in common. */

    } else if (s_cmp(op, "&", op_len, (ftnlen)1) == 0) {
	if (carda == 0 || cardb == 0) {
	    ret_val = FALSE_;
	    chkout_("SETD", (ftnlen)4);
	    return ret_val;
	} else {
	    condlt = 1;
	    condeq = 2;
	    condgt = 1;
	    condoa = 0;
	    condob = 0;
	}

/*     If either A or B is the null set, the two sets are disjoint. */

    } else if (s_cmp(op, "~", op_len, (ftnlen)1) == 0) {
	if (carda == 0 || cardb == 0) {
	    ret_val = TRUE_;
	    chkout_("SETD", (ftnlen)4);
	    return ret_val;
	} else {
	    condlt = 1;
	    condeq = 0;
	    condgt = 1;
	    condoa = 1;
	    condob = 1;
	}

/*     If the relational operator is not recognized, signal an */
/*     error. */

    } else {
	setmsg_("Relational operator, *, is not recognized.", (ftnlen)42);
	errch_("*", op, (ftnlen)1, op_len);
	sigerr_("SPICE(INVALIDOPERATION)", (ftnlen)23);
	chkout_("SETD", (ftnlen)4);
	return ret_val;
    }

/*     Initialize counters used for checking the elements of the sets. */

    indexa = 1;
    indexb = 1;
    cond = 0;

/*     If we've come this far we need to check the elements of the */
/*     sets to determine the function value. */

    while(indexa <= carda && indexb <= cardb) {
	if (a[indexa + 5] < b[indexb + 5]) {
	    cond = condlt;
	    ++indexa;
	} else if (a[indexa + 5] == b[indexb + 5]) {
	    cond = condeq;
	    ++indexa;
	    ++indexb;
	} else {
	    cond = condgt;
	    ++indexb;
	}

/*        At this point, there are several cases which allow us to */
/*        determine the function value without continuing to compare */
/*        the elements of the sets: */

/*        1. If the operator is '~' and a common element was found, */
/*           the sets are not disjoint ( COND = 0 ). */

/*        2. If the operator is '&' and a common element was found, */
/*           the sets have at least one common element ( COND = 2 ). */

/*        3. If the sets are being compared for containment, and the */
/*           first element of the "contained" set is less than the first */
/*           element of the "containing" set, the "contained" set */
/*           cannot be a subset of the "containing" set ( COND = 0 ). */

/*        4. If the operator is '=' and the elements being compared are */
/*           not equal, the sets are not equal ( COND = 0 ). */

/*        5. If the operator is '<>' and the elements being compared are */
/*           not equal, the sets are not equal ( COND = 2 ). */


	if (cond == 0) {
	    ret_val = FALSE_;
	    chkout_("SETD", (ftnlen)4);
	    return ret_val;
	} else if (cond == 2) {
	    ret_val = TRUE_;
	    chkout_("SETD", (ftnlen)4);
	    return ret_val;
	}
    }

/*     We've exited the loop, so now we need to make a decision based on */
/*     what's left over. */


/*     We've gone through all of set B and there are elements left in */
/*     A. */

    if (indexa <= carda) {
	cond = condoa;

/*     We've gone through all of set A and there are elements left in */
/*     B. */

    } else if (indexb <= cardb) {
	cond = condob;

/*     We've gone through both the sets. */

    } else {
	cond = condab;
    }

/*     Determine the value of SETD from the results. */

    ret_val = cond == 1;
    chkout_("SETD", (ftnlen)4);
    return ret_val;
} /* setd_ */
コード例 #28
0
ファイル: synthi.c プロジェクト: Dbelsa/coft
/* $Procedure      SYNTHI ( Return the Nth component of a symbol ) */
/* Subroutine */ int synthi_(char *name__, integer *nth, char *tabsym, 
	integer *tabptr, integer *tabval, integer *value, logical *found, 
	ftnlen name_len, ftnlen tabsym_len)
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    integer nsym;
    extern integer cardc_(char *, ftnlen);
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    extern integer sumai_(integer *, integer *), bsrchc_(char *, integer *, 
	    char *, ftnlen, ftnlen);
    integer locval;
    extern /* Subroutine */ int chkout_(char *, ftnlen);
    integer locsym;
    extern logical return_(void);

/* $ Abstract */

/*     Return the Nth component of a particular symbol in an integer */
/*     symbol table. */

/* $ 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 */

/*     SYMBOLS */

/* $ Keywords */

/*     SYMBOLS */

/* $ Declarations */
/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  -------------------------------------------------- */
/*     NAME       I   Name of the symbol whose Nth component is to be */
/*                    returned. */
/*     NTH        I   Index of the value to be returned. */
/*     TABSYM, */
/*     TABPTR, */
/*     TABVAL     I   Components of the symbol table. */
/*     VALUE      O   Nth value associated with the symbol. */
/*     FOUND      O   True if the Nth value of the symbol exists, false */
/*                    if it does not. */

/* $ Detailed_Input */

/*     NAME       is the name of the symbol whose Nth component is to be */
/*                returned. If NAME is not in the symbol table, FOUND is */
/*                false. */

/*     NTH        is the index of the component to be returned. If the */
/*                value of NTH is out of range ( NTH < 1 or NTH is */
/*                greater than the dimension of the symbol ) FOUND is */
/*                false. */

/*     TABSYM, */
/*     TABPTR, */
/*     TABVAL     are the components of an integer symbol table. */
/*                The symbol table is not modified by this subroutine. */

/* $ Detailed_Output */

/*     VALUES     is the NTH component of the symbol NAME. */

/*     FOUND      is true if NAME is in the symbol table and the NTH */
/*                component of NAME exists.  Otherwise FOUND is false. */

/* $ Parameters */

/*     None. */

/* $ Files */

/*     None. */

/* $ Exceptions */

/*     None. */

/* $ Particulars */

/*     Two conditions will cause the value of FOUND to be false: */

/*       1) The symbol NAME is not in the symbol table. */

/*       2) NTH is out of range ( NTH < 1 or NTH is greater than the */
/*          dimension of the symbol ). */

/* $ Examples */

/*     The contents of the symbol table are: */

/*        books   -->   5 */
/*        erasers -->   6 */
/*        pencils -->  12 */
/*                     24 */
/*        pens    -->  10 */
/*                     12 */
/*                     24 */

/*     The calls, */

/*     CALL SYNTHI ( 'pens',    2, TABSYM, TABPTR, TABVAL, VALUE, */
/*    .               FOUND                                       ) */

/*     CALL SYNTHI ( 'pencils', 3, TABSYM, TABPTR, TABVAL, VALUE, */
/*    .               FOUND                                       ) */

/*     CALL SYNTHI ( 'chairs',  1, TABPTR, TABVAL, TABVAL, VALUE, */
/*    .               FOUND                                       ) */

/*     return the values of VALUE and FOUND corresponding to NAME and */
/*     NTH: */

/*     NAME            NTH       VALUE      FOUND */
/*     ----------     -----     -------    ------- */
/*     pens             2         12         TRUE */
/*     pencils                              FALSE */
/*     chairs                               FALSE */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     H.A. Neilan     (JPL) */
/*     I.M. Underwood  (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, 31-JAN-1990 (IMU) (HAN) */

/* -& */
/* $ Index_Entries */

/*     fetch nth value associated with a symbol */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    } else {
	chkin_("SYNTHI", (ftnlen)6);
    }

/*     How many symbols to start with? */

    nsym = cardc_(tabsym, tabsym_len);

/*     Is this symbol even in the table? */

    locsym = bsrchc_(name__, &nsym, tabsym + tabsym_len * 6, name_len, 
	    tabsym_len);

/*     If it's not in the table, it's definitely a problem. */

    if (locsym == 0) {
	*found = FALSE_;

/*     If the value of NTH is out of range, that's a problem too. */

    } else if (*nth < 1 || *nth > tabptr[locsym + 5]) {
	*found = FALSE_;

/*     Otherwise, we can proceed without fear of error. Merely locate */
/*     and return the appropriate component from the values table. */

    } else {
	*found = TRUE_;
	i__1 = locsym - 1;
	locval = sumai_(&tabptr[6], &i__1) + *nth;
	*value = tabval[locval + 5];
    }
    chkout_("SYNTHI", (ftnlen)6);
    return 0;
} /* synthi_ */
コード例 #29
0
ファイル: ckr05.c プロジェクト: TomCrowley-ME/me_sim_test
/* $Procedure      CKR05 ( Read CK record from segment, type 05 ) */
/* Subroutine */ int ckr05_(integer *handle, doublereal *descr, doublereal *
	sclkdp, doublereal *tol, logical *needav, doublereal *record, logical 
	*found)
{
    /* Initialized data */

    static integer lbeg = -1;
    static integer lend = -1;
    static integer lhand = 0;
    static doublereal prevn = -1.;
    static doublereal prevnn = -1.;
    static doublereal prevs = -1.;

    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1, d__2;

    /* Builtin functions */
    integer i_dnnt(doublereal *), s_rnge(char *, integer, char *, integer);

    /* Local variables */
    integer high;
    doublereal rate;
    integer last, type__, i__, j, n;
    doublereal t;
    integer begin;
    extern /* Subroutine */ int chkin_(char *, ftnlen), dafus_(doublereal *, 
	    integer *, integer *, doublereal *, integer *);
    integer nidir;
    extern doublereal dpmax_(void);
    extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *);
    integer npdir, nsrch;
    extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen);
    integer lsize, first, nints, rsize;
    doublereal start;
    extern /* Subroutine */ int dafgda_(integer *, integer *, integer *, 
	    doublereal *);
    doublereal dc[2];
    integer ic[6];
    extern logical failed_(void);
    integer bufbas, dirbas;
    doublereal hepoch;
    extern doublereal brcktd_(doublereal *, doublereal *, doublereal *);
    doublereal lepoch;
    integer npread, nsread, remain, pbegix, sbegix, timbas;
    doublereal pbuffr[101];
    extern integer lstled_(doublereal *, integer *, doublereal *);
    doublereal sbuffr[103];
    integer pendix, sendix, packsz;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen);
    integer maxwnd;
    doublereal contrl[5];
    extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *, 
	    integer *, ftnlen);
    extern integer lstltd_(doublereal *, integer *, doublereal *);
    doublereal nstart;
    extern logical return_(void);
    integer pgroup, sgroup, wndsiz, wstart, subtyp;
    doublereal nnstrt;
    extern logical odd_(integer *);
    integer end, low;

/* $ Abstract */

/*     Read a single CK data record from a segment of type 05 */
/*     (MEX/Rosetta Attitude file interpolation). */

/* $ 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 */

/*     CK */

/* $ Keywords */

/*     POINTING */

/* $ Declarations */
/* $ Abstract */

/*     Declare parameters specific to CK type 05. */

/* $ 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 */

/*     CK */

/* $ Keywords */

/*     CK */

/* $ Restrictions */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */

/* $ Literature_References */

/*     None. */

/* $ Version */

/* -    SPICELIB Version 1.0.0, 20-AUG-2002 (NJB) */

/* -& */

/*     CK type 5 subtype codes: */


/*     Subtype 0:  Hermite interpolation, 8-element packets. Quaternion */
/*                 and quaternion derivatives only, no angular velocity */
/*                 vector provided. Quaternion elements are listed */
/*                 first, followed by derivatives. Angular velocity is */
/*                 derived from the quaternions and quaternion */
/*                 derivatives. */


/*     Subtype 1:  Lagrange interpolation, 4-element packets. Quaternion */
/*                 only. Angular velocity is derived by differentiating */
/*                 the interpolating polynomials. */


/*     Subtype 2:  Hermite interpolation, 14-element packets. */
/*                 Quaternion and angular angular velocity vector, as */
/*                 well as derivatives of each, are provided. The */
/*                 quaternion comes first, then quaternion derivatives, */
/*                 then angular velocity and its derivatives. */


/*     Subtype 3:  Lagrange interpolation, 7-element packets. Quaternion */
/*                 and angular velocity vector provided.  The quaternion */
/*                 comes first. */


/*     Packet sizes associated with the various subtypes: */


/*     End of file ck05.inc. */

/* $ Abstract */

/*     Declarations of the CK data type specific and general CK low */
/*     level routine parameters. */

/* $ 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 */

/*     CK.REQ */

/* $ Keywords */

/*     CK */

/* $ Restrictions */

/*     1) If new CK types are added, the size of the record passed */
/*        between CKRxx and CKExx must be registered as separate */
/*        parameter. If this size will be greater than current value */
/*        of the CKMRSZ parameter (which specifies the maximum record */
/*        size for the record buffer used inside CKPFS) then it should */
/*        be assigned to CKMRSZ as a new value. */

/* $ Author_and_Institution */

/*     N.J. Bachman      (JPL) */
/*     B.V. Semenov      (JPL) */

/* $ Literature_References */

/*     CK Required Reading. */

/* $ Version */

/* -    SPICELIB Version 2.0.0, 19-AUG-2002 (NJB) */

/*        Updated to support CK type 5. */

/* -    SPICELIB Version 1.0.0, 05-APR-1999 (BVS) */

/* -& */

/*     Number of quaternion components and number of quaternion and */
/*     angular rate components together. */


/*     CK Type 1 parameters: */

/*     CK1DTP   CK data type 1 ID; */

/*     CK1RSZ   maximum size of a record passed between CKR01 */
/*              and CKE01. */


/*     CK Type 2 parameters: */

/*     CK2DTP   CK data type 2 ID; */

/*     CK2RSZ   maximum size of a record passed between CKR02 */
/*              and CKE02. */


/*     CK Type 3 parameters: */

/*     CK3DTP   CK data type 3 ID; */

/*     CK3RSZ   maximum size of a record passed between CKR03 */
/*              and CKE03. */


/*     CK Type 4 parameters: */

/*     CK4DTP   CK data type 4 ID; */

/*     CK4PCD   parameter defining integer to DP packing schema that */
/*              is applied when seven number integer array containing */
/*              polynomial degrees for quaternion and angular rate */
/*              components packed into a single DP number stored in */
/*              actual CK records in a file; the value of must not be */
/*              changed or compatibility with existing type 4 CK files */
/*              will be lost. */

/*     CK4MXD   maximum Chebychev polynomial degree allowed in type 4 */
/*              records; the value of this parameter must never exceed */
/*              value of the CK4PCD; */

/*     CK4SFT   number of additional DPs, which are not polynomial */
/*              coefficients, located at the beginning of a type 4 */
/*              CK record that passed between routines CKR04 and CKE04; */

/*     CK4RSZ   maximum size of type 4 CK record passed between CKR04 */
/*              and CKE04; CK4RSZ is computed as follows: */

/*                 CK4RSZ = ( CK4MXD + 1 ) * QAVSIZ + CK4SFT */


/*     CK Type 5 parameters: */


/*     CK5DTP   CK data type 5 ID; */

/*     CK5MXD   maximum polynomial degree allowed in type 5 */
/*              records. */

/*     CK5MET   number of additional DPs, which are not polynomial */
/*              coefficients, located at the beginning of a type 5 */
/*              CK record that passed between routines CKR05 and CKE05; */

/*     CK5MXP   maximum packet size for any subtype.  Subtype 2 */
/*              has the greatest packet size, since these packets */
/*              contain a quaternion, its derivative, an angular */
/*              velocity vector, and its derivative.  See ck05.inc */
/*              for a description of the subtypes. */

/*     CK5RSZ   maximum size of type 5 CK record passed between CKR05 */
/*              and CKE05; CK5RSZ is computed as follows: */

/*                 CK5RSZ = ( CK5MXD + 1 ) * CK5MXP + CK5MET */



/*     Maximum record size that can be handled by CKPFS. This value */
/*     must be set to the maximum of all CKxRSZ parameters (currently */
/*     CK4RSZ.) */

/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     HANDLE     I   File handle. */
/*     DESCR      I   Segment descriptor. */
/*     SCLKDP     I   Pointing request time. */
/*     TOL        I   Lookup tolerance. */
/*     NEEDAV     I   Angular velocity flag. */
/*     RECORD     O   Data record. */
/*     FOUND      O   Flag indicating whether record was found. */

/* $ Detailed_Input */

/*     HANDLE, */
/*     DESCR       are the file handle and segment descriptor for */
/*                 a CK segment of type 05. */

/*     SCLKDP      is an encoded spacecraft clock time indicating */
/*                 the epoch for which pointing is desired. */

/*     TOL        is a time tolerance, measured in the same units as */
/*                encoded spacecraft clock. */

/*                When SCLKDP falls within the bounds of one of the */
/*                interpolation intervals then the tolerance has no */
/*                effect because pointing will be returned at the */
/*                request time. */

/*                However, if the request time is not in one of the */
/*                intervals, then the tolerance is used to determine */
/*                if pointing at one of the interval endpoints should */
/*                be returned. */

/*     NEEDAV     is true if angular velocity is requested. */

/* $ Detailed_Output */

/*     RECORD      is a set of data from the specified segment which, */
/*                 when evaluated at epoch SCLKDP, will give the */
/*                 attitude and angular velocity of some body, relative */
/*                 to the reference frame indicated by DESCR. */

/*                 The structure of the record is as follows: */

/*                    +----------------------+ */
/*                    | evaluation epoch     | */
/*                    +----------------------+ */
/*                    | subtype code         | */
/*                    +----------------------+ */
/*                    | number of packets (n)| */
/*                    +----------------------+ */
/*                    | nominal SCLK rate    | */
/*                    +----------------------+ */
/*                    | packet 1             | */
/*                    +----------------------+ */
/*                    | packet 2             | */
/*                    +----------------------+ */
/*                                . */
/*                                . */
/*                                . */
/*                    +----------------------+ */
/*                    | packet n             | */
/*                    +----------------------+ */
/*                    | epochs 1--n          | */
/*                    +----------------------+ */

/*                 The packet size is a function of the subtype code. */
/*                 All packets in a record have the same size. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     This routine follows the pattern established in the lower-numbered */
/*     CK data type readers of not explicitly performing error */
/*     diagnoses.  Exceptions are listed below nonetheless. */

/*     1) If the input HANDLE does not designate a loaded CK file, the */
/*        error will be diagnosed by routines called by this routine. */

/*     2) If the segment specified by DESCR is not of data type 05, */
/*        the error 'SPICE(WRONGCKTYPE)' is signaled. */

/*     3) If the input SCLK value is not within the range specified */
/*        in the segment descriptor, the error SPICE(TIMEOUTOFBOUNDS) */
/*        is signaled. */

/*     4) If the window size is non-positive or greater than the */
/*        maximum allowed value, the error SPICE(INVALIDVALUE) is */
/*        signaled. */

/*     5) If the window size is not compatible with the segment */
/*        subtype, the error SPICE(INVALIDVALUE) is signaled. */

/*     6) If the segment subtype is not recognized, the error */
/*        SPICE(NOTSUPPORTED) is signaled. */

/*     7) If the tolerance is negative, the error SPICE(VALUEOUTOFRANGE) */
/*        is signaled. */

/* $ Files */

/*     See argument HANDLE. */

/* $ Particulars */

/*     See the CK Required Reading file for a description of the */
/*     structure of a data type 05 segment. */

/* $ Examples */

/*     The data returned by the CKRnn routine is in its rawest form, */
/*     taken directly from the segment.  As such, it will be meaningless */
/*     to a user unless he/she understands the structure of the data type */
/*     completely.  Given that understanding, however, the CKRxx */
/*     routines might be used to "dump" and check segment data for a */
/*     particular epoch. */


/*     C */
/*     C     Get a segment applicable to a specified body and epoch. */
/*     C */
/*     C     CALL CKBSS ( INST,   SCLKDP, TOL,   NEEDAV ) */
/*           CALL CKSNS ( HANDLE, DESCR,  SEGID, SFND   ) */

/*           IF ( .NOT. SFND ) THEN */
/*              [Handle case of pointing not being found] */
/*           END IF */

/*     C */
/*     C     Look at parts of the descriptor. */
/*     C */
/*           CALL DAFUS ( DESCR, 2, 6, DCD, ICD ) */
/*           CENTER = ICD( 2 ) */
/*           REF    = ICD( 3 ) */
/*           TYPE   = ICD( 4 ) */

/*           IF ( TYPE .EQ. 05 ) THEN */

/*              CALL CKR05 ( HANDLE, DESCR, SCLKDP, TOL, NEEDAV, */
/*          .                RECORD, FOUND                       ) */

/*              IF ( .NOT. FOUND ) THEN */
/*                 [Handle case of pointing not being found] */
/*              END IF */

/*              [Look at the RECORD data] */
/*                  . */
/*                  . */
/*                  . */
/*           END IF */

/* $ Restrictions */

/*     1)  Correctness of inputs must be ensured by the caller of */
/*         this routine. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman    (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.1.0, 06-SEP-2002 (NJB) */

/* -& */
/* $ Index_Entries */

/*     read record from type_5 ck segment */

/* -& */
/* $ Revisions */

/* -& */

/*     SPICELIB functions */


/*     Local parameters */


/*     Maximum polynomial degree: */


/*     Local variables */


/*     Saved variables */


/*     Initial values */


/*     Standard SPICE error handling. */

    if (return_()) {
	return 0;
    }
    chkin_("CKR05", (ftnlen)5);

/*     No pointing found so far. */

    *found = FALSE_;

/*     Unpack the segment descriptor, and get the start and end addresses */
/*     of the segment. */

    dafus_(descr, &c__2, &c__6, dc, ic);
    type__ = ic[2];
    begin = ic[4];
    end = ic[5];

/*     Make sure that this really is a type 05 data segment. */

    if (type__ != 5) {
	setmsg_("You are attempting to locate type * data in a type 5 data s"
		"egment.", (ftnlen)66);
	errint_("*", &type__, (ftnlen)1);
	sigerr_("SPICE(WRONGCKTYPE)", (ftnlen)18);
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     Check the tolerance value. */

    if (*tol < 0.) {
	setmsg_("Tolerance must be non-negative but was actually *.", (ftnlen)
		50);
	errdp_("*", tol, (ftnlen)1);
	sigerr_("SPICE(VALUEOUTOFRANGE)", (ftnlen)22);
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     Check the request time and tolerance against the bounds in */
/*     the segment descriptor. */

    if (*sclkdp + *tol < dc[0] || *sclkdp - *tol > dc[1]) {

/*        The request time is too far outside the segment's coverage */
/*        interval for any pointing to satisfy the request. */

	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     Set the request time to use for searching. */

    t = brcktd_(sclkdp, dc, &dc[1]);

/*     From this point onward, we assume the segment was constructed */
/*     correctly.  In particular, we assume: */

/*        1)  The segment descriptor's time bounds are in order and are */
/*            distinct. */

/*        2)  The epochs in the segment are in strictly increasing */
/*            order. */


/*        3)  The interpolation interval start times in the segment are */
/*            in strictly increasing order. */


/*        4)  The degree of the interpolating polynomial specified by */
/*            the segment is at least 1 and is no larger than MAXDEG. */


    i__1 = end - 4;
    dafgda_(handle, &i__1, &end, contrl);

/*     Check the FAILED flag just in case HANDLE is not attached to */
/*     any DAF file and the error action is not set to ABORT.  We */
/*     do this only after the first call to DAFGDA, as in CKR03. */

    if (failed_()) {
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }
    rate = contrl[0];
    subtyp = i_dnnt(&contrl[1]);
    wndsiz = i_dnnt(&contrl[2]);
    nints = i_dnnt(&contrl[3]);
    n = i_dnnt(&contrl[4]);

/*     Set the packet size, which is a function of the subtype. */

    if (subtyp == 0) {
	packsz = 8;
    } else if (subtyp == 1) {
	packsz = 4;
    } else if (subtyp == 2) {
	packsz = 14;
    } else if (subtyp == 3) {
	packsz = 7;
    } else {
	setmsg_("Unexpected CK type 5 subtype # found in type 5 segment.", (
		ftnlen)55);
	errint_("#", &subtyp, (ftnlen)1);
	sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     Check the window size. */

    if (wndsiz <= 0) {
	setmsg_("Window size in type 05 segment was #; must be positive.", (
		ftnlen)55);
	errint_("#", &wndsiz, (ftnlen)1);
	sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }
    if (subtyp == 0 || subtyp == 2) {

/*        These are the Hermite subtypes. */

	maxwnd = 8;
	if (wndsiz > maxwnd) {
	    setmsg_("Window size in type 05 segment was #; max allowed value"
		    " is # for subtypes 0 and 2 (Hermite, 8 or 14-element pac"
		    "kets).", (ftnlen)117);
	    errint_("#", &wndsiz, (ftnlen)1);
	    errint_("#", &maxwnd, (ftnlen)1);
	    sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}
	if (odd_(&wndsiz)) {
	    setmsg_("Window size in type 05 segment was #; must be even for "
		    "subtypes 0 and 2 (Hermite, 8 or 14-element packets).", (
		    ftnlen)107);
	    errint_("#", &wndsiz, (ftnlen)1);
	    sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}
    } else if (subtyp == 1 || subtyp == 3) {

/*        These are the Lagrange subtypes. */

	maxwnd = 16;
	if (wndsiz > maxwnd) {
	    setmsg_("Window size in type 05 segment was #; max allowed value"
		    " is # for subtypes 1 and 3 (Lagrange, 4 or 7-element pac"
		    "kets).", (ftnlen)117);
	    errint_("#", &wndsiz, (ftnlen)1);
	    errint_("#", &maxwnd, (ftnlen)1);
	    sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}
	if (odd_(&wndsiz)) {
	    setmsg_("Window size in type 05 segment was #; must be even for "
		    "subtypes 1 and 3 (Lagrange, 4 or 7-element packets).", (
		    ftnlen)107);
	    errint_("#", &wndsiz, (ftnlen)1);
	    sigerr_("SPICE(INVALIDVALUE)", (ftnlen)19);
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}
    } else {
	setmsg_("This point should not be reached. Getting here may indicate"
		" that the code needs to updated to handle the new subtype #", 
		(ftnlen)118);
	errint_("#", &subtyp, (ftnlen)1);
	sigerr_("SPICE(NOTSUPPORTED)", (ftnlen)19);
	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     We now need to select the pointing values to interpolate */
/*     in order to satisfy the pointing request.  The first step */
/*     is to use the pointing directories (if any) to locate a set of */
/*     epochs bracketing the request time.  Note that the request */
/*     time might not be bracketed:  it could precede the first */
/*     epoch or follow the last epoch. */

/*     We'll use the variable PGROUP to refer to the set of epochs */
/*     to search.  The first group consists of the epochs prior to */
/*     and including the first pointing directory entry.  The last */
/*     group consists of the epochs following the last pointing */
/*     directory entry.  Other groups consist of epochs following */
/*     one pointing directory entry up to and including the next */
/*     pointing directory entry. */

    npdir = (n - 1) / 100;
    dirbas = begin + n * packsz + n - 1;
    if (npdir == 0) {

/*        There's no mystery about which group of epochs to search. */

	pgroup = 1;
    } else {

/*        There's at least one directory.  Find the first directory */
/*        whose time is greater than or equal to the request time, if */
/*        there is such a directory.  We'll search linearly through the */
/*        directory entries, reading up to DIRSIZ of them at a time. */
/*        Having found the correct set of directory entries, we'll */
/*        perform a binary search within that set for the desired entry. */

	bufbas = dirbas;
	npread = min(npdir,100);
	i__1 = bufbas + 1;
	i__2 = bufbas + npread;
	dafgda_(handle, &i__1, &i__2, pbuffr);
	remain = npdir - npread;
	while(pbuffr[(i__1 = npread - 1) < 101 && 0 <= i__1 ? i__1 : s_rnge(
		"pbuffr", i__1, "ckr05_", (ftnlen)633)] < t && remain > 0) {
	    bufbas += npread;
	    npread = min(remain,100);

/*           Note:  NPREAD is always > 0 here. */

	    i__1 = bufbas + 1;
	    i__2 = bufbas + npread;
	    dafgda_(handle, &i__1, &i__2, pbuffr);
	    remain -= npread;
	}

/*        At this point, BUFBAS - DIRBAS is the number of directory */
/*        entries preceding the one contained in PBUFFR(1). */

/*        PGROUP is one more than the number of directories we've */
/*        passed by. */

	pgroup = bufbas - dirbas + lstltd_(&t, &npread, pbuffr) + 1;
    }

/*     PGROUP now indicates the set of epochs in which to search for the */
/*     request epoch.  The following cases can occur: */

/*        PGROUP = 1 */
/*        ========== */

/*           NPDIR = 0 */
/*           -------- */
/*           The request time may precede the first time tag */
/*           of the segment, exceed the last time tag, or lie */
/*           in the closed interval bounded by these time tags. */

/*           NPDIR >= 1 */
/*           --------- */
/*           The request time may precede the first time tag */
/*           of the group but does not exceed the last epoch */
/*           of the group. */


/*        1 < PGROUP <= NPDIR */
/*        =================== */

/*           The request time follows the last time of the */
/*           previous group and is less than or equal to */
/*           the pointing directory entry at index PGROUP. */

/*        1 < PGROUP = NPDIR + 1 */
/*        ====================== */

/*           The request time follows the last time of the */
/*           last pointing directory entry.  The request time */
/*           may exceed the last time tag. */


/*     Now we'll look up the time tags in the group of epochs */
/*     we've identified. */

/*     We'll use the variable names PBEGIX and PENDIX to refer to */
/*     the indices, relative to the set of time tags, of the first */
/*     and last time tags in the set we're going to look up. */

    if (pgroup == 1) {
	pbegix = 1;
	pendix = min(n,100);
    } else {

/*        If the group index is greater than 1, we'll include the last */
/*        time tag of the previous group in the set of time tags we look */
/*        up.  That way, the request time is strictly bracketed on the */
/*        low side by the time tag set we look up. */

	pbegix = (pgroup - 1) * 100;
/* Computing MIN */
	i__1 = pbegix + 100;
	pendix = min(i__1,n);
    }
    timbas = dirbas - n;
    i__1 = timbas + pbegix;
    i__2 = timbas + pendix;
    dafgda_(handle, &i__1, &i__2, pbuffr);
    npread = pendix - pbegix + 1;

/*     At this point, we'll deal with the cases where T lies outside */
/*     of the range of epochs we've buffered. */

    if (t < pbuffr[0]) {

/*        This can happen only if PGROUP = 1 and T precedes all epochs. */
/*        If the input request time is too far from PBUFFR(1) on */
/*        the low side, we're done. */

	if (*sclkdp + *tol < pbuffr[0]) {
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}

/*        Bracket T to move it within the range of buffered epochs. */

	t = pbuffr[0];
    } else if (t > pbuffr[(i__1 = npread - 1) < 101 && 0 <= i__1 ? i__1 : 
	    s_rnge("pbuffr", i__1, "ckr05_", (ftnlen)748)]) {

/*        This can happen only if T follows all epochs. */

	if (*sclkdp - *tol > pbuffr[(i__1 = npread - 1) < 101 && 0 <= i__1 ? 
		i__1 : s_rnge("pbuffr", i__1, "ckr05_", (ftnlen)752)]) {
	    chkout_("CKR05", (ftnlen)5);
	    return 0;
	}

/*        Bracket T to move it within the range of buffered epochs. */

	t = pbuffr[(i__1 = npread - 1) < 101 && 0 <= i__1 ? i__1 : s_rnge(
		"pbuffr", i__1, "ckr05_", (ftnlen)762)];
    }

/*     At this point, */

/*        | T - SCLKDP |  <=  TOL */

/*     Also, one of the following is true: */

/*        T is the first time of the segment */

/*        T is the last time of the segment */

/*        T equals SCLKDP */



/*     Find two adjacent time tags bounding the request epoch.  The */
/*     request time cannot be greater than all of time tags in the */
/*     group, and it cannot precede the first element of the group. */

    i__ = lstltd_(&t, &npread, pbuffr);

/*     The variables LOW and HIGH are the indices of a pair of time */
/*     tags that bracket the request time.  Remember that NPREAD could */
/*     be equal to 1, in which case we would have LOW = HIGH. */

    if (i__ == 0) {

/*        This can happen only if PGROUP = 1 and T = PBUFFR(1). */

	low = 1;
	lepoch = pbuffr[0];
	if (n == 1) {
	    high = 1;
	} else {
	    high = 2;
	}
	hepoch = pbuffr[(i__1 = high - 1) < 101 && 0 <= i__1 ? i__1 : s_rnge(
		"pbuffr", i__1, "ckr05_", (ftnlen)805)];
    } else {
	low = pbegix + i__ - 1;
	lepoch = pbuffr[(i__1 = i__ - 1) < 101 && 0 <= i__1 ? i__1 : s_rnge(
		"pbuffr", i__1, "ckr05_", (ftnlen)810)];
	high = low + 1;
	hepoch = pbuffr[(i__1 = i__) < 101 && 0 <= i__1 ? i__1 : s_rnge("pbu"
		"ffr", i__1, "ckr05_", (ftnlen)813)];
    }

/*     We now need to find the interpolation interval containing */
/*     T, if any.  We may be able to use the interpolation */
/*     interval found on the previous call to this routine.  If */
/*     this is the first call or if the previous interval is not */
/*     applicable, we'll search for the interval. */

/*     First check if the request time falls in the same interval as */
/*     it did last time.  We need to make sure that we are dealing */
/*     with the same segment as well as the same time range. */


/*        PREVS      is the start time of the interval that satisfied */
/*                   the previous request for pointing. */

/*        PREVN      is the start time of the interval that followed */
/*                   the interval specified above. */

/*        PREVNN     is the start time of the interval that followed */
/*                   the interval starting at PREVN. */

/*        LHAND      is the handle of the file that PREVS and PREVN */
/*                   were found in. */

/*        LBEG,      are the beginning and ending addresses of the */
/*        LEND       segment in the file LHAND that PREVS and PREVN */
/*                   were found in. */

    if (*handle == lhand && begin == lbeg && end == lend && t >= prevs && t < 
	    prevn) {
	start = prevs;
	nstart = prevn;
	nnstrt = prevnn;
    } else {

/*        Search for the interpolation interval. */

	nidir = (nints - 1) / 100;
	dirbas = end - 5 - nidir;
	if (nidir == 0) {

/*           There's no mystery about which group of epochs to search. */

	    sgroup = 1;
	} else {

/*           There's at least one directory.  Find the first directory */
/*           whose time is greater than or equal to the request time, if */
/*           there is such a directory.  We'll search linearly through */
/*           the directory entries, reading up to DIRSIZ of them at a */
/*           time. Having found the correct set of directory entries, */
/*           we'll perform a binary search within that set for the */
/*           desired entry. */

	    bufbas = dirbas;
	    nsread = min(nidir,100);
	    remain = nidir - nsread;
	    i__1 = bufbas + 1;
	    i__2 = bufbas + nsread;
	    dafgda_(handle, &i__1, &i__2, sbuffr);
	    while(sbuffr[(i__1 = nsread - 1) < 103 && 0 <= i__1 ? i__1 : 
		    s_rnge("sbuffr", i__1, "ckr05_", (ftnlen)885)] < t && 
		    remain > 0) {
		bufbas += nsread;
		nsread = min(remain,100);
		remain -= nsread;

/*              Note:  NSREAD is always > 0 here. */

		i__1 = bufbas + 1;
		i__2 = bufbas + nsread;
		dafgda_(handle, &i__1, &i__2, sbuffr);
	    }

/*           At this point, BUFBAS - DIRBAS is the number of directory */
/*           entries preceding the one contained in SBUFFR(1). */

/*           SGROUP is one more than the number of directories we've */
/*           passed by. */

	    sgroup = bufbas - dirbas + lstltd_(&t, &nsread, sbuffr) + 1;
	}

/*        SGROUP now indicates the set of interval start times in which */
/*        to search for the request epoch. */

/*        Now we'll look up the time tags in the group of epochs we've */
/*        identified. */

/*        We'll use the variable names SBEGIX and SENDIX to refer to the */
/*        indices, relative to the set of start times, of the first and */
/*        last start times in the set we're going to look up. */

	if (sgroup == 1) {
	    sbegix = 1;
	    sendix = min(nints,102);
	} else {

/*           Look up the start times for the group of interest. Also */
/*           buffer last start time from the previous group. Also, it */
/*           turns out to be useful to pick up two extra start */
/*           times---the first two start times of the next group---if */
/*           they exist. */

	    sbegix = (sgroup - 1) * 100;
/* Computing MIN */
	    i__1 = sbegix + 102;
	    sendix = min(i__1,nints);
	}
	timbas = dirbas - nints;
	i__1 = timbas + sbegix;
	i__2 = timbas + sendix;
	dafgda_(handle, &i__1, &i__2, sbuffr);
	nsread = sendix - sbegix + 1;

/*        Find the last interval start time less than or equal to the */
/*        request time.  We know T is greater than or equal to the */
/*        first start time, so I will be > 0. */

	nsrch = min(101,nsread);
	i__ = lstled_(&t, &nsrch, sbuffr);
	start = sbuffr[(i__1 = i__ - 1) < 103 && 0 <= i__1 ? i__1 : s_rnge(
		"sbuffr", i__1, "ckr05_", (ftnlen)956)];

/*        Let NSTART ("next start") be the start time that follows */
/*        START, if START is not the last start time.  If NSTART */
/*        has a successor, let NNSTRT be that start time. */

	if (i__ < nsread) {
	    nstart = sbuffr[(i__1 = i__) < 103 && 0 <= i__1 ? i__1 : s_rnge(
		    "sbuffr", i__1, "ckr05_", (ftnlen)965)];
	    if (i__ + 1 < nsread) {
		nnstrt = sbuffr[(i__1 = i__ + 1) < 103 && 0 <= i__1 ? i__1 : 
			s_rnge("sbuffr", i__1, "ckr05_", (ftnlen)969)];
	    } else {
		nnstrt = dpmax_();
	    }
	} else {
	    nstart = dpmax_();
	    nnstrt = dpmax_();
	}
    }

/*     If T does not lie within the interpolation interval starting */
/*     at time START, we'll determine whether T is closer to this */
/*     interval or the next.  If the distance between T and the */
/*     closer interval is less than or equal to TOL, we'll map T */
/*     to the closer endpoint of the closer interval.  Otherwise, */
/*     we return without finding pointing. */

    if (hepoch == nstart) {

/*        The first time tag greater than or equal to T is the start */
/*        time of the next interpolation interval. */

/*        The request time lies between interpolation intervals. */
/*        LEPOCH is the last time tag of the first interval; HEPOCH */
/*        is the first time tag of the next interval. */

	if ((d__1 = t - lepoch, abs(d__1)) <= (d__2 = hepoch - t, abs(d__2))) 
		{

/*           T is closer to the first interval... */

	    if ((d__1 = t - lepoch, abs(d__1)) > *tol) {

/*              ...But T is too far from the interval. */

		chkout_("CKR05", (ftnlen)5);
		return 0;
	    }

/*           Map T to the right endpoint of the preceding interval. */

	    t = lepoch;
	    high = low;
	    hepoch = lepoch;
	} else {

/*           T is closer to the second interval... */

	    if ((d__1 = hepoch - t, abs(d__1)) > *tol) {

/*              ...But T is too far from the interval. */

		chkout_("CKR05", (ftnlen)5);
		return 0;
	    }

/*           Map T to the left endpoint of the next interval. */

	    t = hepoch;
	    low = high;
	    lepoch = hepoch;

/*           Since we're going to be picking time tags from the next */
/*           interval, we'll need to adjust START and NSTART. */

	    start = nstart;
	    nstart = nnstrt;
	}
    }

/*     We now have */

/*        LEPOCH < T <  HEPOCH */
/*                -   - */

/*     where LEPOCH and HEPOCH are the time tags at indices */
/*     LOW and HIGH, respectively. */

/*     Now select the set of packets used for interpolation.  Note */
/*     that the window size is known to be even. */

/*     Unlike CK types 8, 9, 12, and 13, for type 05 we adjust */
/*     the window size to keep the request time within the central */
/*     interval of the window. */

/*     The nominal bracketing epochs we've found are the (WNDSIZ/2)nd */
/*     and (WNDSIZ/2 + 1)st of the interpolating set.  If the request */
/*     time is too close to one end of the interpolation interval, we */
/*     reduce the window size, after which one endpoint of the window */
/*     will coincide with an endpoint of the interpolation interval. */

/*     We start out by looking up the set of time tags we'd use */
/*     if there were no gaps in the coverage.  We then trim our */
/*     time tag set to ensure all tags are in the interpolation */
/*     interval.  It's possible that the interpolation window will */
/*     collapse to a single point as a result of this last step. */

/*     Let LSIZE be the size of the "left half" of the window:  the */
/*     size of the set of window epochs to the left of the request time. */
/*     We want this size to be WNDSIZ/2, but if not enough states are */
/*     available, the set ranges from index 1 to index LOW. */

/* Computing MIN */
    i__1 = wndsiz / 2;
    lsize = min(i__1,low);

/*     RSIZE is defined analogously for the right half of the window. */

/* Computing MIN */
    i__1 = wndsiz / 2, i__2 = n - high + 1;
    rsize = min(i__1,i__2);

/*     The window size is simply the sum of LSIZE and RSIZE. */

    wndsiz = lsize + rsize;

/*     FIRST and LAST are the endpoints of the range of indices of */
/*     time tags (and packets) we'll collect in the output record. */

    first = low - lsize + 1;
    last = first + wndsiz - 1;

/*     Buffer the epochs. */

    wstart = begin + n * packsz + first - 1;
    i__1 = wstart + wndsiz - 1;
    dafgda_(handle, &wstart, &i__1, pbuffr);

/*     Discard any epochs less than START or greater than or equal */
/*     to NSTART.  The set of epochs we want ranges from indices */
/*     I+1 to J.  This range is non-empty unless START and NSTART */
/*     are both DPMAX(). */

    i__ = lstltd_(&start, &wndsiz, pbuffr);
    j = lstltd_(&nstart, &wndsiz, pbuffr);
    if (i__ == j) {

/*        Fuggedaboudit. */

	chkout_("CKR05", (ftnlen)5);
	return 0;
    }

/*     Update FIRST, LAST, and WNDSIZ. */

    wndsiz = j - i__;
    first += i__;
    last = first + wndsiz - 1;

/*     Put the subtype into the output record.  The size of the group */
/*     of packets is derived from the subtype, so we need not include */
/*     the size. */

    record[0] = t;
    record[1] = (doublereal) subtyp;
    record[2] = (doublereal) wndsiz;
    record[3] = rate;

/*     Read the packets. */

    i__1 = begin + (first - 1) * packsz;
    i__2 = begin + last * packsz - 1;
    dafgda_(handle, &i__1, &i__2, &record[4]);

/*     Finally, add the epochs to the output record. */

    i__2 = j - i__;
    moved_(&pbuffr[(i__1 = i__) < 101 && 0 <= i__1 ? i__1 : s_rnge("pbuffr", 
	    i__1, "ckr05_", (ftnlen)1158)], &i__2, &record[wndsiz * packsz + 
	    4]);

/*     Save the information about the interval and segment. */

    lhand = *handle;
    lbeg = begin;
    lend = end;
    prevs = start;
    prevn = nstart;
    prevnn = nnstrt;

/*     Indicate pointing was found. */

    *found = TRUE_;
    chkout_("CKR05", (ftnlen)5);
    return 0;
} /* ckr05_ */
コード例 #30
0
ファイル: invort.c プロジェクト: Dbelsa/coft
/* $Procedure      INVORT ( Invert nearly orthogonal matrices ) */
/* Subroutine */ int invort_(doublereal *m, doublereal *mit)
{
    /* Initialized data */

    static logical first = TRUE_;

    /* System generated locals */
    integer i__1, i__2;

    /* Builtin functions */
    integer s_rnge(char *, integer, char *, integer);

    /* Local variables */
    doublereal temp[9]	/* was [3][3] */;
    integer i__;
    doublereal scale;
    extern /* Subroutine */ int chkin_(char *, ftnlen);
    static doublereal bound;
    extern doublereal dpmax_(void);
    extern /* Subroutine */ int errdp_(char *, doublereal *, ftnlen), xpose_(
	    doublereal *, doublereal *), unorm_(doublereal *, doublereal *, 
	    doublereal *);
    doublereal length;
    extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *, 
	    ftnlen), vsclip_(doublereal *, doublereal *), setmsg_(char *, 
	    ftnlen), errint_(char *, integer *, ftnlen);

/* $ Abstract */

/*     Construct the inverse of a 3x3 matrix with orthogonal columns */
/*     and non-zero norms using a numerical stable algorithm. */

/* $ 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 */

/*     MATRIX */

/* $ Declarations */
/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     M          I   A 3x3 matrix. */
/*     MIT        I   M after transposition and scaling of rows. */

/* $ Detailed_Input */

/*     M          is a 3x3 matrix. */

/* $ Detailed_Output */

/*     MIT        is the matrix obtained by transposing M and dividing */
/*                the rows by squares of their norms. */

/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     1) If any of the columns of M have zero length, the error */
/*        SPICE(ZEROLENGTHCOLUMN) will be signaled. */

/*     2) If any column is too short to allow computation of the */
/*        reciprocal of its length without causing a floating */
/*        point overflow, the error SPICE(COLUMNTOOSMALL) will */
/*        be signaled. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     Suppose that M is the matrix */

/*             -                      - */
/*            |   A*u    B*v     C*w   | */
/*            |      1      1       1  | */
/*            |                        | */
/*            |   A*u    B*v     C*w   | */
/*            |      2      2       2  | */
/*            |                        | */
/*            |   A*u    B*v     C*w   | */
/*            |      3      3       3  | */
/*             -                      - */

/*     where the vectors (u , u , u ),  (v , v , v ),  and (w , w , w ) */
/*                         1   2   3      1   2   3          1   2   3 */
/*     are unit vectors. This routine produces the matrix: */


/*             -                      - */
/*            |   a*u    a*u     a*u   | */
/*            |      1      2       3  | */
/*            |                        | */
/*            |   b*v    b*v     b*v   | */
/*            |      1      2       3  | */
/*            |                        | */
/*            |   c*w    c*w     c*w   | */
/*            |      1      2       3  | */
/*             -                      - */

/*     where a = 1/A, b = 1/B, and c = 1/C. */

/* $ Examples */

/*     Suppose that you have a matrix M whose columns are orthogonal */
/*     and have non-zero norm (but not necessarily norm 1).  Then the */
/*     routine INVORT can be used to construct the inverse of M: */

/*        CALL INVORT ( M, INVERS ) */

/*     This method is numerically more robust than calling the */
/*     routine INVERT. */

/* $ Restrictions */

/*     None. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */
/*     W.L. Taber     (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.1.1, 14-NOV-2013 (EDW) */

/*        Edit to Abstract. Eliminated unneeded Revisions section. */

/* -    SPICELIB Version 1.1.0, 02-SEP-2005 (NJB) */

/*        Updated to remove non-standard use of duplicate arguments */
/*        in VSCL call. */

/* -    SPICELIB Version 1.0.0, 02-JAN-2002 (WLT) */

/* -& */
/* $ Index_Entries */

/*     Transpose a matrix and invert the lengths of the rows */
/*     Invert a pseudo orthogonal matrix */

/* -& */

/*     SPICELIB functions */


/*     Local Variables */


/*     Saved variables */


/*     Initial values */


/*     Use discovery check-in. */


/*     The first time through, get a copy of DPMAX. */

    if (first) {
	bound = dpmax_();
	first = FALSE_;
    }

/*     For each column, construct a scaled copy. However, make sure */
/*     everything is do-able before trying something. */

    for (i__ = 1; i__ <= 3; ++i__) {
	unorm_(&m[(i__1 = i__ * 3 - 3) < 9 && 0 <= i__1 ? i__1 : s_rnge("m", 
		i__1, "invort_", (ftnlen)208)], &temp[(i__2 = i__ * 3 - 3) < 
		9 && 0 <= i__2 ? i__2 : s_rnge("temp", i__2, "invort_", (
		ftnlen)208)], &length);
	if (length == 0.) {
	    chkin_("INVORT", (ftnlen)6);
	    setmsg_("Column # of the input matrix has a norm of zero. ", (
		    ftnlen)49);
	    errint_("#", &i__, (ftnlen)1);
	    sigerr_("SPICE(ZEROLENGTHCOLUMN)", (ftnlen)23);
	    chkout_("INVORT", (ftnlen)6);
	    return 0;
	}

/*        Make sure we can actually rescale the rows. */

	if (length < 1.) {
	    if (length * bound < 1.) {
		chkin_("INVORT", (ftnlen)6);
		setmsg_("The length of column # is #. This number cannot be "
			"inverted.  For this reason, the scaled transpose of "
			"the input matrix cannot be formed. ", (ftnlen)138);
		errint_("#", &i__, (ftnlen)1);
		errdp_("#", &length, (ftnlen)1);
		sigerr_("SPICE(COLUMNTOOSMALL)", (ftnlen)21);
		chkout_("INVORT", (ftnlen)6);
		return 0;
	    }
	}
	scale = 1. / length;
	vsclip_(&scale, &temp[(i__1 = i__ * 3 - 3) < 9 && 0 <= i__1 ? i__1 : 
		s_rnge("temp", i__1, "invort_", (ftnlen)246)]);
    }

/*     If we make it this far, we just need to transpose TEMP into MIT. */

    xpose_(temp, mit);
    return 0;
} /* invort_ */