/* Subroutine */ int deriv_(doublereal *geo, doublereal *grad)
{
/* Initialized data */
static integer icalcn = 0;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
char ch__1[80];
olist o__1;
alist al__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), f_open(olist *), f_rew(
alist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_rsfe(void), s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double pow_di(doublereal *, integer *), sqrt(doublereal);
integer s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer i__, j;
static logical ci;
static integer ii, ij, il, jl, kl, ll, kk;
static logical aic;
extern doublereal dot_(doublereal *, doublereal *, integer *);
static logical int__;
extern /* Subroutine */ int mxm_(doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
static doublereal sum;
static logical scf1;
static char line[80];
static integer ncol;
static doublereal xjuc[3], step;
static logical slow;
static integer icapa;
static logical halfe, debug;
extern /* Subroutine */ int dcart_(doublereal *, doublereal *);
static integer iline;
static logical geook;
static doublereal grlim;
static integer ilowa;
static doublereal gnorm;
extern /* Subroutine */ int geout_(integer *);
static integer ilowz;
static doublereal change[3], aidref[360];
static integer idelta;
extern /* Character */ VOID getnam_(char *, ftnlen, char *, ftnlen);
static logical precis, noanci, aifrst;
extern /* Subroutine */ int dernvo_(doublereal *, doublereal *), jcarin_(
doublereal *, doublereal *, doublereal *, logical *, doublereal *,
integer *), gmetry_(doublereal *, doublereal *), deritr_(
doublereal *, doublereal *), symtry_(void);
/* Fortran I/O blocks */
static cilist io___14 = { 0, 5, 0, "(A)", 0 };
static cilist io___17 = { 1, 5, 1, "(A)", 0 };
static cilist io___19 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___20 = { 0, 6, 0, "(A)", 0 };
static cilist io___21 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___22 = { 0, 6, 0, "(A)", 0 };
static cilist io___23 = { 0, 6, 0, "(6F12.6)", 0 };
static cilist io___25 = { 1, 5, 1, 0, 0 };
static cilist io___26 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___27 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___28 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___29 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___31 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___32 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___37 = { 0, 6, 0, "(' GEO AT START OF DERIV')", 0 };
static cilist io___38 = { 0, 6, 0, "(F19.5,2F12.5)", 0 };
static cilist io___42 = { 0, 6, 0, 0, 0 };
static cilist io___43 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, "(//,3(A,/),I3,A)", 0 };
static cilist io___55 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, "(' GRADIENTS')", 0 };
static cilist io___58 = { 0, 6, 0, "(10F8.3)", 0 };
static cilist io___59 = { 0, 6, 0, "(' ERROR FUNCTION')", 0 };
static cilist io___60 = { 0, 6, 0, "(10F8.3)", 0 };
static cilist io___61 = { 0, 6, 0, "(' COSINE OF SEARCH DIRECTION =',F30"
".6)", 0 };
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
/* *********************************************************************** */
/* DERIV CALCULATES THE DERIVATIVES OF THE ENERGY WITH RESPECT TO THE */
/* INTERNAL COORDINATES. THIS IS DONE BY FINITE DIFFERENCES. */
/* THE MAIN ARRAYS IN DERIV ARE: */
/* LOC INTEGER ARRAY, LOC(1,I) CONTAINS THE ADDRESS OF THE ATOM */
/* INTERNAL COORDINATE LOC(2,I) IS TO BE USED IN THE */
/* DERIVATIVE CALCULATION. */
/* GEO ARRAY \GEO\ HOLDS THE INTERNAL COORDINATES. */
/* GRAD ON EXIT, CONTAINS THE DERIVATIVES */
/* *********************************************************************** */
/* Parameter adjustments */
--grad;
geo -= 4;
/* Function Body */
if (icalcn != numcal_1.numcal) {
aifrst = i_indx(keywrd_1.keywrd, "RESTART", (ftnlen)241, (ftnlen)7) ==
0;
debug = i_indx(keywrd_1.keywrd, "DERIV", (ftnlen)241, (ftnlen)5) != 0;
precis = i_indx(keywrd_1.keywrd, "PREC", (ftnlen)241, (ftnlen)4) != 0;
int__ = i_indx(keywrd_1.keywrd, " XYZ", (ftnlen)241, (ftnlen)4) == 0;
geook = i_indx(keywrd_1.keywrd, "GEO-OK", (ftnlen)241, (ftnlen)6) !=
0;
ci = i_indx(keywrd_1.keywrd, "C.I.", (ftnlen)241, (ftnlen)4) != 0;
scf1 = i_indx(keywrd_1.keywrd, "1SCF", (ftnlen)241, (ftnlen)4) != 0;
aic = i_indx(keywrd_1.keywrd, "AIDER", (ftnlen)241, (ftnlen)5) != 0;
icapa = 'A';
ilowa = 'a';
ilowz = 'z';
if (aic && aifrst) {
o__1.oerr = 0;
o__1.ounit = 5;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, "FOR005", (ftnlen)6);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = "ZERO";
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 5;
f_rew(&al__1);
/* ISOK IS SET FALSE: ONLY ONE SYSTEM ALLOWED */
okmany_1.isok = FALSE_;
for (i__ = 1; i__ <= 3; ++i__) {
/* L10: */
s_rsfe(&io___14);
do_fio(&c__1, line, (ftnlen)80);
e_rsfe();
}
for (j = 1; j <= 1000; ++j) {
i__1 = s_rsfe(&io___17);
if (i__1 != 0) {
goto L40;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L40;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L40;
}
/* *********************************************************************** */
for (i__ = 1; i__ <= 80; ++i__) {
iline = *(unsigned char *)&line[i__ - 1];
if (iline >= ilowa && iline <= ilowz) {
*(unsigned char *)&line[i__ - 1] = (char) (iline +
icapa - ilowa);
}
/* L20: */
}
/* *********************************************************************** */
/* L30: */
if (i_indx(line, "AIDER", (ftnlen)80, (ftnlen)5) != 0) {
goto L60;
}
}
L40:
s_wsfe(&io___19);
do_fio(&c__1, " KEYWORD \"AIDER\" SPECIFIED, BUT NOT", (ftnlen)35)
;
e_wsfe();
s_wsfe(&io___20);
do_fio(&c__1, " PRESENT AFTER Z-MATRIX. JOB STOPPED", (ftnlen)37)
;
e_wsfe();
s_stop("", (ftnlen)0);
L50:
s_wsfe(&io___21);
do_fio(&c__1, " FAULT IN READ OF AB INITIO DERIVATIVES", (ftnlen)
40);
e_wsfe();
s_wsfe(&io___22);
do_fio(&c__1, " DERIVATIVES READ IN ARE AS FOLLOWS", (ftnlen)36);
e_wsfe();
s_wsfe(&io___23);
i__1 = i__;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&aidref[j - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
s_stop("", (ftnlen)0);
L60:
if (geokst_1.natoms > 2) {
j = geokst_1.natoms * 3 - 6;
} else {
j = 1;
}
i__1 = s_rsle(&io___25);
if (i__1 != 0) {
goto L50;
}
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = do_lio(&c__5, &c__1, (char *)&aidref[i__ - 1], (ftnlen)
sizeof(doublereal));
if (i__1 != 0) {
goto L50;
}
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L50;
}
s_wsfe(&io___26);
do_fio(&c__1, " AB-INITIO DERIVATIVES IN KCAL/MOL/(ANGSTROM OR R"
"ADIAN)", (ftnlen)55);
e_wsfe();
s_wsfe(&io___27);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&aidref[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
if (geovar_1.loc[(i__ << 1) - 2] > 3) {
j = geovar_1.loc[(i__ << 1) - 2] * 3 + geovar_1.loc[(i__
<< 1) - 1] - 9;
} else if (geovar_1.loc[(i__ << 1) - 2] == 3) {
j = geovar_1.loc[(i__ << 1) - 1] + 1;
} else {
j = 1;
}
/* L70: */
aidref[i__ - 1] = aidref[j - 1];
}
s_wsfe(&io___28);
do_fio(&c__1, " AB-INITIO DERIVATIVES FOR VARIABLES", (ftnlen)36);
e_wsfe();
s_wsfe(&io___29);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&aidref[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
if (geosym_1.ndep != 0) {
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
sum = aidref[i__ - 1];
i__2 = geosym_1.ndep;
for (j = 1; j <= i__2; ++j) {
if (geovar_1.loc[(i__ << 1) - 2] == geosym_1.locpar[j
- 1] && (geovar_1.loc[(i__ << 1) - 1] ==
geosym_1.idepfn[j - 1] || geovar_1.loc[(i__ <<
1) - 1] == 3 && geosym_1.idepfn[j - 1] == 14)
) {
aidref[i__ - 1] += sum;
}
/* L80: */
}
/* L90: */
}
s_wsfe(&io___31);
do_fio(&c__1, " AB-INITIO DERIVATIVES AFTER SYMMETRY WEIGHTI"
"NG", (ftnlen)47);
e_wsfe();
s_wsfe(&io___32);
i__1 = geovar_1.nvar;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&aidref[j - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
}
icalcn = numcal_1.numcal;
if (i_indx(keywrd_1.keywrd, "RESTART", (ftnlen)241, (ftnlen)7) == 0) {
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
errfn_1.errfn[i__ - 1] = 0.;
}
}
grlim = .01;
if (precis) {
grlim = 1e-4;
}
halfe = molkst_1.nopen > molkst_1.nclose && molkst_1.fract != 2. &&
molkst_1.fract != 0. || ci;
idelta = -7;
/* IDELTA IS A MACHINE-PRECISION DEPENDANT INTEGER */
change[0] = pow_di(&c_b70, &idelta);
change[1] = pow_di(&c_b70, &idelta);
change[2] = pow_di(&c_b70, &idelta);
/* CHANGE(I) IS THE STEP SIZE USED IN CALCULATING THE DERIVATIVES. */
/* FOR "CARTESIAN" DERIVATIVES, CALCULATED USING DCART,AN */
/* INFINITESIMAL STEP, HERE 0.000001, IS ACCEPTABLE. IN THE */
/* HALF-ELECTRON METHOD A QUITE LARGE STEP IS NEEDED AS FULL SCF */
/* CALCULATIONS ARE NEEDED, AND THE DIFFERENCE BETWEEN THE TOTAL */
/* ENERGIES IS USED. THE STEP CANNOT BE VERY LARGE, AS THE SECOND */
/* DERIVITIVE IN FLEPO IS CALCULATED FROM THE DIFFERENCES OF TWO */
/* FIRST DERIVATIVES. CHANGE(1) IS FOR CHANGE IN BOND LENGTH, */
/* (2) FOR ANGLE, AND (3) FOR DIHEDRAL. */
}
if (geovar_1.nvar == 0) {
return 0;
}
if (debug) {
s_wsfe(&io___37);
e_wsfe();
s_wsfe(&io___38);
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
do_fio(&c__1, (char *)&geo[j + i__ * 3], (ftnlen)sizeof(
doublereal));
}
}
e_wsfe();
}
gnorm = 0.;
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
genral_1.gold[i__ - 1] = grad[i__];
genral_1.xparam[i__ - 1] = geo[geovar_1.loc[(i__ << 1) - 1] +
geovar_1.loc[(i__ << 1) - 2] * 3];
/* L110: */
/* Computing 2nd power */
d__1 = grad[i__];
gnorm += d__1 * d__1;
}
gnorm = sqrt(gnorm);
slow = FALSE_;
noanci = FALSE_;
if (halfe) {
noanci = i_indx(keywrd_1.keywrd, "NOANCI", (ftnlen)241, (ftnlen)6) !=
0 || molkst_1.nopen == molkst_1.norbs;
slow = noanci && (gnorm < grlim || scf1);
}
if (geosym_1.ndep != 0) {
symtry_();
}
gmetry_(&geo[4], genral_1.coord);
/* COORD NOW HOLDS THE CARTESIAN COORDINATES */
if (halfe && ! noanci) {
if (debug) {
s_wsle(&io___42);
do_lio(&c__9, &c__1, "DOING ANALYTICAL C.I. DERIVATIVES", (ftnlen)
33);
e_wsle();
}
dernvo_(genral_1.coord, xyzgra_1.dxyz);
} else {
if (debug) {
s_wsle(&io___43);
do_lio(&c__9, &c__1, "DOING VARIATIONALLY OPIMIZED DERIVATIVES", (
ftnlen)40);
e_wsle();
}
dcart_(genral_1.coord, xyzgra_1.dxyz);
}
ij = 0;
i__1 = molkst_1.numat;
for (ii = 1; ii <= i__1; ++ii) {
i__2 = ucell_1.l1u;
for (il = ucell_1.l1l; il <= i__2; ++il) {
i__3 = ucell_1.l2u;
for (jl = ucell_1.l2l; jl <= i__3; ++jl) {
i__4 = ucell_1.l3u;
for (kl = ucell_1.l3l; kl <= i__4; ++kl) {
/* $DOIT ASIS */
for (ll = 1; ll <= 3; ++ll) {
/* L120: */
xjuc[ll - 1] = genral_1.coord[ll + ii * 3 - 4] +
euler_1.tvec[ll - 1] * il + euler_1.tvec[ll +
2] * jl + euler_1.tvec[ll + 5] * kl;
}
++ij;
/* $DOIT ASIS */
for (kk = 1; kk <= 3; ++kk) {
genral_1.cold[kk + ij * 3 - 4] = xjuc[kk - 1];
/* L130: */
}
/* L140: */
}
}
}
/* L150: */
}
step = change[0];
jcarin_(genral_1.coord, genral_1.xparam, &step, &precis, work3_1.work2, &
ncol);
mxm_(work3_1.work2, &geovar_1.nvar, xyzgra_1.dxyz, &ncol, &grad[1], &c__1)
;
if (precis) {
step = .5 / step;
} else {
step = 1. / step;
}
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L160: */
grad[i__] *= step;
}
/* NOW TO ENSURE THAT INTERNAL DERIVATIVES ACCURATELY REFLECT CARTESIAN */
/* DERIVATIVES */
if (int__ && ! geook && geovar_1.nvar >= molkst_1.numat * 3 - 6 &&
euler_1.id == 0) {
/* NUMBER OF VARIABLES LOOKS O.K. */
sum = dot_(&grad[1], &grad[1], &geovar_1.nvar);
i__1 = molkst_1.numat * 3;
/* Computing MAX */
d__1 = 4., d__2 = sum * 4.;
if (sum < 2. && dot_(xyzgra_1.dxyz, xyzgra_1.dxyz, &i__1) > max(d__1,
d__2)) {
/* OOPS, LOOKS LIKE AN ERROR. */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
j = (integer) (genral_1.xparam[i__ - 1] / 3.141);
if (geovar_1.loc[(i__ << 1) - 1] == 2 && geovar_1.loc[(i__ <<
1) - 2] > 3 && (d__1 = genral_1.xparam[i__ - 1] - j *
3.1415926, abs(d__1)) < .005) {
/* ERROR LOCATED, BUT CANNOT CORRECT IN THIS RUN */
s_wsfe(&io___54);
do_fio(&c__1, " INTERNAL COORDINATE DERIVATIVES DO NOT R"
"EFLECT", (ftnlen)47);
do_fio(&c__1, " CARTESIAN COORDINATE DERIVATIVES", (
ftnlen)33);
do_fio(&c__1, " TO CORRECT ERROR, INCREASE DIHEDRAL OF A"
"TOM", (ftnlen)44);
do_fio(&c__1, (char *)&geovar_1.loc[(i__ << 1) - 2], (
ftnlen)sizeof(integer));
do_fio(&c__1, " BY 90 DEGREES", (ftnlen)14);
e_wsfe();
s_wsfe(&io___55);
do_fio(&c__1, " CURRENT GEOMETRY", (ftnlen)21);
e_wsfe();
geout_(&c__6);
s_stop("", (ftnlen)0);
}
/* L170: */
}
}
}
/* THIS CODE IS ONLY USED IF THE KEYWORD NOANCI IS SPECIFIED */
if (slow) {
if (debug) {
s_wsle(&io___56);
do_lio(&c__9, &c__1, "DOING FULL SCF DERIVATIVES", (ftnlen)26);
e_wsle();
}
deritr_(errfn_1.errfn, &geo[4]);
/* THE ARRAY ERRFN HOLDS THE EXACT DERIVATIVES MINUS THE APPROXIMATE */
/* DERIVATIVES */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L180: */
errfn_1.errfn[i__ - 1] -= grad[i__];
}
}
gravec_1.cosine = dot_(&grad[1], genral_1.gold, &geovar_1.nvar) / sqrt(
dot_(&grad[1], &grad[1], &geovar_1.nvar) * dot_(genral_1.gold,
genral_1.gold, &geovar_1.nvar) + 1e-20);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L190: */
grad[i__] += errfn_1.errfn[i__ - 1];
}
if (aic) {
if (aifrst) {
aifrst = FALSE_;
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L200: */
errfn_1.aicorr[i__ - 1] = -aidref[i__ - 1] - grad[i__];
}
}
/* # WRITE(6,'('' GRADIENTS BEFORE AI CORRECTION'')') */
/* # WRITE(6,'(10F8.3)')(GRAD(I),I=1,NVAR) */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L210: */
grad[i__] += errfn_1.aicorr[i__ - 1];
}
}
/* L220: */
if (debug) {
s_wsfe(&io___57);
e_wsfe();
s_wsfe(&io___58);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&grad[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
if (slow) {
s_wsfe(&io___59);
e_wsfe();
s_wsfe(&io___60);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&errfn_1.errfn[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
}
if (debug) {
s_wsfe(&io___61);
do_fio(&c__1, (char *)&gravec_1.cosine, (ftnlen)sizeof(doublereal));
e_wsfe();
}
return 0;
} /* deriv_ */
/* $Procedure BODMAT ( Return transformation matrix for a body ) */
/* Subroutine */ int bodmat_(integer *body, doublereal *et, doublereal *tipm)
{
/* Initialized data */
static logical first = TRUE_;
static logical found = FALSE_;
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_dnnt(doublereal *);
double sin(doublereal), cos(doublereal), d_mod(doublereal *, doublereal *)
;
/* Local variables */
integer cent;
char item[32];
doublereal j2ref[9] /* was [3][3] */;
extern integer zzbodbry_(integer *);
extern /* Subroutine */ int eul2m_(doublereal *, doublereal *, doublereal
*, integer *, integer *, integer *, doublereal *);
doublereal d__;
integer i__, j;
doublereal dcoef[3], t, w;
extern /* Subroutine */ int etcal_(doublereal *, char *, ftnlen);
integer refid;
doublereal delta;
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal epoch, rcoef[3], tcoef[200] /* was [2][100] */, wcoef[3];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
doublereal theta;
extern /* Subroutine */ int moved_(doublereal *, integer *, doublereal *),
repmi_(char *, char *, integer *, char *, ftnlen, ftnlen, ftnlen)
, errdp_(char *, doublereal *, ftnlen);
doublereal costh[100];
extern doublereal vdotg_(doublereal *, doublereal *, integer *);
char dtype[1];
doublereal sinth[100], tsipm[36] /* was [6][6] */;
extern doublereal twopi_(void);
static integer j2code;
doublereal ac[100], dc[100];
integer na, nd;
doublereal ra, wc[100];
extern /* Subroutine */ int cleard_(integer *, doublereal *);
extern logical bodfnd_(integer *, char *, ftnlen);
extern /* Subroutine */ int bodvcd_(integer *, char *, integer *, integer
*, doublereal *, ftnlen);
integer frcode;
extern doublereal halfpi_(void);
extern /* Subroutine */ int ccifrm_(integer *, integer *, integer *, char
*, integer *, logical *, ftnlen);
integer nw;
doublereal conepc, conref;
extern /* Subroutine */ int pckmat_(integer *, doublereal *, integer *,
doublereal *, logical *);
integer ntheta;
extern /* Subroutine */ int gdpool_(char *, integer *, integer *, integer
*, doublereal *, logical *, ftnlen);
char fixfrm[32], errmsg[1840];
extern /* Subroutine */ int irfnum_(char *, integer *, ftnlen), dtpool_(
char *, logical *, integer *, char *, ftnlen, ftnlen);
doublereal tmpmat[9] /* was [3][3] */;
extern /* Subroutine */ int setmsg_(char *, ftnlen), suffix_(char *,
integer *, char *, ftnlen, ftnlen), errint_(char *, integer *,
ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen),
irfrot_(integer *, integer *, doublereal *);
extern logical return_(void);
char timstr[35];
extern doublereal j2000_(void);
doublereal dec;
integer dim, ref;
doublereal phi;
extern doublereal rpd_(void), spd_(void);
extern /* Subroutine */ int mxm_(doublereal *, doublereal *, doublereal *)
;
/* $ Abstract */
/* Return the J2000 to body Equator and Prime Meridian coordinate */
/* transformation matrix for a specified body. */
/* $ 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 */
/* PCK */
/* NAIF_IDS */
/* TIME */
/* $ Keywords */
/* CONSTANTS */
/* $ 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 File: SPICELIB Error Handling Parameters */
/* errhnd.inc Version 2 18-JUN-1997 (WLT) */
/* The size of the long error message was */
/* reduced from 25*80 to 23*80 so that it */
/* will be accepted by the Microsoft Power Station */
/* FORTRAN compiler which has an upper bound */
/* of 1900 for the length of a character string. */
/* errhnd.inc Version 1 29-JUL-1997 (NJB) */
/* Maximum length of the long error message: */
/* Maximum length of the short error message: */
/* End Include File: SPICELIB Error Handling Parameters */
/* $ 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. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - 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) */
/* -& */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* BODY I ID code of body. */
/* ET I Epoch of transformation. */
/* TIPM O Transformation from Inertial to PM for BODY at ET. */
/* $ Detailed_Input */
/* BODY is the integer ID code of the body for which the */
/* transformation is requested. Bodies are numbered */
/* according to the standard NAIF numbering scheme. */
/* ET is the epoch at which the transformation is */
/* requested. (This is typically the epoch of */
/* observation minus the one-way light time from */
/* the observer to the body at the epoch of */
/* observation.) */
/* $ Detailed_Output */
/* TIPM is the transformation matrix from Inertial to body */
/* Equator and Prime Meridian. The X axis of the PM */
/* system is directed to the intersection of the */
/* equator and prime meridian. The Z axis points north. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If data required to define the body-fixed frame associated */
/* with BODY are not found in the binary PCK system or the kernel */
/* pool, the error SPICE(FRAMEDATANOTFOUND) is signaled. In */
/* the case of IAU style body-fixed frames, the absence of */
/* prime meridian polynomial data (which are required) is used */
/* as an indicator of missing data. */
/* 2) If the test for exception (1) passes, but in fact requested */
/* data are not available in the kernel pool, the error will be */
/* signaled by routines in the call tree of this routine. */
/* 3) If the kernel pool does not contain all of the data required */
/* to define the number of nutation precession angles */
/* corresponding to the available nutation precession */
/* coefficients, the error SPICE(INSUFFICIENTANGLES) is */
/* signaled. */
/* 4) If the reference frame REF is not recognized, a routine */
/* called by BODMAT will diagnose the condition and invoke the */
/* SPICE error handling system. */
/* 5) If the specified body code BODY is not recognized, the */
/* error is diagnosed by a routine called by BODMAT. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine is related to the more general routine TIPBOD */
/* which returns a matrix that transforms vectors from a */
/* specified inertial reference frame to body equator and */
/* prime meridian coordinates. TIPBOD accepts an input argument */
/* REF that allows the caller to specify an inertial reference */
/* frame. */
/* The transformation represented by BODMAT's output argument TIPM */
/* is defined as follows: */
/* TIPM = [W] [DELTA] [PHI] */
/* 3 1 3 */
/* If there exists high-precision binary PCK kernel information */
/* for the body at the requested time, these angles, W, DELTA */
/* and PHI are computed directly from that file. The most */
/* recently loaded binary PCK file has first priority followed */
/* by previously loaded binary PCK files in backward time order. */
/* If no binary PCK file has been loaded, the text P_constants */
/* kernel file is used. */
/* If there is only text PCK kernel information, it is */
/* expressed in terms of RA, DEC and W (same W as above), where */
/* RA = PHI - HALFPI() */
/* DEC = HALFPI() - DELTA */
/* RA, DEC, and W are defined as follows in the text PCK file: */
/* RA = RA0 + RA1*T + RA2*T*T + a sin theta */
/* i i */
/* DEC = DEC0 + DEC1*T + DEC2*T*T + d cos theta */
/* i i */
/* W = W0 + W1*d + W2*d*d + w sin theta */
/* i i */
/* where: */
/* d = days past J2000. */
/* T = Julian centuries past J2000. */
/* a , d , and w arrays apply to satellites only. */
/* i i i */
/* theta = THETA0 * THETA1*T are specific to each planet. */
/* i */
/* These angles -- typically nodal rates -- vary in number and */
/* definition from one planetary system to the next. */
/* $ Examples */
/* In the following code fragment, BODMAT is used to rotate */
/* the position vector (POS) from a target body (BODY) to a */
/* spacecraft from inertial coordinates to body-fixed coordinates */
/* at a specific epoch (ET), in order to compute the planetocentric */
/* longitude (PCLONG) of the spacecraft. */
/* CALL BODMAT ( BODY, ET, TIPM ) */
/* CALL MXV ( TIPM, POS, POS ) */
/* CALL RECLAT ( POS, RADIUS, PCLONG, LAT ) */
/* To compute the equivalent planetographic longitude (PGLONG), */
/* it is necessary to know the direction of rotation of the target */
/* body, as shown below. */
/* CALL BODVCD ( BODY, 'PM', 3, DIM, VALUES ) */
/* IF ( VALUES(2) .GT. 0.D0 ) THEN */
/* PGLONG = PCLONG */
/* ELSE */
/* PGLONG = TWOPI() - PCLONG */
/* END IF */
/* Note that the items necessary to compute the transformation */
/* TIPM must have been loaded into the kernel pool (by one or more */
/* previous calls to FURNSH). */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* 1) Refer to the NAIF_IDS required reading file for a complete */
/* list of the NAIF integer ID codes for bodies. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* K.S. Zukor (JPL) */
/* $ Version */
/* - SPICELIB Version 4.1.1, 01-FEB-2008 (NJB) */
/* The routine was updated to improve the error messages created */
/* when required PCK data are not found. Now in most cases the */
/* messages are created locally rather than by the kernel pool */
/* access routines. In particular missing binary PCK data will */
/* be indicated with a reasonable error message. */
/* - SPICELIB Version 4.1.0, 25-AUG-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM call. */
/* Calls to ZZBODVCD have been replaced with calls to */
/* BODVCD. */
/* - SPICELIB Version 4.0.0, 12-FEB-2004 (NJB) */
/* Code has been updated to support satellite ID codes in the */
/* range 10000 to 99999 and to allow nutation precession angles */
/* to be associated with any object. */
/* Implementation changes were made to improve robustness */
/* of the code. */
/* - SPICELIB Version 3.2.0, 22-MAR-1995 (KSZ) */
/* Gets TSIPM matrix from PCKMAT (instead of Euler angles */
/* from PCKEUL.) */
/* - SPICELIB Version 3.0.0, 10-MAR-1994 (KSZ) */
/* Ability to get Euler angles from binary PCK file added. */
/* This uses the new routine PCKEUL. */
/* - SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.0, 04-SEP-1991 (NJB) */
/* Updated to handle P_constants referenced to different epochs */
/* and inertial reference frames. */
/* The header was updated to specify that the inertial reference */
/* frame used by BODMAT is restricted to be J2000. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) (IMU) */
/* -& */
/* $ Index_Entries */
/* fetch transformation matrix for a body */
/* transformation from j2000 position to bodyfixed */
/* transformation from j2000 to bodyfixed coordinates */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 4.1.0, 25-AUG-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM call. */
/* Calls to ZZBODVCD have been replaced with calls to */
/* BODVCD. */
/* - SPICELIB Version 4.0.0, 12-FEB-2004 (NJB) */
/* Code has been updated to support satellite ID codes in the */
/* range 10000 to 99999 and to allow nutation precession angles */
/* to be associated with any object. */
/* Calls to deprecated kernel pool access routine RTPOOL */
/* were replaced by calls to GDPOOL. */
/* Calls to BODVAR have been replaced with calls to */
/* ZZBODVCD. */
/* - SPICELIB Version 3.2.0, 22-MAR-1995 (KSZ) */
/* BODMAT now get the TSIPM matrix from PCKMAT, and */
/* unpacks TIPM from it. Also the calculated but unused */
/* variable LAMBDA was removed. */
/* - SPICELIB Version 3.0.0, 10-MAR-1994 (KSZ) */
/* BODMAT now uses new software to check for the */
/* existence of binary PCK files, search the for */
/* data corresponding to the requested body and time, */
/* and return the appropriate Euler angles, using the */
/* new routine PCKEUL. Otherwise the code calculates */
/* the Euler angles from the P_constants kernel file. */
/* - SPICELIB Version 2.0.0, 04-SEP-1991 (NJB) */
/* Updated to handle P_constants referenced to different epochs */
/* and inertial reference frames. */
/* The header was updated to specify that the inertial reference */
/* frame used by BODMAT is restricted to be J2000. */
/* BODMAT now checks the kernel pool for presence of the */
/* variables */
/* BODY#_CONSTANTS_REF_FRAME */
/* and */
/* BODY#_CONSTANTS_JED_EPOCH */
/* where # is the NAIF integer code of the barycenter of a */
/* planetary system or of a body other than a planet or */
/* satellite. If either or both of these variables are */
/* present, the P_constants for BODY are presumed to be */
/* referenced to the specified inertial frame or epoch. */
/* If the epoch of the constants is not J2000, the input */
/* time ET is converted to seconds past the reference epoch. */
/* If the frame of the constants is not J2000, the rotation from */
/* the P_constants' frame to body-fixed coordinates is */
/* transformed to the rotation from J2000 coordinates to */
/* body-fixed coordinates. */
/* For efficiency reasons, this routine now duplicates much */
/* of the code of BODEUL so that it doesn't have to call BODEUL. */
/* In some cases, BODEUL must covert Euler angles to a matrix, */
/* rotate the matrix, and convert the result back to Euler */
/* angles. If this routine called BODEUL, then in such cases */
/* this routine would convert the transformed angles back to */
/* a matrix. That would be a bit much.... */
/* - Beta Version 1.1.0, 16-FEB-1989 (IMU) (NJB) */
/* Examples section completed. Declaration of unused variable */
/* FOUND removed. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE Error handling. */
if (return_()) {
return 0;
} else {
chkin_("BODMAT", (ftnlen)6);
}
/* Get the code for the J2000 frame, if we don't have it yet. */
if (first) {
irfnum_("J2000", &j2code, (ftnlen)5);
first = FALSE_;
}
/* Get Euler angles from high precision data file. */
pckmat_(body, et, &ref, tsipm, &found);
if (found) {
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 3; ++j) {
tipm[(i__1 = i__ + j * 3 - 4) < 9 && 0 <= i__1 ? i__1 :
s_rnge("tipm", i__1, "bodmat_", (ftnlen)485)] = tsipm[
(i__2 = i__ + j * 6 - 7) < 36 && 0 <= i__2 ? i__2 :
s_rnge("tsipm", i__2, "bodmat_", (ftnlen)485)];
}
}
} else {
/* The data for the frame of interest are not available in a */
/* loaded binary PCK file. This is not an error: the data may be */
/* present in the kernel pool. */
/* Conduct a non-error-signaling check for the presence of a */
/* kernel variable that is required to implement an IAU style */
/* body-fixed reference frame. If the data aren't available, we */
/* don't want BODVCD to signal a SPICE(KERNELVARNOTFOUND) error; */
/* we want to issue the error signal locally, with a better error */
/* message. */
s_copy(item, "BODY#_PM", (ftnlen)32, (ftnlen)8);
repmi_(item, "#", body, item, (ftnlen)32, (ftnlen)1, (ftnlen)32);
dtpool_(item, &found, &nw, dtype, (ftnlen)32, (ftnlen)1);
if (! found) {
/* Now we do have an error. */
/* We don't have the data we'll need to produced the requested */
/* state transformation matrix. In order to create an error */
/* message understandable to the user, find, if possible, the */
/* name of the reference frame associated with the input body. */
/* Note that the body is really identified by a PCK frame class */
/* ID code, though most of the documentation just calls it a */
/* body ID code. */
ccifrm_(&c__2, body, &frcode, fixfrm, ¢, &found, (ftnlen)32);
etcal_(et, timstr, (ftnlen)35);
s_copy(errmsg, "PCK data required to compute the orientation of "
"the # # for epoch # TDB were not found. If these data we"
"re to be provided by a binary PCK file, then it is possi"
"ble that the PCK file does not have coverage for the spe"
"cified body-fixed frame at the time of interest. If the "
"data were to be provided by a text PCK file, then possib"
"ly the file does not contain data for the specified body"
"-fixed frame. In either case it is possible that a requi"
"red PCK file was not loaded at all.", (ftnlen)1840, (
ftnlen)475);
/* Fill in the variable data in the error message. */
if (found) {
/* The frame system knows the name of the body-fixed frame. */
setmsg_(errmsg, (ftnlen)1840);
errch_("#", "body-fixed frame", (ftnlen)1, (ftnlen)16);
errch_("#", fixfrm, (ftnlen)1, (ftnlen)32);
errch_("#", timstr, (ftnlen)1, (ftnlen)35);
} else {
/* The frame system doesn't know the name of the */
/* body-fixed frame, most likely due to a missing */
/* frame kernel. */
suffix_("#", &c__1, errmsg, (ftnlen)1, (ftnlen)1840);
setmsg_(errmsg, (ftnlen)1840);
errch_("#", "body-fixed frame associated with the ID code", (
ftnlen)1, (ftnlen)44);
errint_("#", body, (ftnlen)1);
errch_("#", timstr, (ftnlen)1, (ftnlen)35);
errch_("#", "Also, a frame kernel defining the body-fixed fr"
"ame associated with body # may need to be loaded.", (
ftnlen)1, (ftnlen)96);
errint_("#", body, (ftnlen)1);
}
sigerr_("SPICE(FRAMEDATANOTFOUND)", (ftnlen)24);
chkout_("BODMAT", (ftnlen)6);
return 0;
}
/* Find the body code used to label the reference frame and epoch */
/* specifiers for the orientation constants for BODY. */
/* For planetary systems, the reference frame and epoch for the */
/* orientation constants is associated with the system */
/* barycenter, not with individual bodies in the system. For any */
/* other bodies, (the Sun or asteroids, for example) the body's */
/* own code is used as the label. */
refid = zzbodbry_(body);
/* Look up the epoch of the constants. The epoch is specified */
/* as a Julian ephemeris date. The epoch defaults to J2000. */
s_copy(item, "BODY#_CONSTANTS_JED_EPOCH", (ftnlen)32, (ftnlen)25);
repmi_(item, "#", &refid, item, (ftnlen)32, (ftnlen)1, (ftnlen)32);
gdpool_(item, &c__1, &c__1, &dim, &conepc, &found, (ftnlen)32);
if (found) {
/* The reference epoch is returned as a JED. Convert to */
/* ephemeris seconds past J2000. Then convert the input ET to */
/* seconds past the reference epoch. */
conepc = spd_() * (conepc - j2000_());
epoch = *et - conepc;
} else {
epoch = *et;
}
/* Look up the reference frame of the constants. The reference */
/* frame is specified by a code recognized by CHGIRF. The */
/* default frame is J2000, symbolized by the code J2CODE. */
s_copy(item, "BODY#_CONSTANTS_REF_FRAME", (ftnlen)32, (ftnlen)25);
repmi_(item, "#", &refid, item, (ftnlen)32, (ftnlen)1, (ftnlen)32);
gdpool_(item, &c__1, &c__1, &dim, &conref, &found, (ftnlen)32);
if (found) {
ref = i_dnnt(&conref);
} else {
ref = j2code;
}
/* Whatever the body, it has quadratic time polynomials for */
/* the RA and Dec of the pole, and for the rotation of the */
/* Prime Meridian. */
s_copy(item, "POLE_RA", (ftnlen)32, (ftnlen)7);
cleard_(&c__3, rcoef);
bodvcd_(body, item, &c__3, &na, rcoef, (ftnlen)32);
s_copy(item, "POLE_DEC", (ftnlen)32, (ftnlen)8);
cleard_(&c__3, dcoef);
bodvcd_(body, item, &c__3, &nd, dcoef, (ftnlen)32);
s_copy(item, "PM", (ftnlen)32, (ftnlen)2);
cleard_(&c__3, wcoef);
bodvcd_(body, item, &c__3, &nw, wcoef, (ftnlen)32);
/* There may be additional nutation and libration (THETA) terms. */
ntheta = 0;
na = 0;
nd = 0;
nw = 0;
s_copy(item, "NUT_PREC_ANGLES", (ftnlen)32, (ftnlen)15);
if (bodfnd_(&refid, item, (ftnlen)32)) {
bodvcd_(&refid, item, &c__100, &ntheta, tcoef, (ftnlen)32);
ntheta /= 2;
}
s_copy(item, "NUT_PREC_RA", (ftnlen)32, (ftnlen)11);
if (bodfnd_(body, item, (ftnlen)32)) {
bodvcd_(body, item, &c__100, &na, ac, (ftnlen)32);
}
s_copy(item, "NUT_PREC_DEC", (ftnlen)32, (ftnlen)12);
if (bodfnd_(body, item, (ftnlen)32)) {
bodvcd_(body, item, &c__100, &nd, dc, (ftnlen)32);
}
s_copy(item, "NUT_PREC_PM", (ftnlen)32, (ftnlen)11);
if (bodfnd_(body, item, (ftnlen)32)) {
bodvcd_(body, item, &c__100, &nw, wc, (ftnlen)32);
}
/* Computing MAX */
i__1 = max(na,nd);
if (max(i__1,nw) > ntheta) {
setmsg_("Insufficient number of nutation/precession angles for b"
"ody * at time #.", (ftnlen)71);
errint_("*", body, (ftnlen)1);
errdp_("#", et, (ftnlen)1);
sigerr_("SPICE(KERNELVARNOTFOUND)", (ftnlen)24);
chkout_("BODMAT", (ftnlen)6);
return 0;
}
/* Evaluate the time polynomials at EPOCH. */
d__ = epoch / spd_();
t = d__ / 36525.;
ra = rcoef[0] + t * (rcoef[1] + t * rcoef[2]);
dec = dcoef[0] + t * (dcoef[1] + t * dcoef[2]);
w = wcoef[0] + d__ * (wcoef[1] + d__ * wcoef[2]);
/* Add nutation and libration as appropriate. */
i__1 = ntheta;
for (i__ = 1; i__ <= i__1; ++i__) {
theta = (tcoef[(i__2 = (i__ << 1) - 2) < 200 && 0 <= i__2 ? i__2 :
s_rnge("tcoef", i__2, "bodmat_", (ftnlen)700)] + t *
tcoef[(i__3 = (i__ << 1) - 1) < 200 && 0 <= i__3 ? i__3 :
s_rnge("tcoef", i__3, "bodmat_", (ftnlen)700)]) * rpd_();
sinth[(i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 : s_rnge("sinth",
i__2, "bodmat_", (ftnlen)702)] = sin(theta);
costh[(i__2 = i__ - 1) < 100 && 0 <= i__2 ? i__2 : s_rnge("costh",
i__2, "bodmat_", (ftnlen)703)] = cos(theta);
}
ra += vdotg_(ac, sinth, &na);
dec += vdotg_(dc, costh, &nd);
w += vdotg_(wc, sinth, &nw);
/* Convert from degrees to radians and mod by two pi. */
ra *= rpd_();
dec *= rpd_();
w *= rpd_();
d__1 = twopi_();
ra = d_mod(&ra, &d__1);
d__1 = twopi_();
dec = d_mod(&dec, &d__1);
d__1 = twopi_();
w = d_mod(&w, &d__1);
/* Convert to Euler angles. */
phi = ra + halfpi_();
delta = halfpi_() - dec;
/* Produce the rotation matrix defined by the Euler angles. */
eul2m_(&w, &delta, &phi, &c__3, &c__1, &c__3, tipm);
}
/* Convert TIPM to the J2000-to-bodyfixed rotation, if is is not */
/* already referenced to J2000. */
if (ref != j2code) {
/* Find the transformation from the J2000 frame to the frame */
/* designated by REF. Form the transformation from `REF' */
/* coordinates to body-fixed coordinates. Compose the */
/* transformations to obtain the J2000-to-body-fixed */
/* transformation. */
irfrot_(&j2code, &ref, j2ref);
mxm_(tipm, j2ref, tmpmat);
moved_(tmpmat, &c__9, tipm);
}
/* TIPM now gives the transformation from J2000 to */
/* body-fixed coordinates at epoch ET seconds past J2000, */
/* regardless of the epoch and frame of the orientation constants */
/* for the specified body. */
chkout_("BODMAT", (ftnlen)6);
return 0;
} /* bodmat_ */
/* $Procedure M2EUL ( Matrix to Euler angles ) */
/* Subroutine */ int m2eul_(doublereal *r__, integer *axis3, integer *axis2,
integer *axis1, doublereal *angle3, doublereal *angle2, doublereal *
angle1)
{
/* Initialized data */
static integer next[3] = { 2,3,1 };
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer);
double acos(doublereal), atan2(doublereal, doublereal), asin(doublereal);
/* Local variables */
doublereal sign;
extern /* Subroutine */ int vhat_(doublereal *, doublereal *), mtxm_(
doublereal *, doublereal *, doublereal *);
integer c__, i__;
logical degen;
extern /* Subroutine */ int chkin_(char *, ftnlen);
extern logical isrot_(doublereal *, doublereal *, doublereal *);
doublereal change[9] /* was [3][3] */;
extern /* Subroutine */ int cleard_(integer *, doublereal *), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen);
doublereal tmpmat[9] /* was [3][3] */;
extern /* Subroutine */ int setmsg_(char *, ftnlen), errint_(char *,
integer *, ftnlen);
extern logical return_(void);
doublereal tmprot[9] /* was [3][3] */;
extern /* Subroutine */ int mxm_(doublereal *, doublereal *, doublereal *)
;
/* $ Abstract */
/* Factor a rotation matrix as a product of three rotations about */
/* specified coordinate axes. */
/* $ 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 */
/* ROTATION */
/* $ Keywords */
/* ANGLE */
/* MATRIX */
/* ROTATION */
/* TRANSFORMATION */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* R I A rotation matrix to be factored. */
/* AXIS3, */
/* AXIS2, */
/* AXIS1 I Numbers of third, second, and first rotation axes. */
/* ANGLE3, */
/* ANGLE2, */
/* ANGLE1 O Third, second, and first Euler angles, in radians. */
/* $ Detailed_Input */
/* R is a 3x3 rotation matrix that is to be factored as */
/* a product of three rotations about a specified */
/* coordinate axes. The angles of these rotations are */
/* called `Euler angles'. */
/* AXIS3, */
/* AXIS2, */
/* AXIS1 are the indices of the rotation axes of the */
/* `factor' rotations, whose product is R. R is */
/* factored as */
/* R = [ ANGLE3 ] [ ANGLE2 ] [ ANGLE1 ] . */
/* AXIS3 AXIS2 AXIS1 */
/* The axis numbers must belong to the set {1, 2, 3}. */
/* The second axis number MUST differ from the first */
/* and third axis numbers. */
/* See the $ Particulars section below for details */
/* concerning this notation. */
/* $ Detailed_Output */
/* ANGLE3, */
/* ANGLE2, */
/* ANGLE1 are the Euler angles corresponding to the matrix */
/* R and the axes specified by AXIS3, AXIS2, and */
/* AXIS1. These angles satisfy the equality */
/* R = [ ANGLE3 ] [ ANGLE2 ] [ ANGLE1 ] */
/* AXIS3 AXIS2 AXIS1 */
/* See the $ Particulars section below for details */
/* concerning this notation. */
/* The range of ANGLE3 and ANGLE1 is (-pi, pi]. */
/* The range of ANGLE2 depends on the exact set of */
/* axes used for the factorization. For */
/* factorizations in which the first and third axes */
/* are the same, */
/* R = [r] [s] [t] , */
/* a b a */
/* the range of ANGLE2 is [0, pi]. */
/* For factorizations in which the first and third */
/* axes are different, */
/* R = [r] [s] [t] , */
/* a b c */
/* the range of ANGLE2 is [-pi/2, pi/2]. */
/* For rotations such that ANGLE3 and ANGLE1 are not */
/* uniquely determined, ANGLE3 will always be set to */
/* zero; ANGLE1 is then uniquely determined. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If any of AXIS3, AXIS2, or AXIS1 do not have values in */
/* { 1, 2, 3 }, */
/* then the error SPICE(BADAXISNUMBERS) is signaled. */
/* 2) An arbitrary rotation matrix cannot be expressed using */
/* a sequence of Euler angles unless the second rotation axis */
/* differs from the other two. If AXIS2 is equal to AXIS3 or */
/* AXIS1, then then error SPICE(BADAXISNUMBERS) is signaled. */
/* 3) If the input matrix R is not a rotation matrix, the error */
/* SPICE(NOTAROTATION) is signaled. */
/* 4) If ANGLE3 and ANGLE1 are not uniquely determined, ANGLE3 */
/* is set to zero, and ANGLE1 is determined. */
/* $ Files */
/* None. */
/* $ Particulars */
/* A word about notation: the symbol */
/* [ x ] */
/* i */
/* indicates a coordinate system rotation of x radians about the */
/* ith coordinate axis. To be specific, the symbol */
/* [ x ] */
/* 1 */
/* indicates a coordinate system rotation of x radians about the */
/* first, or x-, axis; the corresponding matrix is */
/* +- -+ */
/* | 1 0 0 | */
/* | | */
/* | 0 cos(x) sin(x) |. */
/* | | */
/* | 0 -sin(x) cos(x) | */
/* +- -+ */
/* Remember, this is a COORDINATE SYSTEM rotation by x radians; this */
/* matrix, when applied to a vector, rotates the vector by -x */
/* radians, not x radians. Applying the matrix to a vector yields */
/* the vector's representation relative to the rotated coordinate */
/* system. */
/* The analogous rotation about the second, or y-, axis is */
/* represented by */
/* [ x ] */
/* 2 */
/* which symbolizes the matrix */
/* +- -+ */
/* | cos(x) 0 -sin(x) | */
/* | | */
/* | 0 1 0 |, */
/* | | */
/* | sin(x) 0 cos(x) | */
/* +- -+ */
/* and the analogous rotation about the third, or z-, axis is */
/* represented by */
/* [ x ] */
/* 3 */
/* which symbolizes the matrix */
/* +- -+ */
/* | cos(x) sin(x) 0 | */
/* | | */
/* | -sin(x) cos(x) 0 |. */
/* | | */
/* | 0 0 1 | */
/* +- -+ */
/* The input matrix is assumed to be the product of three */
/* rotation matrices, each one of the form */
/* +- -+ */
/* | 1 0 0 | */
/* | | */
/* | 0 cos(r) sin(r) | (rotation of r radians about the */
/* | | x-axis), */
/* | 0 -sin(r) cos(r) | */
/* +- -+ */
/* +- -+ */
/* | cos(s) 0 -sin(s) | */
/* | | */
/* | 0 1 0 | (rotation of s radians about the */
/* | | y-axis), */
/* | sin(s) 0 cos(s) | */
/* +- -+ */
/* or */
/* +- -+ */
/* | cos(t) sin(t) 0 | */
/* | | */
/* | -sin(t) cos(t) 0 | (rotation of t radians about the */
/* | | z-axis), */
/* | 0 0 1 | */
/* +- -+ */
/* where the second rotation axis is not equal to the first or */
/* third. Any rotation matrix can be factored as a sequence of */
/* three such rotations, provided that this last criterion is met. */
/* This routine is related to the SPICELIB routine EUL2M, which */
/* produces a rotation matrix, given a sequence of Euler angles. */
/* This routine is a `right inverse' of EUL2M: the sequence of */
/* calls */
/* CALL M2EUL ( R, AXIS3, AXIS2, AXIS1, */
/* . ANGLE3, ANGLE2, ANGLE1 ) */
/* CALL EUL2M ( ANGLE3, ANGLE2, ANGLE1, */
/* . AXIS3, AXIS2, AXIS1, R ) */
/* preserves R, except for round-off error. */
/* On the other hand, the sequence of calls */
/* CALL EUL2M ( ANGLE3, ANGLE2, ANGLE1, */
/* . AXIS3, AXIS2, AXIS1, R ) */
/* CALL M2EUL ( R, AXIS3, AXIS2, AXIS1, */
/* . ANGLE3, ANGLE2, ANGLE1 ) */
/* preserve ANGLE3, ANGLE2, and ANGLE1 only if these angles start */
/* out in the ranges that M2EUL's outputs are restricted to. */
/* $ Examples */
/* 1) Conversion of instrument pointing from a matrix representation */
/* to Euler angles: */
/* Suppose we want to find camera pointing in alpha, delta, and */
/* kappa, given the inertial-to-camera coordinate transformation */
/* +- -+ */
/* | 0.49127379678135830 0.50872620321864170 0.70699908539882417 | */
/* | | */
/* | -0.50872620321864193 -0.49127379678135802 0.70699908539882428 | */
/* | | */
/* | 0.70699908539882406 -0.70699908539882439 0.01745240643728360 | */
/* +- -+ */
/* We want to find angles alpha, delta, kappa such that */
/* TICAM = [ kappa ] [ pi/2 - delta ] [ pi/2 + alpha ] . */
/* 3 1 3 */
/* We can use the following small program to do this computation: */
/* PROGRAM EX1 */
/* IMPLICIT NONE */
/* DOUBLE PRECISION DPR */
/* DOUBLE PRECISION HALFPI */
/* DOUBLE PRECISION TWOPI */
/* DOUBLE PRECISION ALPHA */
/* DOUBLE PRECISION ANG1 */
/* DOUBLE PRECISION ANG2 */
/* DOUBLE PRECISION DELTA */
/* DOUBLE PRECISION KAPPA */
/* DOUBLE PRECISION TICAM ( 3, 3 ) */
/* DATA TICAM / 0.49127379678135830D0, */
/* . -0.50872620321864193D0, */
/* . 0.70699908539882406D0, */
/* . 0.50872620321864170D0, */
/* . -0.49127379678135802D0, */
/* . -0.70699908539882439D0, */
/* . 0.70699908539882417D0, */
/* . 0.70699908539882428D0, */
/* . 0.01745240643728360D0 / */
/* CALL M2EUL ( TICAM, 3, 1, 3, KAPPA, ANG2, ANG1 ) */
/* DELTA = HALFPI() - ANG2 */
/* ALPHA = ANG1 - HALFPI() */
/* IF ( KAPPA .LT. 0.D0 ) THEN */
/* KAPPA = KAPPA + TWOPI() */
/* END IF */
/* IF ( ALPHA .LT. 0.D0 ) THEN */
/* ALPHA = ALPHA + TWOPI() */
/* END IF */
/* WRITE (*,'(1X,A,F24.14)') 'Alpha (deg): ', DPR() * ALPHA */
/* WRITE (*,'(1X,A,F24.14)') 'Delta (deg): ', DPR() * DELTA */
/* WRITE (*,'(1X,A,F24.14)') 'Kappa (deg): ', DPR() * KAPPA */
/* END */
/* The program's output should be something like */
/* Alpha (deg): 315.00000000000000 */
/* Delta (deg): 1.00000000000000 */
/* Kappa (deg): 45.00000000000000 */
/* possibly formatted a little differently, or degraded slightly */
/* by round-off. */
/* 2) Conversion of instrument pointing angles from a non-J2000, */
/* not necessarily inertial frame to J2000-relative RA, Dec, */
/* and Twist. */
/* Suppose that we have pointing for some instrument expressed as */
/* [ gamma ] [ beta ] [ alpha ] */
/* 3 2 3 */
/* with respect to some coordinate system S. For example, S */
/* could be a spacecraft-fixed system. */
/* We will suppose that the transformation from J2000 */
/* coordinates to system S coordinates is given by the rotation */
/* matrix J2S. */
/* The rows of J2S are the unit basis vectors of system S, given */
/* in J2000 coordinates. */
/* We want to express the pointing with respect to the J2000 */
/* system as the sequence of rotations */
/* [ kappa ] [ pi/2 - delta ] [ pi/2 + alpha ] . */
/* 3 1 3 */
/* First, we use subroutine EUL2M to form the transformation */
/* from system S to instrument coordinates S2INST. */
/* CALL EUL2M ( GAMMA, BETA, ALPHA, 3, 2, 3, S2INST ) */
/* Next, we form the transformation from J2000 to instrument */
/* coordinates J2INST. */
/* CALL MXM ( S2INST, J2S, J2INST ) */
/* Finally, we express J2INST using the desired Euler angles, as */
/* in the first example: */
/* CALL M2EUL ( J2INST, 3, 1, 3, TWIST, ANG2, ANG3 ) */
/* RA = ANG3 - HALFPI() */
/* DEC = HALFPI() - ANG2 */
/* If we wish to make sure that RA, DEC, and TWIST are in */
/* the ranges [0, 2pi), [-pi/2, pi/2], and [0, 2pi) */
/* respectively, we may add the code */
/* IF ( RA .LT. 0.D0 ) THEN */
/* RA = RA + TWOPI() */
/* END IF */
/* IF ( TWIST .LT. 0.D0 ) THEN */
/* TWIST = TWIST + TWOPI() */
/* END IF */
/* Note that DEC is already in the correct range, since ANG2 */
/* is in the range [0, pi] when the first and third input axes */
/* are equal. */
/* Now RA, DEC, and TWIST express the instrument pointing */
/* as RA, Dec, and Twist, relative to the J2000 system. */
/* A warning note: more than one definition of RA, Dec, and */
/* Twist is extant. Before using this example in an application, */
/* check that the definition given here is consistent with that */
/* used in your application. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.1, 21-DEC-2006 (NJB) */
/* Error corrected in header example: input matrix */
/* previously did not match shown outputs. Offending */
/* example now includes complete program. */
/* - SPICELIB Version 1.2.0, 15-OCT-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM and MTXM calls. A short error message cited in */
/* the Exceptions section of the header failed to match */
/* the actual short message used; this has been corrected. */
/* - SPICELIB Version 1.1.2, 13-OCT-2004 (NJB) */
/* Fixed header typo. */
/* - SPICELIB Version 1.1.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.1.0, 02-NOV-1990 (NJB) */
/* Header upgraded to describe notation in more detail. Argument */
/* names were changed to describe the use of the arguments more */
/* accurately. No change in functionality was made; the operation */
/* of the routine is identical to that of the previous version. */
/* - SPICELIB Version 1.0.0, 03-SEP-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* matrix to euler angles */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 26-AUG-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM and MTXM calls. A short error message cited in */
/* the Exceptions section of the header failed to match */
/* the actual short message used; this has been corrected. */
/* - SPICELIB Version 1.1.0, 02-NOV-1990 (NJB) */
/* Argument names were changed to describe the use of the */
/* arguments more accurately. The axis and angle numbers */
/* now decrease, rather than increase, from left to right. */
/* The current names reflect the order of operator application */
/* when the Euler angle rotations are applied to a vector: the */
/* rightmost matrix */
/* [ ANGLE1 ] */
/* AXIS1 */
/* is applied to the vector first, followed by */
/* [ ANGLE2 ] */
/* AXIS2 */
/* and then */
/* [ ANGLE3 ] */
/* AXIS3 */
/* Previously, the names reflected the order in which the Euler */
/* angle matrices appear on the page, from left to right. This */
/* naming convention was found to be a bit obtuse by a various */
/* users. */
/* No change in functionality was made; the operation of the */
/* routine is identical to that of the previous version. */
/* Also, the header was upgraded to describe the notation in more */
/* detail. The symbol */
/* [ x ] */
/* i */
/* is explained at mind-numbing length. An example was added */
/* that shows a specific set of inputs and the resulting output */
/* matrix. */
/* The angle sequence notation was changed to be consistent with */
/* Rotations required reading. */
/* 1-2-3 and a-b-c */
/* have been changed to */
/* 3-2-1 and c-b-a. */
/* Also, one `)' was changed to a `}'. */
/* The phrase `first and third' was changed to `first or third' */
/* in the $ Particulars section, where the criterion for the */
/* existence of an Euler angle factorization is stated. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* NTOL and DETOL are used to determine whether R is a rotation */
/* matrix. */
/* NTOL is the tolerance for the norms of the columns of R. */
/* DTOL is the tolerance for the determinant of a matrix whose */
/* columns are the unitized columns of R. */
/* Local variables */
/* Saved variables */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("M2EUL", (ftnlen)5);
}
/* The first order of business is to screen out the goofy cases. */
/* Make sure the axis numbers are all right: They must belong to */
/* the set {1, 2, 3}... */
if (*axis3 < 1 || *axis3 > 3 || (*axis2 < 1 || *axis2 > 3) || (*axis1 < 1
|| *axis1 > 3)) {
setmsg_("Axis numbers are #, #, #. ", (ftnlen)28);
errint_("#", axis3, (ftnlen)1);
errint_("#", axis2, (ftnlen)1);
errint_("#", axis1, (ftnlen)1);
sigerr_("SPICE(BADAXISNUMBERS)", (ftnlen)21);
chkout_("M2EUL", (ftnlen)5);
return 0;
/* ...and the second axis number must differ from its neighbors. */
} else if (*axis3 == *axis2 || *axis1 == *axis2) {
setmsg_("Middle axis matches neighbor: # # #.", (ftnlen)36);
errint_("#", axis3, (ftnlen)1);
errint_("#", axis2, (ftnlen)1);
errint_("#", axis1, (ftnlen)1);
sigerr_("SPICE(BADAXISNUMBERS)", (ftnlen)21);
chkout_("M2EUL", (ftnlen)5);
return 0;
/* R must be a rotation matrix, or we may as well forget it. */
} else if (! isrot_(r__, &c_b15, &c_b15)) {
setmsg_("Input matrix is not a rotation.", (ftnlen)31);
sigerr_("SPICE(NOTAROTATION)", (ftnlen)19);
chkout_("M2EUL", (ftnlen)5);
return 0;
}
/* AXIS3, AXIS2, AXIS1 and R have passed their tests at this */
/* point. We take the liberty of working with TMPROT, a version */
/* of R that has unitized columns. */
for (i__ = 1; i__ <= 3; ++i__) {
vhat_(&r__[(i__1 = i__ * 3 - 3) < 9 && 0 <= i__1 ? i__1 : s_rnge(
"r", i__1, "m2eul_", (ftnlen)667)], &tmprot[(i__2 = i__ * 3 -
3) < 9 && 0 <= i__2 ? i__2 : s_rnge("tmprot", i__2, "m2eul_",
(ftnlen)667)]);
}
/* We now proceed to recover the promised Euler angles from */
/* TMPROT. */
/* The ideas behind our method are explained in excruciating */
/* detail in the ROTATION required reading, so we'll be terse. */
/* Nonetheless, a word of explanation is in order. */
/* The sequence of rotation axes used for the factorization */
/* belongs to one of two categories: a-b-a or c-b-a. We */
/* wish to handle each of these cases in one shot, rather than */
/* using different formulas for each sequence to recover the */
/* Euler angles. */
/* What we're going to do is use the Euler angle formula for the */
/* 3-1-3 factorization for all of the a-b-a sequences, and the */
/* formula for the 3-2-1 factorization for all of the c-b-a */
/* sequences. */
/* How can we get away with this? The Euler angle formulas for */
/* each factorization are different! */
/* Our trick is to apply a change-of-basis transformation to the */
/* input matrix R. For the a-b-a factorizations, we choose a new */
/* basis such that a rotation of ANGLE3 radians about the basis */
/* vector indexed by AXIS3 becomes a rotation of ANGLE3 radians */
/* about the third coordinate axis, and such that a rotation of */
/* ANGLE2 radians about the basis vector indexed by AXIS2 becomes */
/* a rotation of ANGLE2 radians about the first coordinate axis. */
/* So R can be factored as a 3-1-3 rotation relative to the new */
/* basis, and the Euler angles we obtain are the exact ones we */
/* require. */
/* The c-b-a factorizations can be handled in an analogous */
/* fashion. We transform R to a basis where the original axis */
/* sequence becomes a 3-2-1 sequence. In some cases, the angles */
/* we obtain will be the negatives of the angles we require. This */
/* will happen if and only if the ordered basis (here the e's are */
/* the standard basis vectors) */
/* { e e e } */
/* AXIS3 AXIS2 AXIS1 */
/* is not right-handed. An easy test for this condition is that */
/* AXIS2 is not the successor of AXIS3, where the ordering is */
/* cyclic. */
if (*axis3 == *axis1) {
/* The axis order is a-b-a. We're going to find a matrix CHANGE */
/* such that */
/* T */
/* CHANGE R CHANGE */
/* gives us R in the a useful basis, that is, a basis in which */
/* our original a-b-a rotation is a 3-1-3 rotation, but where the */
/* rotation angles are unchanged. To achieve this pleasant */
/* simplification, we set column 3 of CHANGE to to e(AXIS3), */
/* column 1 of CHANGE to e(AXIS2), and column 2 of CHANGE to */
/* (+/-) e(C), */
/* (C is the remaining index) depending on whether */
/* AXIS3-AXIS2-C is a right-handed sequence of axes: if it */
/* is, the sign is positive. (Here e(1), e(2), e(3) are the */
/* standard basis vectors.) */
/* Determine the sign of our third basis vector, so that we can */
/* ensure that our new basis is right-handed. The variable NEXT */
/* is just a little mapping that takes 1 to 2, 2 to 3, and 3 to */
/* 1. */
if (*axis2 == next[(i__1 = *axis3 - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("next", i__1, "m2eul_", (ftnlen)746)]) {
sign = 1.;
} else {
sign = -1.;
}
/* Since the axis indices sum to 6, */
c__ = 6 - *axis3 - *axis2;
/* Set up the entries of CHANGE: */
cleard_(&c__9, change);
change[(i__1 = *axis3 + 5) < 9 && 0 <= i__1 ? i__1 : s_rnge("change",
i__1, "m2eul_", (ftnlen)762)] = 1.;
change[(i__1 = *axis2 - 1) < 9 && 0 <= i__1 ? i__1 : s_rnge("change",
i__1, "m2eul_", (ftnlen)763)] = 1.;
change[(i__1 = c__ + 2) < 9 && 0 <= i__1 ? i__1 : s_rnge("change",
i__1, "m2eul_", (ftnlen)764)] = sign * 1.;
/* Transform TMPROT. */
mxm_(tmprot, change, tmpmat);
mtxm_(change, tmpmat, tmprot);
/* Now we're ready to find the Euler angles, using a */
/* 3-1-3 factorization. In general, the matrix product */
/* [ a1 ] [ a2 ] [ a3 ] */
/* 3 1 3 */
/* has the form */
/* +- -+ */
/* | cos(a1)cos(a3) cos(a1)sin(a3) sin(a1)sin(a2) | */
/* | -sin(a1)cos(a2)sin(a3) +sin(a1)cos(a2)cos(a3) | */
/* | | */
/* | -sin(a1)cos(a3) -sin(a1)sin(a3) cos(a1)sin(a2) | */
/* | -cos(a1)cos(a2)sin(a3) +cos(a1)cos(a2)cos(a3) | */
/* | | */
/* | sin(a2)sin(a3) -sin(a2)cos(a3) cos(a2) | */
/* +- -+ */
/* but if a2 is 0 or pi, the product matrix reduces to */
/* +- -+ */
/* | cos(a1)cos(a3) cos(a1)sin(a3) 0 | */
/* | -sin(a1)cos(a2)sin(a3) +sin(a1)cos(a2)cos(a3) | */
/* | | */
/* | -sin(a1)cos(a3) -sin(a1)sin(a3) 0 | */
/* | -cos(a1)cos(a2)sin(a3) +cos(a1)cos(a2)cos(a3) | */
/* | | */
/* | 0 0 cos(a2) | */
/* +- -+ */
/* In this case, a1 and a3 are not uniquely determined. If we */
/* arbitrarily set a1 to zero, we arrive at the matrix */
/* +- -+ */
/* | cos(a3) sin(a3) 0 | */
/* | -cos(a2)sin(a3) cos(a2)cos(a3) 0 | */
/* | 0 0 cos(a2) | */
/* +- -+ */
/* We take care of this case first. We test three conditions */
/* that are mathematically equivalent, but may not be satisfied */
/* simultaneously because of round-off: */
degen = tmprot[6] == 0. && tmprot[7] == 0. || tmprot[2] == 0. &&
tmprot[5] == 0. || abs(tmprot[8]) == 1.;
/* In the following block of code, we make use of the fact that */
/* SIN ( ANGLE2 ) > 0 */
/* - */
/* in choosing the signs of the ATAN2 arguments correctly. Note */
/* that ATAN2(x,y) = -ATAN2(-x,-y). */
if (degen) {
*angle3 = 0.;
*angle2 = acos(tmprot[8]);
*angle1 = atan2(tmprot[3], tmprot[0]);
} else {
/* The normal case. */
*angle3 = atan2(tmprot[6], tmprot[7]);
*angle2 = acos(tmprot[8]);
*angle1 = atan2(tmprot[2], -tmprot[5]);
}
} else {
/* The axis order is c-b-a. We're going to find a matrix CHANGE */
/* such that */
/* T */
/* CHANGE R CHANGE */
/* gives us R in the a useful basis, that is, a basis in which */
/* our original c-b-a rotation is a 3-2-1 rotation, but where the */
/* rotation angles are unchanged, or at worst negated. To */
/* achieve this pleasant simplification, we set column 1 of */
/* CHANGE to to e(AXIS3), column 2 of CHANGE to e(AXIS2), and */
/* column 3 of CHANGE to */
/* (+/-) e(AXIS1), */
/* depending on whether AXIS3-AXIS2-AXIS1 is a right-handed */
/* sequence of axes: if it is, the sign is positive. (Here */
/* e(1), e(2), e(3) are the standard basis vectors.) */
/* We must be cautious here, because if AXIS3-AXIS2-AXIS1 is a */
/* right-handed sequence of axes, all of the rotation angles will */
/* be the same in our new basis, but if it's a left-handed */
/* sequence, the third angle will be negated. Let's get this */
/* straightened out right now. The variable NEXT is just a */
/* little mapping that takes 1 to 2, 2 to 3, and 3 to 1. */
if (*axis2 == next[(i__1 = *axis3 - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("next", i__1, "m2eul_", (ftnlen)883)]) {
sign = 1.;
} else {
sign = -1.;
}
/* Set up the entries of CHANGE: */
cleard_(&c__9, change);
change[(i__1 = *axis3 - 1) < 9 && 0 <= i__1 ? i__1 : s_rnge("change",
i__1, "m2eul_", (ftnlen)894)] = 1.;
change[(i__1 = *axis2 + 2) < 9 && 0 <= i__1 ? i__1 : s_rnge("change",
i__1, "m2eul_", (ftnlen)895)] = 1.;
change[(i__1 = *axis1 + 5) < 9 && 0 <= i__1 ? i__1 : s_rnge("change",
i__1, "m2eul_", (ftnlen)896)] = sign * 1.;
/* Transform TMPROT. */
mxm_(tmprot, change, tmpmat);
mtxm_(change, tmpmat, tmprot);
/* Now we're ready to find the Euler angles, using a */
/* 3-2-1 factorization. In general, the matrix product */
/* [ a1 ] [ a2 ] [ a3 ] */
/* 1 2 3 */
/* has the form */
/* +- -+ */
/* | cos(a2)cos(a3) cos(a2)sin(a3) -sin(a2) | */
/* | | */
/* | -cos(a1)sin(a3) cos(a1)cos(a3) sin(a1)cos(a2) | */
/* | +sin(a1)sin(a2)cos(a3) +sin(a1)sin(a2)sin(a3) | */
/* | | */
/* | sin(a1)sin(a3) -sin(a1)cos(a3) cos(a1)cos(a2) | */
/* | +cos(a1)sin(a2)cos(a3) +cos(a1)sin(a2)sin(a3) | */
/* +- -+ */
/* but if a2 is -pi/2 or pi/2, the product matrix reduces to */
/* +- -+ */
/* | 0 0 -sin(a2) | */
/* | | */
/* | -cos(a1)sin(a3) cos(a1)cos(a3) 0 | */
/* | +sin(a1)sin(a2)cos(a3) +sin(a1)sin(a2)sin(a3) | */
/* | | */
/* | sin(a1)sin(a3) -sin(a1)cos(a3) 0 | */
/* | +cos(a1)sin(a2)cos(a3) +cos(a1)sin(a2)sin(a3) | */
/* +- -+ */
/* In this case, a1 and a3 are not uniquely determined. If we */
/* arbitrarily set a1 to zero, we arrive at the matrix */
/* +- -+ */
/* | 0 0 -sin(a2) | */
/* | -sin(a3) cos(a3) 0 |, */
/* | sin(a2)cos(a3) sin(a2)sin(a3) 0 | */
/* +- -+ */
/* We take care of this case first. We test three conditions */
/* that are mathematically equivalent, but may not be satisfied */
/* simultaneously because of round-off: */
degen = tmprot[0] == 0. && tmprot[3] == 0. || tmprot[7] == 0. &&
tmprot[8] == 0. || abs(tmprot[6]) == 1.;
/* In the following block of code, we make use of the fact that */
/* COS ( ANGLE2 ) > 0 */
/* - */
/* in choosing the signs of the ATAN2 arguments correctly. Note */
/* that ATAN2(x,y) = -ATAN2(-x,-y). */
if (degen) {
*angle3 = 0.;
*angle2 = asin(-tmprot[6]);
*angle1 = sign * atan2(-tmprot[1], tmprot[4]);
} else {
/* The normal case. */
*angle3 = atan2(tmprot[7], tmprot[8]);
*angle2 = asin(-tmprot[6]);
*angle1 = sign * atan2(tmprot[3], tmprot[0]);
}
}
chkout_("M2EUL", (ftnlen)5);
return 0;
} /* m2eul_ */
/* $Procedure PXFRM2 ( Position Transform Matrix, Different Epochs ) */
/* Subroutine */ int pxfrm2_(char *from, char *to, doublereal *etfrom,
doublereal *etto, doublereal *rotate, ftnlen from_len, ftnlen to_len)
{
/* Initialized data */
static logical first = TRUE_;
static char svto[32];
extern /* Subroutine */ int zznamfrm_(integer *, char *, integer *, char *
, integer *, ftnlen, ftnlen), zzctruin_(integer *);
integer fcode;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer tcode;
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
doublereal jf[9] /* was [3][3] */;
static integer svctr1[2], svctr2[2];
doublereal tj[9] /* was [3][3] */;
extern /* Subroutine */ int refchg_(integer *, integer *, doublereal *,
doublereal *);
static integer svfcod, svtcde;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
static char svfrom[32];
extern logical return_(void);
extern /* Subroutine */ int mxm_(doublereal *, doublereal *, doublereal *)
;
/* $ Abstract */
/* Return the 3x3 matrix that transforms position vectors from one */
/* specified frame at a specified epoch to another specified */
/* frame at another specified epoch. */
/* $ 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 */
/* FRAMES */
/* $ Keywords */
/* FRAMES */
/* TRANSFORM */
/* $ Declarations */
/* $ 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 */
/* -------- --- -------------------------------------------------- */
/* FROM I Name of the frame to transform from. */
/* TO I Name of the frame to transform to. */
/* ETFROM I Evaluation time of 'FROM' frame. */
/* ETTO I Evaluation time of 'TO' frame. */
/* ROTATE O A position transformation matrix from */
/* frame FROM to frame TO. */
/* $ Detailed_Input */
/* FROM is the name of a reference frame recognized by */
/* SPICELIB that corresponds to the input ETFROM. */
/* TO is the name of a reference frame recognized by */
/* SPICELIB that corresponds to the desired output */
/* at ETTO. */
/* ETFROM is the epoch in ephemeris seconds past the epoch */
/* of J2000 (TDB) corresponding to the FROM reference */
/* frame. */
/* ETTO is the epoch in ephemeris seconds past the epoch */
/* of J2000 (TDB) that corresponds to the TO reference */
/* frame. */
/* $ Detailed_Output */
/* ROTATE is the transformation matrix that relates the reference */
/* frame FROM at epoch ETFROM to the frame TO at epoch */
/* ETTO. */
/* If (x, y, z) is a position relative to the reference */
/* frame FROM at time ETFROM then the vector ( x', y', */
/* z') is the same position relative to the frame TO at */
/* epoch ETTO. Here the vector ( x', y', z' ) is defined */
/* by the equation: */
/* - - - - - - */
/* | x' | | | | x | */
/* | y' | = | ROTATE | | y | */
/* | z' | | | | z | */
/* - - - - - - */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If sufficient information has not been supplied via loaded */
/* SPICE kernels to compute the transformation between the */
/* two frames, the error will be diagnosed by a routine */
/* in the call tree to this routine. */
/* 2) If either frame FROM or TO is not recognized the error */
/* 'SPICE(UNKNOWNFRAME)' will be signaled. */
/* $ Files */
/* Appropriate kernels must be loaded by the calling program before */
/* this routine is called. Kernels that may be required include */
/* SPK files, PCK files, frame kernels, C-kernels, and SCLK kernels. */
/* Such kernel data are normally loaded once per program */
/* run, NOT every time this routine is called. */
/* $ Particulars */
/* PXFRM2 is most commonly used to transform a position between */
/* time-dependant reference frames. */
/* For more examples of where to use PXFRM2, please see: */
/* SINCPT */
/* SURFPT */
/* SUBSLR */
/* ILUMIN */
/* $ 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) Suppose that MGS has taken a picture of Mars at time ETREC with */
/* the MOC narrow angle camera. We want to know the latitude and */
/* longitude associated with two pixels projected to Mars' */
/* surface: the boresight and one along the boundary of the */
/* field of view (FOV). Due to light time, the photons taken in */
/* the picture left Mars at time ETEMIT, when Mars was at a */
/* different state than at time ETREC. */
/* In order to solve this problem, we could use the SINCPT */
/* routine for both pixels, but this would be slow. Instead, we */
/* will assume that the light time for each pixel is the same. We */
/* will call SINCPT once to get the light time and surface point */
/* associated with the boresight. Then, we will rotate one of the */
/* FOV boundary vectors from the camera frame at ETREC to the */
/* body-fixed Mars frame at ETEMIT, and call the faster routine */
/* SURFPT to retrieve the surface point for one of the FOV */
/* boundary vectors. */
/* This example problem could be extended to find the latitude */
/* and longitude associated with every pixel in an instrument's */
/* field of view, but this example is simplified to only solve */
/* for two pixels: the boresight and one along the boundary of */
/* the field of view. */
/* Assumptions: */
/* 1) The light times from the surface points in the camera's */
/* field of view to the camera are equal. */
/* 2) The camera offset from the center of gravity of the */
/* spacecraft is zero. If the data are more accurate */
/* and precise, this assumption can be easily discarded. */
/* 3) An ellipsoid shape model for the target body is */
/* sufficient. */
/* 4) The boundary field of view vector returned from GETFOV */
/* is associated with a boundary field of view pixel. If */
/* this example were extended to include a geometric camera */
/* model, this assumption would not be needed since the */
/* direction vectors associated with each pixel would be */
/* calculated from the geometric camera model. */
/* Use the meta-kernel shown below to load the required SPICE */
/* kernels. */
/* KPL/MK */
/* File name: mgs_ex.tm */
/* This is the meta-kernel file for the example problem for */
/* the subroutine PXFRM2. These kernel files can be found in */
/* the NAIF archives. */
/* 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 */
/* --------- -------- */
/* de421.bsp Planetary ephemeris */
/* pck00009.tpc Planet orientation and */
/* radii */
/* naif0009.tls Leapseconds */
/* mgs_ext12_ipng_mgs95j.bsp MGS ephemeris */
/* mgs_moc_v20.ti MGS MOC instrument */
/* parameters */
/* mgs_sclkscet_00061.tsc MGS SCLK coefficients */
/* mgs_sc_ext12.bc MGS s/c bus attitude */
/* \begindata */
/* KERNELS_TO_LOAD = ( 'de421.bsp', */
/* 'pck00009.tpc', */
/* 'naif0009.tls', */
/* 'mgs_ext12_ipng_mgs95j.bsp', */
/* 'mgs_moc_v20.ti', */
/* 'mgs_sclkscet_00061.tsc', */
/* 'mgs_sc_ext12.bc' ) */
/* \begintext */
/* End of meta-kernel. */
/* Example code begins here. */
/* PROGRAM EX_PXFRM2 */
/* IMPLICIT NONE */
/* C */
/* C SPICELIB functions */
/* C */
/* C Degrees per radian */
/* C */
/* DOUBLE PRECISION DPR */
/* C */
/* C Distance between two vectors */
/* C */
/* DOUBLE PRECISION VDIST */
/* C */
/* C Local parameters */
/* C */
/* C ABCORR is the desired light time and stellar */
/* C aberration correction setting. */
/* C */
/* CHARACTER*(*) ABCORR */
/* PARAMETER ( ABCORR = 'CN+S' ) */
/* C */
/* C MGS_MOC_NA is the name of the camera that took */
/* C the picture being analyzed. */
/* C */
/* CHARACTER*(*) CAMERA */
/* PARAMETER ( CAMERA = 'MGS_MOC_NA' ) */
/* CHARACTER*(*) METAKR */
/* PARAMETER ( METAKR = 'mgs_ex.tm' ) */
/* INTEGER FRNMLN */
/* PARAMETER ( FRNMLN = 32 ) */
/* INTEGER NCORNR */
/* PARAMETER ( NCORNR = 4 ) */
/* INTEGER SHPLEN */
/* PARAMETER ( SHPLEN = 80 ) */
/* C */
/* C Local variables */
/* C */
/* C OBSREF is the observer reference frame on MGS. */
/* C */
/* CHARACTER*(FRNMLN) OBSREF */
/* CHARACTER*(SHPLEN) SHAPE */
/* DOUBLE PRECISION BOUNDS ( 3, NCORNR ) */
/* DOUBLE PRECISION BNDVEC ( 3 ) */
/* DOUBLE PRECISION BSIGHT ( 3 ) */
/* C */
/* C ETEMIT is the time at which the photons were */
/* C emitted from Mars. ETREC is the time at */
/* C which the picture was taken by MGS. */
/* C */
/* DOUBLE PRECISION ETREC */
/* DOUBLE PRECISION ETEMIT */
/* DOUBLE PRECISION DIST */
/* C */
/* C LAT and LON are the latitude and longitude */
/* C associated with one of the boundary FOV vectors. */
/* C */
/* DOUBLE PRECISION LAT */
/* DOUBLE PRECISION LON */
/* C */
/* C PMGSMR is the opposite of the apparent position of */
/* C Mars with respect to MGS. */
/* C */
/* DOUBLE PRECISION PMGSMR ( 3 ) */
/* C */
/* C RADII is a vector of the semi-axes of Mars. */
/* C */
/* DOUBLE PRECISION RADII ( 3 ) */
/* DOUBLE PRECISION RADIUS */
/* C */
/* C ROTATE is a position transformation matrix from */
/* C the camera frame at ETREC to the IAU_MARS frame */
/* C at ETEMIT. */
/* C */
/* DOUBLE PRECISION ROTATE ( 3, 3 ) */
/* DOUBLE PRECISION SPOINT ( 3 ) */
/* DOUBLE PRECISION SRFVEC ( 3 ) */
/* DOUBLE PRECISION TMP ( 3 ) */
/* INTEGER CAMID */
/* INTEGER DIM */
/* INTEGER N */
/* LOGICAL FOUND */
/* C */
/* C ------------------ Program Setup ------------------ */
/* C */
/* C Load kernel files via the meta-kernel. */
/* C */
/* CALL FURNSH ( METAKR ) */
/* C */
/* C Convert the time the picture was taken from a */
/* C UTC time string to seconds past J2000, TDB. */
/* C */
/* CALL STR2ET ( '2003 OCT 13 06:00:00 UTC', ETREC ) */
/* C */
/* C Assume the one-way light times from different */
/* C surface points on Mars to MGS within the camera's */
/* C FOV are equal. This means the photons that make */
/* C up different pixels were all emitted from Mars at */
/* C ETEMIT and received by the MGS MOC camera at ETREC. It */
/* C would be slow to process images using SINCPT for every */
/* C pixel. Instead, we will use SINCPT on the */
/* C boresight pixel and use SURFPT for one of the FOV */
/* C boundary pixels. If this example program were extended */
/* C to include all of the camera's pixels, SURFPT would */
/* C be used for the remaining pixels. */
/* C */
/* C Get the MGS MOC Narrow angle camera (MGS_MOC_NA) */
/* C ID code. Then look up the field of view (FOV) */
/* C parameters by calling GETFOV. */
/* C */
/* CALL BODN2C ( CAMERA, CAMID, FOUND ) */
/* IF ( .NOT. FOUND ) THEN */
/* CALL SETMSG ( 'Could not find ID code for ' // */
/* . 'instrument #.' ) */
/* CALL ERRCH ( '#', CAMERA ) */
/* CALL SIGERR ( 'SPICE(NOTRANSLATION)' ) */
/* END IF */
/* C */
/* C GETFOV will return the name of the camera-fixed frame */
/* C in the string OBSREF, the camera boresight vector in */
/* C the array BSIGHT, and the FOV corner vectors in the */
/* C array BOUNDS. */
/* C */
/* CALL GETFOV ( CAMID, NCORNR, SHAPE, OBSREF, */
/* . BSIGHT, N, BOUNDS ) */
/* WRITE (*,*) 'Observation Reference frame: ', OBSREF */
/* C */
/* C ----------- Boresight Surface Intercept ----------- */
/* C */
/* C Retrieve the time, surface intercept point, and vector */
/* C from MGS to the boresight surface intercept point */
/* C in IAU_MARS coordinates. */
/* C */
/* CALL SINCPT ( 'ELLIPSOID', 'MARS', ETREC, 'IAU_MARS', */
/* . ABCORR, 'MGS', OBSREF, BSIGHT, */
/* . SPOINT, ETEMIT, SRFVEC, FOUND ) */
/* IF ( .NOT. FOUND ) THEN */
/* CALL SETMSG ( 'Intercept not found for the ' // */
/* . 'boresight vector.' ) */
/* CALL SIGERR ( 'SPICE(NOINTERCEPT)' ) */
/* END IF */
/* C */
/* C Convert the intersection point of the boresight */
/* C vector and Mars from rectangular into latitudinal */
/* C coordinates. Convert radians to degrees. */
/* C */
/* CALL RECLAT ( SPOINT, RADIUS, LON, LAT ) */
/* LON = LON * DPR () */
/* LAT = LAT * DPR () */
/* WRITE (*,*) 'Boresight surface intercept ' // */
/* . 'coordinates:' */
/* WRITE (*,*) ' Radius (km) : ', RADIUS */
/* WRITE (*,*) ' Latitude (deg): ', LAT */
/* WRITE (*,*) ' Longitude (deg): ', LON */
/* C */
/* C --------- A Boundary FOV Surface Intercept (SURFPT) ------ */
/* C */
/* C Now we will transform one of the FOV corner vectors into the */
/* C IAU_MARS frame so the surface intercept point can be */
/* C calculated using SURFPT, which is faster than SUBPNT. */
/* C */
/* C If this example program were extended to include all */
/* C of the pixels in the camera's FOV, a few steps, such as */
/* C finding the rotation matrix from the camera frame to the */
/* C IAU_MARS frame, looking up the radii values for Mars, */
/* C and finding the position of MGS with respect to Mars could */
/* C be done once and used for every pixel. */
/* C */
/* C Find the rotation matrix from the ray's reference */
/* C frame at the time the photons were received (ETREC) */
/* C to IAU_MARS at the time the photons were emitted */
/* C (ETEMIT). */
/* C */
/* CALL PXFRM2 ( OBSREF, 'IAU_MARS', ETREC, ETEMIT, ROTATE ) */
/* C */
/* C Look up the radii values for Mars. */
/* C */
/* CALL BODVRD ( 'MARS', 'RADII', 3, DIM, RADII ) */
/* C */
/* C Find the position of the center of Mars with respect */
/* C to MGS. The position of the observer with respect */
/* C to Mars is required for the call to SURFPT. Note: */
/* C the apparent position of MGS with respect to Mars is */
/* C not the same as the negative of Mars with respect to MGS. */
/* C */
/* CALL VSUB ( SPOINT, SRFVEC, PMGSMR ) */
/* C */
/* C The selected boundary FOV pixel must be rotated into the */
/* C IAU_MARS reference frame. */
/* C */
/* CALL MXV ( ROTATE, BOUNDS(1,1), BNDVEC ) */
/* C */
/* C Calculate the surface point of the boundary FOV */
/* C vector. */
/* C */
/* CALL SURFPT ( PMGSMR, BNDVEC, RADII(1), RADII(2), */
/* . RADII(3), SPOINT, FOUND ) */
/* IF ( .NOT. FOUND ) THEN */
/* CALL SETMSG ( 'Could not calculate surface point.') */
/* CALL SIGERR ( 'SPICE(NOTFOUND)' ) */
/* END IF */
/* CALL VEQU ( SPOINT, TMP ) */
/* C */
/* C Convert the intersection point of the boundary */
/* C FOV vector and Mars from rectangular into */
/* C latitudinal coordinates. Convert radians */
/* C to degrees. */
/* C */
/* CALL RECLAT ( SPOINT, RADIUS, LON, LAT ) */
/* LON = LON * DPR () */
/* LAT = LAT * DPR () */
/* WRITE (*,*) 'Boundary vector surface intercept ' // */
/* . 'coordinates using SURFPT:' */
/* WRITE (*,*) ' Radius (km) : ', RADIUS */
/* WRITE (*,*) ' Latitude (deg): ', LAT */
/* WRITE (*,*) ' Longitude (deg): ', LON */
/* WRITE (*,*) ' Emit time using' */
/* WRITE (*,*) ' boresight LT(s): ', ETEMIT */
/* C */
/* C ------ A Boundary FOV Surface Intercept Verification ---- */
/* C */
/* C For verification only, we will calculate the surface */
/* C intercept coordinates for the selected boundary vector */
/* C using SINCPT and compare to the faster SURFPT method. */
/* C */
/* CALL SINCPT ( 'ELLIPSOID', 'MARS', ETREC, 'IAU_MARS', */
/* . ABCORR, 'MGS', OBSREF, BOUNDS(1,1), */
/* . SPOINT, ETEMIT, SRFVEC, FOUND ) */
/* IF ( .NOT. FOUND ) THEN */
/* CALL SETMSG ( 'Intercept not found for the ' // */
/* . 'boresight vector.' ) */
/* CALL SIGERR ( 'SPICE(NOINTERCEPT)' ) */
/* END IF */
/* C */
/* C Convert the intersection point of the selected boundary */
/* C vector and Mars from rectangular into latitudinal */
/* C coordinates. Convert radians to degrees. */
/* C */
/* CALL RECLAT ( SPOINT, RADIUS, LON, LAT ) */
/* LON = LON * DPR () */
/* LAT = LAT * DPR () */
/* WRITE (*,*) 'Boundary vector surface intercept ' // */
/* . 'coordinates using SINCPT:' */
/* WRITE (*,*) ' Radius (km) : ', RADIUS */
/* WRITE (*,*) ' Latitude (deg): ', LAT */
/* WRITE (*,*) ' Longitude (deg): ', LON */
/* WRITE (*,*) ' Emit time using' */
/* WRITE (*,*) ' boundary LT(s) : ', ETEMIT */
/* C */
/* C We expect this to be a very small distance. */
/* C */
/* DIST = VDIST ( TMP, SPOINT ) */
/* WRITE (*,*) 'Distance between surface points' */
/* WRITE (*,*) 'of the selected boundary vector using' */
/* WRITE (*,*) 'SURFPT and SINCPT:' */
/* WRITE (*,*) ' Distance (mm): ', DIST*(10**6) */
/* END */
/* When this program was executed using gfortran on a PC Linux */
/* 64 bit environment, the output was: */
/* Observation Reference frame: MGS_MOC_NA */
/* Boresight surface intercept coordinates: */
/* Radius (km) : 3384.9404101592791 */
/* Latitude (deg): -48.479579821639035 */
/* Longitude (deg): -123.43645396290199 */
/* Boundary vector surface intercept coordinates using SURFPT: */
/* Radius (km) : 3384.9411359300038 */
/* Latitude (deg): -48.477481877892437 */
/* Longitude (deg): -123.47407986665237 */
/* Emit time using */
/* boresight LT(s): 119296864.18105948 */
/* Boundary vector surface intercept coordinates using SINCPT: */
/* Radius (km) : 3384.9411359139663 */
/* Latitude (deg): -48.477481924252693 */
/* Longitude (deg): -123.47407904898704 */
/* Emit time using */
/* boundary LT(s) : 119296864.18105946 */
/* Distance between surface points */
/* of the selected boundary vector using */
/* SURFPT and SINCPT: */
/* Distance (mm): 32.139879867352690 */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* S.C. Krening (JPL) */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 23-SEP-2013 (SCK) (WLT) (BVS) */
/* -& */
/* $ Index_Entries */
/* Position transformation matrix for different epochs */
/* -& */
/* $ Revisions */
/* None. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* JCODE represents the NAIF ID of the J2000 reference frame. */
/* The J2000 frame has a NAIF ID of 1. Any inertial reference */
/* frame could have been used for this program instead of J2000. */
/* Saved frame name length. */
/* Local variables */
/* Saved frame name/ID item declarations. */
/* Saved frame name/ID items. */
/* Initial values. */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
}
chkin_("PXFRM2", (ftnlen)6);
/* Initialization. */
if (first) {
/* Initialize counters. */
zzctruin_(svctr1);
zzctruin_(svctr2);
first = FALSE_;
}
/* The frame names must be converted to their corresponding IDs. */
zznamfrm_(svctr1, svfrom, &svfcod, from, &fcode, (ftnlen)32, from_len);
zznamfrm_(svctr2, svto, &svtcde, to, &tcode, (ftnlen)32, to_len);
/* Only non-zero ID codes are legitimate frame ID codes. Zero */
/* indicates that the frame was not recognized. */
if (fcode != 0 && tcode != 0) {
/* The following three lines of code calculate the following: */
/* 1) [JF] The rotation matrix is calculated from the frame */
/* FROM to the inertial J2000 frame at ETFROM. */
/* 2) [TJ] The rotation matrix is calculated from the J2000 */
/* frame to the TO frame at ETTO. */
/* 3) [ROTATE] The rotation matrix from frame FROM at ETFROM to */
/* frame TO at ETTO is given by the following: */
/* [ROTATE] = [TF] = [TJ][JF] */
refchg_(&fcode, &c__1, etfrom, jf);
refchg_(&c__1, &tcode, etto, tj);
mxm_(tj, jf, rotate);
} else if (fcode == 0 && tcode == 0) {
setmsg_("Neither frame # nor # was recognized as a known reference f"
"rame. ", (ftnlen)65);
errch_("#", from, (ftnlen)1, from_len);
errch_("#", to, (ftnlen)1, to_len);
sigerr_("SPICE(UNKNOWNFRAME)", (ftnlen)19);
} else if (fcode == 0) {
setmsg_("The frame # was not recognized as a known reference frame. ",
(ftnlen)59);
errch_("#", from, (ftnlen)1, from_len);
sigerr_("SPICE(UNKNOWNFRAME)", (ftnlen)19);
} else {
/* TCODE is zero */
setmsg_("The frame # was not recognized as a known reference frame. ",
(ftnlen)59);
errch_("#", to, (ftnlen)1, to_len);
sigerr_("SPICE(UNKNOWNFRAME)", (ftnlen)19);
}
chkout_("PXFRM2", (ftnlen)6);
return 0;
} /* pxfrm2_ */
/* $Procedure CKGP ( C-kernel, get pointing ) */
/* Subroutine */ int ckgp_(integer *inst, doublereal *sclkdp, doublereal *tol,
char *ref, doublereal *cmat, doublereal *clkout, logical *found,
ftnlen ref_len)
{
logical pfnd, sfnd;
integer sclk;
extern /* Subroutine */ int sct2e_(integer *, doublereal *, doublereal *);
integer type1, type2;
char segid[40];
extern /* Subroutine */ int chkin_(char *, ftnlen);
doublereal descr[5];
extern /* Subroutine */ int dafus_(doublereal *, integer *, integer *,
doublereal *, integer *), ckbss_(integer *, doublereal *,
doublereal *, logical *), ckpfs_(integer *, doublereal *,
doublereal *, doublereal *, logical *, doublereal *, doublereal *,
doublereal *, logical *), moved_(doublereal *, integer *,
doublereal *), cksns_(integer *, doublereal *, char *, logical *,
ftnlen);
logical gotit;
extern logical failed_(void);
doublereal av[3], et;
integer handle;
extern /* Subroutine */ int refchg_(integer *, integer *, doublereal *,
doublereal *);
logical needav;
extern /* Subroutine */ int ckmeta_(integer *, char *, integer *, ftnlen);
integer refseg, center;
extern /* Subroutine */ int namfrm_(char *, integer *, ftnlen), frinfo_(
integer *, integer *, integer *, integer *, logical *);
integer refreq, typeid;
extern /* Subroutine */ int chkout_(char *, ftnlen);
doublereal tmpmat[9] /* was [3][3] */;
extern logical return_(void);
doublereal dcd[2];
integer icd[6];
extern /* Subroutine */ int mxm_(doublereal *, doublereal *, doublereal *)
;
doublereal rot[9] /* was [3][3] */;
/* $ Abstract */
/* Get pointing (attitude) for a specified spacecraft clock time. */
/* $ 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 */
/* SCLK */
/* $ Keywords */
/* POINTING */
/* $ 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. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - 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) */
/* -& */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* INST I NAIF ID of instrument, spacecraft, or structure. */
/* SCLKDP I Encoded spacecraft clock time. */
/* TOL I Time tolerance. */
/* REF I Reference frame. */
/* CMAT O C-matrix pointing data. */
/* CLKOUT O Output encoded spacecraft clock time. */
/* FOUND O True when requested pointing is available. */
/* $ Detailed_Input */
/* INST is the NAIF integer ID for the instrument, spacecraft, */
/* or other structure for which pointing is requested. */
/* For brevity we will refer to this object as the */
/* "instrument," and the frame fixed to this object as */
/* the "instrument frame" or "instrument-fixed" frame. */
/* SCLKDP is the encoded spacecraft clock time for which */
/* pointing is requested. */
/* The SPICELIB routines SCENCD and SCE2C respectively */
/* convert spacecraft clock strings and ephemeris time to */
/* encoded spacecraft clock. The inverse conversions are */
/* performed by SCDECD and SCT2E. */
/* TOL is a time tolerance in ticks, the units of encoded */
/* spacecraft clock time. */
/* The SPICELIB routine SCTIKS converts a spacecraft */
/* clock tolerance duration from its character string */
/* representation to ticks. SCFMT performs the inverse */
/* conversion. */
/* The C-matrix returned by CKGP is the one whose time */
/* tag is closest to SCLKDP and within TOL units of */
/* SCLKDP. (More in Particulars, below.) */
/* In general, because using a non-zero tolerance */
/* affects selection of the segment from which the */
/* data is obtained, users are strongly discouraged */
/* from using a non-zero tolerance when reading CKs */
/* with continuous data. Using a non-zero tolerance */
/* should be reserved exclusively to reading CKs with */
/* discrete data because in practice obtaining data */
/* from such CKs using a zero tolerance is often not */
/* possible due to time round off. */
/* REF is the desired reference frame for the returned */
/* pointing. The returned C-matrix CMAT gives the */
/* orientation of the instrument designated by INST */
/* relative to the frame designated by REF. When a */
/* vector specified relative to frame REF is left- */
/* multiplied by CMAT, the vector is rotated to the */
/* frame associated with INST. See the discussion of */
/* CMAT below for details. */
/* Consult the SPICE document "Frames" for a discussion */
/* of supported reference frames. */
/* $ Detailed_Output */
/* CMAT is a rotation matrix that transforms the components of */
/* a vector expressed in the reference frame specified by */
/* REF to components expressed in the frame tied to the */
/* instrument, spacecraft, or other structure at time */
/* CLKOUT (see below). */
/* Thus, if a vector v has components x,y,z in the REF */
/* reference frame, then v has components x',y',z' in the */
/* instrument fixed frame at time CLKOUT: */
/* [ x' ] [ ] [ x ] */
/* | y' | = | CMAT | | y | */
/* [ z' ] [ ] [ z ] */
/* If you know x', y', z', use the transpose of the */
/* C-matrix to determine x, y, z as follows: */
/* [ x ] [ ]T [ x' ] */
/* | y | = | CMAT | | y' | */
/* [ z ] [ ] [ z' ] */
/* (Transpose of CMAT) */
/* CLKOUT is the encoded spacecraft clock time associated with */
/* the returned C-matrix. This value may differ from the */
/* requested time, but never by more than the input */
/* tolerance TOL. */
/* The particulars section below describes the search */
/* algorithm used by CKGP to satisfy a pointing */
/* request. This algorithm determines the pointing */
/* instance (and therefore the associated time value) */
/* that is returned. */
/* FOUND is true if a record was found to satisfy the pointing */
/* request. FOUND will be false otherwise. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If a C-kernel file has not been loaded using FURNSH prior to */
/* a call to this routine, an error is signaled by a routine in */
/* the call tree of this routine. */
/* 2) If TOL is negative, found is set to .FALSE. */
/* 3) If REF is not a supported reference frame, an error is */
/* signaled by a routine in the call tree of this routine and */
/* FOUND is set to .FALSE. */
/* $ Files */
/* CKGP searches through files loaded by FURNSH to locate a */
/* segment that can satisfy the request for pointing for instrument */
/* INST at time SCLKDP. You must load a C-kernel file using FURNSH */
/* prior to calling this routine. */
/* $ Particulars */
/* How the tolerance argument is used */
/* ================================== */
/* Reading a type 1 CK segment (discrete pointing instances) */
/* --------------------------------------------------------- */
/* In the diagram below */
/* - "0" is used to represent discrete pointing instances */
/* (quaternions and associated time tags). */
/* - "( )" are used to represent the end points of the time */
/* interval covered by a segment in a CK file. */
/* - SCLKDP is the time at which you requested pointing. */
/* The location of SCLKDP relative to the time tags of the */
/* pointing instances is indicated by the "+" sign. */
/* - TOL is the time tolerance specified in the pointing */
/* request. The square brackets "[ ]" represent the */
/* endpoints of the time interval */
/* SCLKDP-TOL : SCLKDP+TOL */
/* - The quaternions occurring in the segment need not be */
/* evenly spaced in time. */
/* Case 1: pointing is available */
/* ------------------------------ */
/* SCLKDP */
/* \ TOL */
/* | / */
/* |/\ */
/* Your request [--+--] */
/* . . . */
/* Segment (0-----0--0--0--0--0--0---0--0------------0--0--0--0) */
/* ^ */
/* | */
/* CKGP returns this instance. */
/* Case 2: pointing is not available */
/* ---------------------------------- */
/* SCLKDP */
/* \ TOL */
/* | / */
/* |/\ */
/* Your request [--+--] */
/* . . . */
/* Segment (0-----0--0--0--0--0--0---0--0--0---------0--0--0--0) */
/* CKGP returns no pointing; the output */
/* FOUND flag is set to .FALSE. */
/* Reading a type 2, 3, 4, or 5 CK segment (continuous pointing) */
/* ------------------------------------------------------------- */
/* In the diagrams below */
/* - "==" is used to represent periods of continuous pointing. */
/* - "--" is used to represent gaps in the pointing coverage. */
/* - "( )" are used to represent the end points of the time */
/* interval covered by a segment in a CK file. */
/* - SCLKDP is the time at which you requested pointing. */
/* The location of SCLKDP relative to the time tags of the */
/* pointing instances is indicated by the "+" sign. */
/* - TOL is the time tolerance specified in the pointing */
/* request. The square brackets "[ ]" represent the */
/* endpoints of the time interval */
/* SCLKDP-TOL : SCLKDP+TOL */
/* - The quaternions occurring in the periods of continuous */
/* pointing need not be evenly spaced in time. */
/* Case 1: pointing is available at the request time */
/* -------------------------------------------------- */
/* SCLKDP */
/* \ TOL */
/* | / */
/* |/\ */
/* Your request [--+--] */
/* . . . */
/* . . . */
/* . . . */
/* Segment (==---===========---=======----------===--) */
/* ^ */
/* | */
/* The request time lies within an interval where */
/* continuous pointing is available. CKGP returns */
/* pointing at the requested epoch. */
/* Case 2: pointing is available "near" the request time */
/* ------------------------------------------------------ */
/* SCLKDP */
/* \ TOL */
/* | / */
/* |/\ */
/* Your request [--+--] */
/* . . . */
/* Segment (==---===========----=======---------===--) */
/* ^ */
/* | */
/* The request time lies in a gap: an interval where */
/* continuous pointing is *not* available. CKGP */
/* returns pointing for the epoch closest to the */
/* request time SCLKDP. */
/* Case 3: pointing is not available */
/* ---------------------------------- */
/* SCLKDP */
/* \ TOL */
/* | / */
/* |/\ */
/* Your request [--+--] */
/* . . . */
/* Segment (==---===========----=======---------===--) */
/* CKGP returns no pointing; the output */
/* FOUND flag is set to .FALSE. */
/* Tolerance and segment priority */
/* ============================== */
/* CKGP searches through loaded C-kernels to satisfy a pointing */
/* request. Last-loaded files are searched first. Individual files */
/* are searched in backwards order, so that between competing */
/* segments (segments containing data for the same object, for */
/* overlapping time ranges), the one closest to the end of the file */
/* has highest priority. */
/* The search ends when a segment is found that can provide pointing */
/* for the specified instrument at a time falling within the */
/* specified tolerance on either side of the request time. Within */
/* that segment, the instance closest to the input time is located */
/* and returned. */
/* The following four cases illustrate this search procedure. */
/* Segments A and B are in the same file, with segment A located */
/* further towards the end of the file than segment B. Both segments */
/* A and B contain discrete pointing data, indicated by the number */
/* 0. */
/* Case 1: Pointing is available in the first segment searched. */
/* Because segment A has the highest priority and can */
/* satisfy the request, segment B is not searched. */
/* SCLKDP */
/* \ TOL */
/* | / */
/* |/\ */
/* Your request [--+--] */
/* . . . */
/* Segment A (0-----------------0--------0--0-----0) */
/* ^ */
/* | */
/* | */
/* CKGP returns this instance */
/* Segment B (0--0--0--0--0--0--0--0--0--0--0--0--0--0--0--0--0) */
/* Case 2: Pointing is not available in the first segment searched. */
/* Because segment A cannot satisfy the request, segment B */
/* is searched. */
/* SCLKDP */
/* \ TOL */
/* | / */
/* |/\ */
/* Your request [--+--] */
/* . . . */
/* Segment A (0-----------------0--------0--0-----0) */
/* . . . */
/* Segment B (0--0--0--0--0--0--0--0--0--0--0--0--0--0--0--0--0) */
/* ^ */
/* | */
/* CKGP returns this instance */
/* Segments that contain continuous pointing data are searched in */
/* the same manner as segments containing discrete pointing data. */
/* For request times that fall within the bounds of continuous */
/* intervals, CKGP will return pointing at the request time. When */
/* the request time does not fall within an interval, then a time at */
/* an endpoint of an interval may be returned if it is the closest */
/* time in the segment to the user request time and is also within */
/* the tolerance. */
/* In the following examples, segment A is located further towards */
/* the end of the file than segment C. Segment A contains discrete */
/* pointing data and segment C contains continuous data, indicated */
/* by the "=" character. */
/* Case 3: Pointing is not available in the first segment searched. */
/* Because segment A cannot satisfy the request, segment C */
/* is searched. */
/* SCLKDP */
/* \ TOL */
/* | / */
/* |/\ */
/* Your request [--+--] */
/* . . . */
/* . . . */
/* Segment A (0-----------------0--------0--0-----0) */
/* . . . */
/* . . . */
/* Segment C (---=============-----====--------==--) */
/* ^ */
/* | */
/* | */
/* CKGP returns this instance */
/* In the next case, assume that the order of segments A and C in the */
/* file is reversed: A is now closer to the front, so data from */
/* segment C are considered first. */
/* Case 4: Pointing is available in the first segment searched. */
/* Because segment C has the highest priority and can */
/* satisfy the request, segment A is not searched. */
/* SCLKDP */
/* / */
/* | TOL */
/* | / */
/* |/\ */
/* Your request [--+--] */
/* . . . */
/* . . . */
/* Segment C (---=============-----====--------==--) */
/* ^ */
/* | */
/* CKGP returns this instance */
/* Segment A (0-----------------0--------0--0-----0) */
/* ^ */
/* | */
/* "Best" answer */
/* The next case illustrates an unfortunate side effect of using */
/* a non-zero tolerance when reading multi-segment CKs with */
/* continuous data. In all cases when the look-up interval */
/* formed using tolerance overlaps a segment boundary and */
/* the request time falls within the coverage of the lower */
/* priority segment, the data at the end of the higher priority */
/* segment will be picked instead of the data from the lower */
/* priority segment. */
/* Case 5: Pointing is available in the first segment searched. */
/* Because segment C has the highest priority and can */
/* satisfy the request, segment A is not searched. */
/* SCLKDP */
/* / */
/* | TOL */
/* | / */
/* |/\ */
/* Your request [--+--] */
/* . . . */
/* . . . */
/* Segment C (===============) */
/* ^ */
/* | */
/* CKGP returns this instance */
/* Segment A (=====================) */
/* ^ */
/* | */
/* "Best" answer */
/* $ Examples */
/* Suppose you have two C-kernel files containing data for the */
/* Voyager 2 narrow angle camera. One file contains predict values, */
/* and the other contains corrected pointing for a selected group */
/* of images, that is, for a subset of images from the first file. */
/* The following example program uses CKGP to get C-matrices for a */
/* set of images whose SCLK counts (un-encoded character string */
/* versions) are contained in the array SCLKCH. */
/* If available, the program will get the corrected pointing values. */
/* Otherwise, predict values will be used. */
/* For each C-matrix, a unit pointing vector is constructed */
/* and printed. */
/* C */
/* C Constants for this program. */
/* C */
/* C -- The code for the Voyager 2 spacecraft clock is -32 */
/* C */
/* C -- The code for the narrow angle camera on the Voyager 2 */
/* C spacecraft is -32001. */
/* C */
/* C -- Spacecraft clock times for successive Voyager images */
/* C always differ by more than 0:0:400. This is an */
/* C acceptable tolerance, and must be converted to "ticks" */
/* C (units of encoded SCLK) for input to CKGP. */
/* C */
/* C -- The reference frame we want is FK4. */
/* C */
/* C -- The narrow angle camera boresight defines the third */
/* C axis of the instrument-fixed coordinate system. */
/* C Therefore, the vector ( 0, 0, 1 ) represents */
/* C the boresight direction in the camera-fixed frame. */
/* C */
/* IMPLICIT NONE */
/* INTEGER FILEN */
/* PARAMETER ( FILEN = 255 ) */
/* INTEGER NPICS */
/* PARAMETER ( NPICS = 2 ) */
/* INTEGER TIMLEN */
/* PARAMETER ( TIMLEN = 30 ) */
/* INTEGER REFLEN */
/* PARAMETER ( REFLEN = 32 ) */
/* CHARACTER*(TIMLEN) CLKCH */
/* CHARACTER*(FILEN) CKPRED */
/* CHARACTER*(FILEN) CKCORR */
/* CHARACTER*(REFLEN) REF */
/* CHARACTER*(FILEN) SCLK */
/* CHARACTER*(TIMLEN) SCLKCH ( NPICS ) */
/* CHARACTER*(TIMLEN) TOLVGR */
/* DOUBLE PRECISION CLKOUT */
/* DOUBLE PRECISION CMAT ( 3, 3 ) */
/* DOUBLE PRECISION SCLKDP */
/* DOUBLE PRECISION TOLTIK */
/* DOUBLE PRECISION VCFIX ( 3 ) */
/* DOUBLE PRECISION VINERT ( 3 ) */
/* INTEGER SC */
/* INTEGER I */
/* INTEGER INST */
/* LOGICAL FOUND */
/* CKPRED = 'voyager2_predict.bc' */
/* CKCORR = 'voyager2_corrected.bc' */
/* SCLK = 'voyager2_sclk.tsc' */
/* SC = -32 */
/* INST = -32001 */
/* SCLKCH(1) = '4/08966:30:768' */
/* SCLKCH(2) = '4/08970:58:768' */
/* TOLVGR = '0:0:400' */
/* REF = 'FK4' */
/* VCFIX( 1 ) = 0.D0 */
/* VCFIX( 2 ) = 0.D0 */
/* VCFIX( 3 ) = 1.D0 */
/* C */
/* C Loading the files in this order ensures that the */
/* C corrected file will get searched first. */
/* C */
/* CALL FURNSH ( CKPRED ) */
/* CALL FURNSH ( CKCORR ) */
/* C */
/* C Need to load a Voyager 2 SCLK kernel to convert from */
/* C clock strings to ticks. */
/* C */
/* CALL FURNSH ( SCLK ) */
/* C */
/* C Convert tolerance from VGR formatted character string */
/* C SCLK to ticks which are units of encoded SCLK. */
/* C */
/* CALL SCTIKS ( SC, TOLVGR, TOLTIK ) */
/* DO I = 1, NPICS */
/* C */
/* C CKGP requires encoded spacecraft clock. */
/* C */
/* CALL SCENCD ( SC, SCLKCH( I ), SCLKDP ) */
/* CALL CKGP ( INST, SCLKDP, TOLTIK, REF, CMAT, */
/* . CLKOUT, FOUND ) */
/* IF ( FOUND ) THEN */
/* C */
/* C Use the transpose of the C-matrix to transform the */
/* C boresight vector from camera-fixed to reference */
/* C coordinates. */
/* C */
/* CALL MTXV ( CMAT, VCFIX, VINERT ) */
/* CALL SCDECD ( SC, CLKOUT, CLKCH ) */
/* WRITE (*,*) 'VGR 2 SCLK Time: ', CLKCH */
/* WRITE (*,*) 'VGR 2 NA ISS boresight ' */
/* . // 'pointing vector: ', VINERT */
/* ELSE */
/* WRITE (*,*) 'Pointing not found for time ', SCLKCH(I) */
/* END IF */
/* END DO */
/* END */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* C.H. Acton (JPL) */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* J.M. Lynch (JPL) */
/* B.V. Semenov (JPL) */
/* M.J. Spencer (JPL) */
/* R.E. Thurman (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 5.3.1, 09-JUN-2010 (BVS) */
/* Header update: description of the tolerance and Particulars */
/* section were expanded to address some problems arising from */
/* using a non-zero tolerance. */
/* - SPICELIB Version 5.3.0, 23-APR-2010 (NJB) */
/* Bug fix: this routine now obtains the rotation */
/* from the request frame to the applicable CK segment's */
/* base frame via a call to REFCHG. Formerly the routine */
/* used FRMCHG, which required that angular velocity data */
/* be available for this transformation. */
/* - SPICELIB Version 5.2.0, 25-AUG-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM call. */
/* - SPICELIB Version 5.1.2, 29-JAN-2004 (NJB) */
/* Header update: description of input argument REF was */
/* expanded. */
/* - SPICELIB Version 5.1.1, 27-JUL-2003 (CHA) (NJB) */
/* Various header corrections were made. */
/* - SPICELIB Version 3.2.0, 23-FEB-1999 (WLT) */
/* The previous editions of this routine did not properly handle */
/* the case when TOL was negative. The routine now returns a */
/* value of .FALSE. for FOUND as is advertised above. */
/* - SPICELIB Version 3.1.0, 13-APR-1998 (WLT) */
/* The call to CHKOUT in the case when FAILED returned the */
/* value TRUE used to check out with the name 'CKGPAV'. This */
/* has been changed to a CKGP. */
/* - SPICELIB Version 3.0.0, 19-SEP-1994 (WLT) */
/* The routine was upgraded to support non-inertial frames. */
/* - SPICELIB Version 2.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.0, 30-AUG-1991 (JML) */
/* The Particulars section was updated to show how the */
/* search algorithm processes segments with continuous */
/* pointing data. */
/* The example program now loads an SCLK kernel. */
/* FAILED is checked after the call to IRFROT to handle the */
/* case where the reference frame is invalid and the error */
/* handling is not set to abort. */
/* FAILED is checked in the DO WHILE loop to handle the case */
/* where an error is detected by a SPICELIB routine inside the */
/* loop and the error handling is not set to abort. */
/* - SPICELIB Version 1.0.1, 02-NOV-1990 (JML) */
/* The restriction that a C-kernel file must be loaded */
/* was explicitly stated. */
/* - SPICELIB Version 1.0.0, 07-SEP-1990 (RET) (IMU) */
/* -& */
/* $ Index_Entries */
/* get ck pointing */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 5.2.0, 25-AUG-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM call. */
/* - SPICELIB Version 3.1.0, 20-DEC-1995 (WLT) */
/* A call to FRINFO did not have enough arguments and */
/* went undetected until Howard Taylor of ACT. Many */
/* thanks go out to Howard for tracking down this error. */
/* - SPICELIB Version 3.0.0, 19-SEP-1994 (WLT) */
/* The routine was upgraded to support non-inertial frames. */
/* Calls to NAMIRF and IRFROT were replaced with calls to */
/* NAMFRM and FRMCHG respectively. */
/* - SPICELIB Version 1.0.2, 30-AUG-1991 (JML) */
/* 1) The Particulars section was updated to show how the */
/* search algorithm processes segments with continuous */
/* pointing data. */
/* 2) The example program now loads an SCLK kernel. */
/* 3) FAILED is checked after the call to IRFROT to handle the */
/* case where the reference frame is invalid and the error */
/* handling is not set to abort. */
/* 4) FAILED is checked in the DO WHILE loop to handle the case */
/* where an error is detected by a SPICELIB routine inside the */
/* loop and the error handling is not set to abort. */
/* - SPICELIB Version 1.0.1, 02-NOV-1990 (JML) */
/* 1) The restriction that a C-kernel file must be loaded */
/* was explicitly stated. */
/* 2) Minor changes were made to the wording of the header. */
/* - Beta Version 1.1.0, 29-AUG-1990 (MJS) */
/* The following changes were made as a result of the */
/* NAIF CK Code and Documentation Review: */
/* 1) The variable SCLK was changed to SCLKDP. */
/* 2) The variable INSTR was changed to INST. */
/* 3) The variable IDENT was changed to SEGID. */
/* 4) The declarations for the parameters NDC, NIC, NC, and */
/* IDLEN were moved from the "Declarations" section of the */
/* header to the "Local parameters" section of the code below */
/* the header. These parameters are not meant to modified by */
/* users. */
/* 5) The header was updated to reflect the changes. */
/* - Beta Version 1.0.0, 04-MAY-1990 (RET) (IMU) */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* NDC is the number of double precision components in an */
/* unpacked C-kernel segment descriptor. */
/* NIC is the number of integer components in an unpacked */
/* C-kernel segment descriptor. */
/* NC is the number of components in a packed C-kernel */
/* descriptor. All DAF summaries have this formulaic */
/* relationship between the number of its integer and */
/* double precision components and the number of packed */
/* components. */
/* IDLEN is the length of the C-kernel segment identifier. */
/* All DAF names have this formulaic relationship */
/* between the number of summary components and */
/* the length of the name (You will notice that */
/* a name and a summary have the same length in bytes.) */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("CKGP", (ftnlen)4);
}
/* Don't need angular velocity data. */
/* Assume the segment won't be found until it really is. */
needav = FALSE_;
*found = FALSE_;
/* If the tolerance is less than zero, we go no further. */
if (*tol < 0.) {
chkout_("CKGP", (ftnlen)4);
return 0;
}
/* Begin a search for this instrument and time, and get the first */
/* applicable segment. */
ckbss_(inst, sclkdp, tol, &needav);
cksns_(&handle, descr, segid, &sfnd, (ftnlen)40);
/* Keep trying candidate segments until a segment can produce a */
/* pointing instance within the specified time tolerance of the */
/* input time. */
/* Check FAILED to prevent an infinite loop if an error is detected */
/* by a SPICELIB routine and the error handling is not set to abort. */
while(sfnd && ! failed_()) {
ckpfs_(&handle, descr, sclkdp, tol, &needav, cmat, av, clkout, &pfnd);
if (pfnd) {
/* Found one. If the C-matrix doesn't already rotate from the */
/* requested frame, convert it to one that does. */
dafus_(descr, &c__2, &c__6, dcd, icd);
refseg = icd[1];
/* Look up the id code for the requested reference frame. */
namfrm_(ref, &refreq, ref_len);
if (refreq != refseg) {
/* We may need to convert the output ticks CLKOUT to ET */
/* so that we can get the needed state transformation */
/* matrix. This is the case if either of the frames */
/* is non-inertial. */
frinfo_(&refreq, ¢er, &type1, &typeid, &gotit);
frinfo_(&refseg, ¢er, &type2, &typeid, &gotit);
if (type1 == 1 && type2 == 1) {
/* Any old value of ET will do in this case. We'll */
/* use zero. */
et = 0.;
} else {
/* Look up the spacecraft clock id to use to convert */
/* the output CLKOUT to ET. */
ckmeta_(inst, "SCLK", &sclk, (ftnlen)4);
sct2e_(&sclk, clkout, &et);
}
/* Get the transformation from the requested frame to */
/* the segment frame at ET. */
refchg_(&refreq, &refseg, &et, rot);
/* If REFCHG detects that the reference frame is invalid */
/* then return from this routine with FOUND equal to false. */
if (failed_()) {
chkout_("CKGP", (ftnlen)4);
return 0;
}
/* Transform the attitude information: convert CMAT so that */
/* it maps from request frame to C-matrix frame. */
mxm_(cmat, rot, tmpmat);
moved_(tmpmat, &c__9, cmat);
}
*found = TRUE_;
chkout_("CKGP", (ftnlen)4);
return 0;
}
cksns_(&handle, descr, segid, &sfnd, (ftnlen)40);
}
/* $Procedure TIPBOD ( Transformation, inertial position to bodyfixed ) */
/* Subroutine */ int tipbod_(char *ref, integer *body, doublereal *et,
doublereal *tipm, ftnlen ref_len)
{
doublereal ref2j[9] /* was [3][3] */;
extern /* Subroutine */ int chkin_(char *, ftnlen), moved_(doublereal *,
integer *, doublereal *);
extern logical failed_(void);
extern /* Subroutine */ int bodmat_(integer *, doublereal *, doublereal *)
, chkout_(char *, ftnlen);
doublereal tmpmat[9] /* was [3][3] */;
extern /* Subroutine */ int irftrn_(char *, char *, doublereal *, ftnlen,
ftnlen);
extern logical return_(void);
extern /* Subroutine */ int mxm_(doublereal *, doublereal *, doublereal *)
;
/* $ Abstract */
/* Return a 3x3 matrix that transforms positions in inertial */
/* coordinates to positions in body-equator-and-prime-meridian */
/* coordinates. */
/* $ 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 */
/* PCK */
/* NAIF_IDS */
/* ROTATION */
/* TIME */
/* $ Keywords */
/* TRANSFORMATION */
/* ROTATION */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* REF I ID of inertial reference frame to transform from. */
/* BODY I ID code of body. */
/* ET I Epoch of transformation. */
/* TIPM O Transformation (position), inertial to prime */
/* meridian. */
/* $ Detailed_Input */
/* REF is the NAIF name for an inertial reference frame. */
/* Acceptable names include: */
/* Name Description */
/* -------- -------------------------------- */
/* 'J2000' Earth mean equator, dynamical */
/* equinox of J2000 */
/* 'B1950' Earth mean equator, dynamical */
/* equinox of B1950 */
/* 'FK4' Fundamental Catalog (4) */
/* 'DE-118' JPL Developmental Ephemeris (118) */
/* 'DE-96' JPL Developmental Ephemeris ( 96) */
/* 'DE-102' JPL Developmental Ephemeris (102) */
/* 'DE-108' JPL Developmental Ephemeris (108) */
/* 'DE-111' JPL Developmental Ephemeris (111) */
/* 'DE-114' JPL Developmental Ephemeris (114) */
/* 'DE-122' JPL Developmental Ephemeris (122) */
/* 'DE-125' JPL Developmental Ephemeris (125) */
/* 'DE-130' JPL Developmental Ephemeris (130) */
/* 'GALACTIC' Galactic System II */
/* 'DE-200' JPL Developmental Ephemeris (200) */
/* 'DE-202' JPL Developmental Ephemeris (202) */
/* (See the routine CHGIRF for a full list of names.) */
/* The output TIPM will give the transformation */
/* from this frame to the bodyfixed frame specified by */
/* BODY at the epoch specified by ET. */
/* BODY is the integer ID code of the body for which the */
/* position transformation matrix is requested. Bodies */
/* are numbered according to the standard NAIF */
/* numbering scheme. The numbering scheme is */
/* explained in the NAIF_IDS required reading file. */
/* ET is the epoch at which the position transformation */
/* matrix is requested. (This is typically the */
/* epoch of observation minus the one-way light time */
/* from the observer to the body at the epoch of */
/* observation.) */
/* $ Detailed_Output */
/* TIPM is a 3x3 coordinate transformation matrix. It is */
/* used to transform positions from inertial */
/* coordinates to body fixed (also called equator and */
/* prime meridian --- PM) coordinates. */
/* Given a position P in the inertial reference frame */
/* specified by REF, the corresponding bodyfixed */
/* position is given by the matrix vector product: */
/* TIPM * S */
/* The X axis of the PM system is directed to the */
/* intersection of the equator and prime meridian. */
/* The Z axis points along the spin axis and points */
/* towards the same side of the invariable plane of */
/* the solar system as does earth's north pole. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the kernel pool does not contain all of the data required */
/* for computing the transformation matrix, TIPM, the error */
/* SPICE(INSUFFICIENTANGLES) is signalled. */
/* 2) If the reference frame, REF, is not recognized, a routine */
/* called by TIPBOD will diagnose the condition and invoke the */
/* SPICE error handling system. */
/* 3) If the specified body code, BODY, is not recognized, the */
/* error is diagnosed by a routine called by TIPBOD. */
/* $ Files */
/* None. */
/* $ Particulars */
/* TIPBOD takes PCK information as input, either in the */
/* form of a binary or text PCK file. High precision */
/* binary files are searched for first (the last loaded */
/* file takes precedence); then it defaults to the text */
/* PCK file. If binary information is found for the */
/* requested body and time, the Euler angles are */
/* evaluated and the transformation matrix is calculated */
/* from them. Using the Euler angles PHI, DELTA and W */
/* we compute */
/* TIPM = [W] [DELTA] [PHI] */
/* 3 1 3 */
/* If no appropriate binary PCK files have been loaded, */
/* the text PCK file is used. Here information is found */
/* as RA, DEC and W (with the possible addition of nutation */
/* and libration terms for satellites). Again, the Euler */
/* angles are found, and the transformation matrix is */
/* calculated from them. The transformation from inertial to */
/* bodyfixed coordinates is represented as: */
/* TIPM = [W] [HALFPI-DEC] [RA+HALFPI] */
/* 3 1 3 */
/* These are basically the Euler angles, PHI, DELTA and W: */
/* RA = PHI - HALFPI */
/* DEC = HALFPI - DELTA */
/* W = W */
/* In the text file, RA, DEC, and W are defined as follows: */
/* 2 ____ */
/* RA2*t \ */
/* RA = RA0 + RA1*t/T + ------ + / a sin theta */
/* 2 ---- i i */
/* T i */
/* 2 ____ */
/* DEC2*t \ */
/* DEC = DEC0 + DEC1*t/T + ------- + / d cos theta */
/* 2 ---- i i */
/* T i */
/* 2 ____ */
/* W2*t \ */
/* W = W0 + W1*t/d + ----- + / w sin theta */
/* 2 ---- i i */
/* d i */
/* where: */
/* d = seconds/day */
/* T = seconds/Julian century */
/* a , d , and w arrays apply to satellites only. */
/* i i i */
/* theta = THETA0(i) + THETA1(i)*t/T are specific to each */
/* i */
/* planet. */
/* These angles -- typically nodal rates -- vary in number and */
/* definition from one planetary system to the next. */
/* $ Examples */
/* Note that the items necessary to compute the Euler angles */
/* must have been loaded into the kernel pool (by one or more */
/* previous calls to FURNSH). The Euler angles are typically */
/* stored in the P_constants kernel file that comes with */
/* SPICELIB. */
/* 1) In the following code fragment, TIPBOD is used to transform */
/* a position in J2000 inertial coordinates to a state in */
/* bodyfixed coordinates. */
/* The 3-vectors POSTN represents the inertial position */
/* of an object with respect to the center of the */
/* body at time ET. */
/* C */
/* C First load the kernel pool. */
/* C */
/* CALL FURNSH ( 'PLANETARY_CONSTANTS.KER' ) */
/* C */
/* C Next get the transformation and its derivative. */
/* C */
/* CALL TIPBOD ( 'J2000', BODY, ET, TIPM ) */
/* C */
/* C Convert position, the first three elements of */
/* C STATE, to bodyfixed coordinates. */
/* C */
/* CALL MXVG ( TIPM, POSTN, BDPOS ) */
/* $ Restrictions */
/* The kernel pool must be loaded with the appropriate */
/* coefficients (from the P_constants kernel or binary PCK file) */
/* prior to calling this routine. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* W.L. Taber (JPL) */
/* K.S. Zukor (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.0, 23-OCT-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM call. Replaced header references to LDPOOL with */
/* references to FURNSH. */
/* - SPICELIB Version 1.1.0, 05-JAN-2005 (NJB) */
/* Tests of routine FAILED() were added. */
/* - SPICELIB Version 1.0.3, 10-MAR-1994 (KSZ) */
/* Underlying BODMAT code changed to look for binary PCK */
/* data files, and use them to get orientation information if */
/* they are available. Only the comments to TIPBOD changed. */
/* - SPICELIB Version 1.0.2, 06-JUL-1993 (HAN) */
/* Example in header was corrected. Previous version had */
/* incorrect matrix dimension specifications passed to MXVG. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 05-AUG-1991 (NJB) (WLT) */
/* -& */
/* $ Index_Entries */
/* transformation from inertial position to bodyfixed */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.2.0, 06-SEP-2005 (NJB) */
/* Updated to remove non-standard use of duplicate arguments */
/* in MXM call. Replaced header references to LDPOOL with */
/* references to FURNSH. */
/* - SPICELIB Version 1.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 variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("TIPBOD", (ftnlen)6);
}
/* Get the transformation from the inertial from REF to J2000 */
/* coordinates. */
irftrn_(ref, "J2000", ref2j, ref_len, (ftnlen)5);
/* Get the transformation from J2000 to body-fixed coordinates */
/* for the requested epoch. */
bodmat_(body, et, tipm);
if (failed_()) {
chkout_("TIPBOD", (ftnlen)6);
return 0;
}
/* Compose the transformations to arrive at the REF-to-J2000 */
/* transformation. */
mxm_(tipm, ref2j, tmpmat);
moved_(tmpmat, &c__9, tipm);
/* That's all folks. Check out and get out. */
chkout_("TIPBOD", (ftnlen)6);
return 0;
} /* tipbod_ */
/* Subroutine */ int deri1_(doublereal *c__, integer *norbs, doublereal *
coord, integer *number, doublereal *work, doublereal *grad,
doublereal *f, integer *minear, doublereal *fd, doublereal *wmat,
doublereal *hmat, doublereal *fmat)
{
/* Initialized data */
static integer icalcn = 0;
/* System generated locals */
integer c_dim1, c_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4,
i__5, i__6, i__7, i__8;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), do_lio(
integer *, integer *, char *, ftnlen), e_wsle(void), s_wsfe(
cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, j, k, l, n1, n2, ll;
static doublereal gse;
extern doublereal dot_(doublereal *, doublereal *, integer *);
extern /* Subroutine */ int mxm_(doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
static integer nend, nati, lcut, loop, natx;
static doublereal step;
static integer iprt;
extern /* Subroutine */ int mtxm_(doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), mecid_(doublereal *,
doublereal *, doublereal *, doublereal *), mecih_(doublereal *,
doublereal *, integer *, integer *);
static logical debug;
extern /* Subroutine */ int timer_(char *, ftnlen);
static integer ninit;
extern /* Subroutine */ int scopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dfock2_(doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
integer *, integer *), dijkl1_(doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *);
static doublereal enucl2;
extern /* Subroutine */ int dhcore_(doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, doublereal *);
extern doublereal helect_(integer *, doublereal *, doublereal *,
doublereal *);
static integer linear;
extern /* Subroutine */ int supdot_(doublereal *, doublereal *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___11 = { 0, 6, 0, 0, 0 };
static cilist io___13 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___22 = { 0, 6, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, "(' * * * GRADIENT COMPONENT NUMBER',"
"I4)", 0 };
static cilist io___24 = { 0, 0, 0, "(' NON-RELAXED C.I-ACTIVE FOCK EIGEN"
"VALUES ', 'DERIVATIVES (E.V.)')", 0 };
static cilist io___25 = { 0, 0, 0, "(8F10.4)", 0 };
static cilist io___26 = { 0, 0, 0, "(' NON-RELAXED 2-ELECTRONS DERIVATIV"
"ES (E.V.)'/ ' I J K L d<I(1)J(1)|K(2)L(2)>')",
0 };
static cilist io___28 = { 0, 0, 0, "(4I5,F20.10)", 0 };
static cilist io___29 = { 0, 0, 0, "(' NON-RELAXED GRADIENT COMPONENT',F"
"10.4, ' KCAL/MOLE')", 0 };
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
/* ******************************************************************** */
/* DERI1 COMPUTE THE NON-RELAXED DERIVATIVE OF THE NON-VARIATIONALLY */
/* OPTIMIZED WAVEFUNCTION ENERGY WITH RESPECT TO ONE CARTESIAN */
/* COORDINATE AT A TIME */
/* AND */
/* COMPUTE THE NON-RELAXED FOCK MATRIX DERIVATIVE IN M.O BASIS AS */
/* REQUIRED IN THE RELAXATION SECTION (ROUTINE 'DERI2'). */
/* INPUT */
/* C(NORBS,NORBS) : M.O. COEFFICIENTS. */
/* COORD : CARTESIAN COORDINATES ARRAY. */
/* NUMBER : LOCATION OF THE REQUIRED VARIABLE IN COORD. */
/* WORK : WORK ARRAY OF SIZE N*N. */
/* WMAT : WORK ARRAYS FOR d<PQ|RS> (2-CENTERS A.O) */
/* OUTPUT */
/* C,COORD,NUMBER : NOT MODIFIED. */
/* GRAD : DERIVATIVE OF THE HEAT OF FORMATION WITH RESPECT TO */
/* COORD(NUMBER), WITHOUT RELAXATION CORRECTION. */
/* F(MINEAR) : NON-RELAXED FOCK MATRIX DERIVATIVE WITH RESPECT TO */
/* COORD(NUMBER), EXPRESSED IN M.O BASIS, SCALED AND */
/* PACKED, OFF-DIAGONAL BLOCKS ONLY. */
/* FD : IDEM BUT UNSCALED, DIAGONAL BLOCKS, C.I-ACTIVE ONLY. */
/* *********************************************************************** */
/* Parameter adjustments */
work_dim1 = *norbs;
work_offset = 1 + work_dim1 * 1;
work -= work_offset;
c_dim1 = *norbs;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--coord;
--f;
--fd;
--wmat;
--hmat;
--fmat;
/* Function Body */
if (icalcn != numcal_1.numcal) {
debug = i_indx(keywrd_1.keywrd, "DERI1", (ftnlen)241, (ftnlen)5) != 0;
iprt = 6;
linear = *norbs * (*norbs + 1) / 2;
icalcn = numcal_1.numcal;
}
if (debug) {
timer_("BEFORE DERI1", (ftnlen)12);
}
step = .001;
/* 2 POINTS FINITE DIFFERENCE TO GET THE INTEGRAL DERIVATIVES */
/* ---------------------------------------------------------- */
/* STORED IN HMAT AND WMAT, WITHOUT DIVIDING BY THE STEP SIZE. */
nati = (*number - 1) / 3 + 1;
natx = *number - (nati - 1) * 3;
dhcore_(&coord[1], &hmat[1], &wmat[1], &enucl2, &nati, &natx, &step);
/* HMAT HOLDS THE ONE-ELECTRON DERIVATIVES OF ATOM NATI FOR DIRECTION */
/* NATX W.R.T. ALL OTHER ATOMS */
/* WMAT HOLDS THE TWO-ELECTRON DERIVATIVES OF ATOM NATI FOR DIRECTION */
/* NATX W.R.T. ALL OTHER ATOMS */
step = .5 / step;
/* NON-RELAXED FOCK MATRIX DERIVATIVE IN A.O BASIS. */
/* ------------------------------------------------ */
/* STORED IN FMAT, DIVIDED BY STEP. */
scopy_(&linear, &hmat[1], &c__1, &fmat[1], &c__1);
dfock2_(&fmat[1], densty_1.p, densty_1.pa, &wmat[1], &molkst_1.numat,
molkst_1.nfirst, molkst_1.nmidle, molkst_1.nlast, &nati);
/* FMAT HOLDS THE ONE PLUS TWO - ELECTRON DERIVATIVES OF ATOM NATI FOR */
/* DIRECTION NATX W.R.T. ALL OTHER ATOMS */
/* DERIVATIVE OF THE SCF-ONLY ENERGY (I.E BEFORE C.I CORRECTION) */
*grad = (helect_(norbs, densty_1.p, &hmat[1], &fmat[1]) + enucl2) * step;
/* TAKE STEP INTO ACCOUNT IN FMAT */
i__1 = linear;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
fmat[i__] *= step;
}
/* RIGHT-HAND SIDE SUPER-VECTOR F = C' FMAT C USED IN RELAXATION */
/* ----------------------------------------------------------- */
/* STORED IN NON-STANDARD PACKED FORM IN F(MINEAR) AND FD. */
/* THE SUPERVECTOR IS THE NON-RELAXED FOCK MATRIX DERIVATIVE IN */
/* M.O BASIS: F(IJ)= ( (C' * FOCK * C)(I,J) ) WITH I.GT.J . */
/* F IS SCALED AND PACKED IN SUPERVECTOR FORM WITH */
/* THE CONSECUTIVE FOLLOWING OFF-DIAGONAL BLOCKS: */
/* 1) OPEN-CLOSED I.E. F(IJ)=F(I,J) WITH I OPEN & J CLOSED */
/* AND I RUNNING FASTER THAN J, */
/* 2) VIRTUAL-CLOSED SAME RULE OF ORDERING, */
/* 3) VIRTUAL-OPEN SAME RULE OF ORDERING. */
/* FD IS PACKED OVER THE C.I-ACTIVE M.O WITH */
/* THE CONSECUTIVE DIAGONAL BLOCKS: */
/* 1) CLOSED-CLOSED IN CANONICAL ORDER, WITHOUT THE */
/* DIAGONAL ELEMENTS, */
/* 2) OPEN-OPEN SAME RULE OF ORDERING, */
/* 3) VIRTUAL-VIRTUAL SAME RULE OF ORDERING. */
/* PART 1 : WORK(N,N) = FMAT(N,N) * C(N,N) */
i__1 = *norbs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
supdot_(&work[i__ * work_dim1 + 1], &fmat[1], &c__[i__ * c_dim1 + 1],
norbs, &c__1);
}
/* PART 2 : F(IJ) = (C' * WORK)(I,J) ... OFF-DIAGONAL BLOCKS. */
l = 1;
if (cibits_1.nbo[1] != 0 && cibits_1.nbo[0] != 0) {
/* OPEN-CLOSED */
mtxm_(&c__[(cibits_1.nbo[0] + 1) * c_dim1 + 1], &cibits_1.nbo[1], &
work[work_offset], norbs, &f[l], cibits_1.nbo);
l += cibits_1.nbo[1] * cibits_1.nbo[0];
}
if (cibits_1.nbo[2] != 0 && cibits_1.nbo[0] != 0) {
/* VIRTUAL-CLOSED */
mtxm_(&c__[(molkst_1.nopen + 1) * c_dim1 + 1], &cibits_1.nbo[2], &
work[work_offset], norbs, &f[l], cibits_1.nbo);
l += cibits_1.nbo[2] * cibits_1.nbo[0];
}
if (cibits_1.nbo[2] != 0 && cibits_1.nbo[1] != 0) {
/* VIRTUAL-OPEN */
mtxm_(&c__[(molkst_1.nopen + 1) * c_dim1 + 1], &cibits_1.nbo[2], &
work[(cibits_1.nbo[0] + 1) * work_dim1 + 1], norbs, &f[l], &
cibits_1.nbo[1]);
}
/* SCALE F ACCORDING TO THE DIAGONAL METRIC TENSOR 'SCALAR '. */
i__1 = *minear;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L30: */
f[i__] *= fokmat_1.scalar[i__ - 1];
}
if (debug) {
s_wsle(&io___11);
do_lio(&c__9, &c__1, " F IN DERI1", (ftnlen)11);
e_wsle();
j = min(20,*minear);
s_wsfe(&io___13);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&f[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
}
/* PART 3 : SUPER-VECTOR FD, C.I-ACTIVE DIAGONAL BLOCKS, UNSCALED. */
l = 1;
nend = 0;
for (loop = 1; loop <= 3; ++loop) {
ninit = nend + 1;
nend += cibits_1.nbo[loop - 1];
/* Computing MAX */
i__1 = ninit, i__2 = cibits_1.nelec + 1;
n1 = max(i__1,i__2);
/* Computing MIN */
i__1 = nend, i__2 = cibits_1.nelec + cibits_1.nmos;
n2 = min(i__1,i__2);
if (n2 < n1) {
goto L50;
}
i__1 = n2;
for (i__ = n1; i__ <= i__1; ++i__) {
if (i__ > ninit) {
i__2 = i__ - ninit;
mxm_(&c__[i__ * c_dim1 + 1], &c__1, &work[ninit * work_dim1 +
1], norbs, &fd[l], &i__2);
l = l + i__ - ninit;
}
/* L40: */
}
L50:
;
}
/* NON-RELAXED C.I CORRECTION TO THE ENERGY DERIVATIVE. */
/* ---------------------------------------------------- */
/* C.I-ACTIVE FOCK EIGENVALUES DERIVATIVES, STORED IN FD(CONTINUED). */
lcut = l;
i__1 = cibits_1.nelec + cibits_1.nmos;
for (i__ = cibits_1.nelec + 1; i__ <= i__1; ++i__) {
fd[l] = dot_(&c__[i__ * c_dim1 + 1], &work[i__ * work_dim1 + 1],
norbs);
/* L60: */
++l;
}
/* C.I-ACTIVE 2-ELECTRONS INTEGRALS DERIVATIVES. STORED IN XY. */
/* FMAT IS USED HERE AS SCRATCH SPACE */
dijkl1_(&c__[(cibits_1.nelec + 1) * c_dim1 + 1], norbs, &nati, &wmat[1], &
fmat[1], &hmat[1], &fmat[1]);
i__1 = cibits_1.nmos;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = cibits_1.nmos;
for (j = 1; j <= i__2; ++j) {
i__3 = cibits_1.nmos;
for (k = 1; k <= i__3; ++k) {
i__4 = cibits_1.nmos;
for (l = 1; l <= i__4; ++l) {
/* L70: */
xyijkl_1.xy[i__ + (j + (k + (l << 3) << 3) << 3) - 585] *=
step;
}
}
}
}
/* BUILD THE C.I MATRIX DERIVATIVE, STORED IN WMAT. */
mecid_(&fd[lcut - cibits_1.nelec], &gse, vector_1.eigb, &work[work_offset]
);
if (debug) {
s_wsle(&io___22);
do_lio(&c__9, &c__1, " GSE:", (ftnlen)5);
do_lio(&c__5, &c__1, (char *)&gse, (ftnlen)sizeof(doublereal));
e_wsle();
/* # WRITE(6,*)' EIGB:',(EIGB(I),I=1,10) */
/* # WRITE(6,*)' WORK:',(WORK(I,1),I=1,10) */
}
mecih_(&work[work_offset], &wmat[1], &cibits_1.nmos, &cibits_1.lab);
/* NON-RELAXED C.I CONTRIBUTION TO THE ENERGY DERIVATIVE. */
supdot_(&work[work_offset], &wmat[1], civect_1.conf, &cibits_1.lab, &c__1)
;
*grad = (*grad + dot_(civect_1.conf, &work[work_offset], &cibits_1.lab)) *
23.061;
if (debug) {
io___23.ciunit = iprt;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&(*number), (ftnlen)sizeof(integer));
e_wsfe();
io___24.ciunit = iprt;
s_wsfe(&io___24);
e_wsfe();
io___25.ciunit = iprt;
s_wsfe(&io___25);
i__4 = cibits_1.nmos;
for (i__ = 1; i__ <= i__4; ++i__) {
do_fio(&c__1, (char *)&fd[lcut - 1 + i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
io___26.ciunit = iprt;
s_wsfe(&io___26);
e_wsfe();
i__4 = cibits_1.nmos;
for (i__ = 1; i__ <= i__4; ++i__) {
i__3 = i__;
for (j = 1; j <= i__3; ++j) {
i__2 = i__;
for (k = 1; k <= i__2; ++k) {
ll = k;
if (k == i__) {
ll = j;
}
i__1 = ll;
for (l = 1; l <= i__1; ++l) {
/* L80: */
io___28.ciunit = iprt;
s_wsfe(&io___28);
i__5 = cibits_1.nelec + i__;
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
i__6 = cibits_1.nelec + j;
do_fio(&c__1, (char *)&i__6, (ftnlen)sizeof(integer));
i__7 = cibits_1.nelec + k;
do_fio(&c__1, (char *)&i__7, (ftnlen)sizeof(integer));
i__8 = cibits_1.nelec + l;
do_fio(&c__1, (char *)&i__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&xyijkl_1.xy[i__ + (j + (k + (l
<< 3) << 3) << 3) - 585], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
}
}
io___29.ciunit = iprt;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&(*grad), (ftnlen)sizeof(doublereal));
e_wsfe();
timer_("AFTER DERI1", (ftnlen)11);
}
return 0;
} /* deri1_ */
