integer nv2inigmsx_(integer *ifunc, integer *iparms)
{
/* System generated locals */
integer ret_val;
char ch__1[4];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer i__;
extern /* Character */ VOID clit_(char *, ftnlen, integer *);
static char form[5];
extern /* Subroutine */ int movc_(integer *, integer *, integer *, char *,
integer *, ftnlen);
static char cparms[1*3200];
static integer offset1, offset2;
extern /* Subroutine */ int decode_oa_block__(char *, char *, ftnlen,
ftnlen);
/* Parameter adjustments */
--iparms;
/* Function Body */
if (*ifunc == 1) {
offset1 = 4;
offset2 = 0;
movc_(&c__504, &iparms[1], &offset1, cparms, &offset2, (ftnlen)1);
offset1 += 508;
offset2 += 504;
for (i__ = 1; i__ <= 4; ++i__) {
movc_(&c__508, &iparms[1], &offset1, cparms, &offset2, (ftnlen)1);
offset1 += 512;
offset2 += 508;
/* L100: */
}
s_copy(form, "short", (ftnlen)5, (ftnlen)5);
decode_oa_block__(cparms, form, (ftnlen)1, (ftnlen)5);
} else if (*ifunc == 2) {
clit_(ch__1, (ftnlen)4, &iparms[1]);
if (i_indx(ch__1, "XY", (ftnlen)4, (ftnlen)2) != 0) {
gmsnavcomgmsxnv2_1.navtype = 1;
}
clit_(ch__1, (ftnlen)4, &iparms[1]);
if (i_indx(ch__1, "LL", (ftnlen)4, (ftnlen)2) != 0) {
gmsnavcomgmsxnv2_1.navtype = 2;
}
}
ret_val = 0;
return ret_val;
} /* nv2inigmsx_ */
integer nv3inimsat_(integer *ifunc, integer *iparms)
{
/* System generated locals */
integer ret_val;
char ch__1[4];
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern integer lit_(char *, ftnlen);
extern /* Character */ VOID clit_(char *, ftnlen, integer *);
extern /* Subroutine */ int movw_(integer *, integer *, integer *);
extern real flalo_(integer *);
/* Parameter adjustments */
--iparms;
/* Function Body */
if (*ifunc == 1) {
if (iparms[1] != lit_("MSAT", (ftnlen)4)) {
ret_val = -1;
return ret_val;
}
movw_(&c__3, &iparms[4], polyxxmsatnv3_1.ioff);
metxxxmsatnv3_1.h__ = 35785.845000000001f;
metxxxmsatnv3_1.re = 6378.155f;
metxxxmsatnv3_1.a = .0033670033670033669f;
metxxxmsatnv3_1.rp = metxxxmsatnv3_1.re / (metxxxmsatnv3_1.a + 1.f);
metxxxmsatnv3_1.pi = 3.141592653f;
metxxxmsatnv3_1.cdr = metxxxmsatnv3_1.pi / 180.f;
metxxxmsatnv3_1.crd = 180.f / metxxxmsatnv3_1.pi;
metxxxmsatnv3_1.lpsi2 = 1;
metxxxmsatnv3_1.deltax = .0071999999999999998f;
metxxxmsatnv3_1.deltay = .0071999999999999998f;
metxxxmsatnv3_1.rflon = 0.f;
polyxxmsatnv3_1.sublon = flalo_(&iparms[7]);
} else if (*ifunc == 2) {
clit_(ch__1, (ftnlen)4, &iparms[1]);
if (i_indx(ch__1, "XY", (ftnlen)4, (ftnlen)2) != 0) {
metxxxmsatnv3_1.ic = 1;
}
clit_(ch__1, (ftnlen)4, &iparms[1]);
if (i_indx(ch__1, "LL", (ftnlen)4, (ftnlen)2) != 0) {
metxxxmsatnv3_1.ic = 2;
}
}
ret_val = 0;
return ret_val;
} /* nv3inimsat_ */
/* Subroutine */ int getval_(char *line, doublereal *x, char *t, ftnlen
line_len, ftnlen t_len)
{
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer i__;
static char ch1[1], ch2[1];
extern doublereal reada_(char *, integer *, ftnlen);
*(unsigned char *)ch1 = *(unsigned char *)line;
*(unsigned char *)ch2 = *(unsigned char *)&line[1];
if ((*(unsigned char *)ch1 < 'A' || *(unsigned char *)ch1 > 'Z') && (*(
unsigned char *)ch2 < 'A' || *(unsigned char *)ch2 > 'Z')) {
/* IS A NUMBER */
*x = reada_(line, &c__1, (ftnlen)80);
s_copy(t, " ", (ftnlen)12, (ftnlen)1);
} else {
i__ = i_indx(line, " ", (ftnlen)80, (ftnlen)1);
s_copy(t, line, (ftnlen)12, i__);
*x = -999.;
}
return 0;
} /* getval_ */
/* Subroutine */ int timer_(char *a, ftnlen a_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
doublereal d__1, d__2;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *,
ftnlen, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_wsfe(void);
/* Local variables */
static doublereal t0, t1, t2;
extern doublereal second_(void);
/* Fortran I/O blocks */
static cilist io___5 = { 0, 6, 0, "(2X,A,A,F7.2,A,F8.2)", 0 };
static cilist io___6 = { 0, 6, 0, "(40X,'TIME LOST:',F7.2)", 0 };
if (first) {
/* DEFINE THE ZERO OF TIME */
t0 = second_();
t1 = t0;
first = FALSE_;
}
/* THE ACT OF CALLING THIS ROUTINE COSTS 0.026 SECONDS */
t0 += .026;
t2 = second_();
if (i_indx(a, "BEF", a_len, (ftnlen)3) == 0 && s_cmp(a, " ", a_len, (
ftnlen)1) != 0) {
s_wsfe(&io___5);
do_fio(&c__1, a, a_len);
do_fio(&c__1, " INTERVAL:", (ftnlen)10);
d__1 = t2 - t1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, " INTEGRAL:", (ftnlen)10);
d__2 = t2 - t0;
do_fio(&c__1, (char *)&d__2, (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
s_wsfe(&io___6);
d__1 = t2 - t1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
}
t1 = t2 + .026;
return 0;
} /* timer_ */
integer nv2inimsgt_(integer *ifunc, integer *iparms)
{
/* System generated locals */
integer ret_val;
char ch__1[4];
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern integer lit_(char *, ftnlen);
extern /* Character */ VOID clit_(char *, ftnlen, integer *);
/* Parameter adjustments */
--iparms;
/* Function Body */
msgmsgtnv2_1.itype = 0;
ret_val = 0;
if (*ifunc == 1) {
if (iparms[1] != lit_("MSGT", (ftnlen)4)) {
ret_val = -1;
return ret_val;
}
nvparammsgtnv2_1.loff = iparms[2];
nvparammsgtnv2_1.coff = iparms[3];
nvparammsgtnv2_1.lfac = iparms[4];
nvparammsgtnv2_1.cfac = iparms[5];
} else if (*ifunc == 2) {
clit_(ch__1, (ftnlen)4, &iparms[1]);
if (i_indx(ch__1, "XY", (ftnlen)4, (ftnlen)2) != 0) {
msgmsgtnv2_1.itype = 1;
}
clit_(ch__1, (ftnlen)4, &iparms[1]);
if (i_indx(ch__1, "LL", (ftnlen)4, (ftnlen)2) != 0) {
msgmsgtnv2_1.itype = 2;
}
}
return ret_val;
} /* nv2inimsgt_ */
/* $Procedure REPMD ( Replace marker with double precision number ) */
/* Subroutine */ int repmd_(char *in, char *marker, doublereal *value,
integer *sigdig, char *out, ftnlen in_len, ftnlen marker_len, ftnlen
out_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int zzrepsub_(char *, integer *, integer *, char *
, char *, ftnlen, ftnlen, ftnlen), dpstr_(doublereal *, integer *,
char *, ftnlen);
integer mrknbf, subnbf;
extern integer lastnb_(char *, ftnlen);
integer mrknbl, subnbl;
extern integer frstnb_(char *, ftnlen);
integer mrkpsb, mrkpse;
char substr[23];
/* $ Abstract */
/* Replace a marker with a double precision number. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CHARACTER */
/* CONVERSION */
/* STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* IN I Input string. */
/* MARKER I Marker to be replaced. */
/* VALUE I Replacement value. */
/* SIGDIG I Significant digits in replacement text. */
/* OUT O Output string. */
/* MAXLDP P Maximum length of a DP number. */
/* $ Detailed_Input */
/* IN is an arbitrary character string. */
/* MARKER is an arbitrary character string. The first */
/* occurrence of MARKER in the input string is */
/* to be replaced by VALUE. */
/* Leading and trailing blanks in MARKER are NOT */
/* significant. In particular, no substitution is */
/* performed if MARKER is blank. */
/* VALUE is an arbitrary double precision number. */
/* SIGDIG is the number of significant digits with */
/* which VALUE is to be represented. SIGDIG */
/* must be greater than zero and less than 15. */
/* $ Detailed_Output */
/* OUT is the string obtained by substituting the text */
/* representation of VALUE for the first occurrence */
/* of MARKER in the input string. */
/* The text representation of VALUE is in scientific */
/* notation, having the number of significant digits */
/* specified by SIGDIG. The representation of VALUE */
/* is produced by the routine DPSTR; see that routine */
/* for details concerning the representation of */
/* double precision numbers. */
/* OUT and IN must be identical or disjoint. */
/* $ Parameters */
/* MAXLDP is the maximum expected length of the text */
/* representation of a double precision number. */
/* 23 characters are sufficient to hold any result */
/* returned by DPSTR. (See $Restrictions.) */
/* $ Exceptions */
/* Error Free. */
/* 1) If OUT does not have sufficient length to accommodate the */
/* result of the substitution, the result will be truncated on */
/* the right. */
/* 2) If MARKER is blank, or if MARKER is not a substring of IN, */
/* no substitution is performed. (OUT and IN are identical.) */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is one of a family of related routines for inserting values */
/* into strings. They are typically to construct messages that */
/* are partly fixed, and partly determined at run time. For example, */
/* a message like */
/* 'Fifty-one pictures were found in directory [USER.DATA].' */
/* might be constructed from the fixed string */
/* '#1 pictures were found in directory #2.' */
/* by the calls */
/* CALL REPMCT ( STRING, '#1', N_PICS, 'C', STRING ) */
/* CALL REPMC ( STRING, '#2', DIR_NAME, STRING ) */
/* which substitute the cardinal text 'Fifty-one' and the character */
/* string '[USER.DATA]' for the markers '#1' and '#2' respectively. */
/* The complete list of routines is shown below. */
/* REPMC ( Replace marker with character string value ) */
/* REPMD ( Replace marker with double precision value ) */
/* REPMF ( Replace marker with formatted d.p. value ) */
/* REPMI ( Replace marker with integer value ) */
/* REPMCT ( Replace marker with cardinal text) */
/* REPMOT ( Replace marker with ordinal text ) */
/* $ Examples */
/* 1. Let */
/* IN = 'Invalid operation value. The value was #.' */
/* Then following the call, */
/* CALL REPMD ( IN, '#', 5.0D1, 2, IN ) */
/* IN is */
/* 'Invalid operation value. The value was 5.0E+01.' */
/* 2. Let */
/* IN = 'Left endpoint exceeded right endpoint. The left */
/* endpoint was: XX. The right endpoint was: XX.' */
/* Then following the call, */
/* CALL REPMD ( IN, ' XX ', -5.2D-9, 3, OUT ) */
/* OUT is */
/* 'Left endpoint exceeded right endpoint. The left */
/* endpoint was: -5.20E-09. The right endpoint was: XX.' */
/* 3. Let */
/* IN = 'Invalid operation value. The value was #.' */
/* Then following the call */
/* CALL REPMD ( IN, '#', 5.0D1, 100, IN ) */
/* IN is */
/* 'Invalid operation value. The value was */
/* 5.0000000000000E+01.' */
/* Note that even though 100 digits of precision were requested, */
/* only 14 were returned. */
/* 4. Let */
/* NUM = 23 */
/* CHANCE = 'fair' */
/* SCORE = 4.665D0 */
/* Then following the sequence of calls, */
/* CALL REPMI ( 'There are & routines that have a ' // */
/* . '& chance of meeting your needs.' // */
/* . 'The maximum score was &.', */
/* . '&', */
/* . NUM, */
/* . MSG ) */
/* CALL REPMC ( MSG, '&', CHANCE, MSG ) */
/* CALL REPMD ( MSG, '&', SCORE, 4, MSG ) */
/* MSG is */
/* 'There are 23 routines that have a fair chance of */
/* meeting your needs. The maximum score was 4.665E+00.' */
/* $ Restrictions */
/* 1) The maximum number of significant digits returned is 14. */
/* 2) This routine makes explicit use of the format of the string */
/* returned by DPSTR; should that routine change, substantial */
/* work may be required to bring this routine back up to snuff. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.2.0, 23-SEP-2013 (BVS) */
/* Minor efficiency update: the routine now looks up the first */
/* and last non-blank characters only once. */
/* - SPICELIB Version 1.1.0, 15-AUG-2002 (WLT) */
/* The routine is now error free. */
/* - 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, 30-AUG-1990 (NJB) (IMU) */
/* -& */
/* $ Index_Entries */
/* replace marker with d.p. number */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* If MARKER is blank, no substitution is possible. */
if (s_cmp(marker, " ", marker_len, (ftnlen)1) == 0) {
s_copy(out, in, out_len, in_len);
return 0;
}
/* Locate the leftmost occurrence of MARKER, if there is one */
/* (ignoring leading and trailing blanks). If MARKER is not */
/* a substring of IN, no substitution can be performed. */
mrknbf = frstnb_(marker, marker_len);
mrknbl = lastnb_(marker, marker_len);
mrkpsb = i_indx(in, marker + (mrknbf - 1), in_len, mrknbl - (mrknbf - 1));
if (mrkpsb == 0) {
s_copy(out, in, out_len, in_len);
return 0;
}
mrkpse = mrkpsb + mrknbl - mrknbf;
/* Okay, MARKER is non-blank and has been found. Convert the */
/* number to text, and substitute the text for the marker. */
dpstr_(value, sigdig, substr, (ftnlen)23);
subnbf = frstnb_(substr, (ftnlen)23);
subnbl = lastnb_(substr, (ftnlen)23);
if (subnbf != 0 && subnbl != 0) {
zzrepsub_(in, &mrkpsb, &mrkpse, substr + (subnbf - 1), out, in_len,
subnbl - (subnbf - 1), out_len);
}
return 0;
} /* repmd_ */
/* Subroutine */ int getgeg_(integer *iread, integer *labels, doublereal *geo,
integer *na, integer *nb, integer *nc, doublereal *ams, integer *
natoms, logical *int__)
{
/* Initialized data */
static char elemnt[2*107] = " H" "HE" "LI" "BE" " B" " C" " N" " O" " F"
"NE" "NA" "MG" "AL" "SI" " P" " S" "CL" "AR" "K " "CA" "SC" "TI"
" V" "CR" "MN" "FE" "CO" "NI" "CU" "ZN" "GA" "GE" "AS" "SE" "BR"
"KR" "RB" "SR" " Y" "ZR" "NB" "MO" "TC" "RU" "RH" "PD" "AG" "CD"
"IN" "SN" "SB" "TE" " I" "XE" "CS" "BA" "LA" "CE" "PR" "ND" "PM"
"SM" "EU" "GD" "TB" "DY" "HO" "ER" "TM" "YB" "LU" "HF" "TA" " W"
"RE" "OS" "IR" "PT" "AU" "HG" "TL" "PB" "BI" "PO" "AT" "RN" "FR"
"RA" "AC" "TH" "PA" "U " "NP" "PU" "AM" "CM" "BK" "CF" "XX" "FM"
"MD" "CB" "++" " +" "--" " -" "TV";
/* System generated locals */
address a__1[2], a__2[2];
integer i__1, i__2, i__3[2], i__4[2];
char ch__1[81], ch__2[3], ch__3[29];
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
double asin(doublereal);
/* Local variables */
static integer i__, j, k, l, n;
static doublereal sum;
static integer lgeo[300] /* was [3][100] */;
static char line[80], tgeo[12*3*100];
static integer ivar, kerr, merr, nerr, lerr;
extern doublereal reada_(char *, integer *, ftnlen);
static integer iline, numat;
static doublereal degree;
static logical leadsp;
extern /* Subroutine */ int getval_(char *, doublereal *, char *, ftnlen,
ftnlen);
static integer nvalue, istart[20];
static char string[80];
static integer maxtxt;
/* Fortran I/O blocks */
static cilist io___5 = { 1, 0, 1, "(A)", 0 };
static cilist io___15 = { 0, 6, 0, "(2A)", 0 };
static cilist io___16 = { 0, 6, 0, "(' FOR ATOM',I4,' ISOTOPIC MASS:' "
" ,F15.5)", 0 };
static cilist io___21 = { 1, 0, 1, "(A)", 0 };
static cilist io___27 = { 0, 6, 0, "(A)", 0 };
static cilist io___28 = { 0, 6, 0, "(A)", 0 };
static cilist io___29 = { 0, 6, 0, "(2A)", 0 };
static cilist io___30 = { 0, 6, 0, "(2A)", 0 };
static cilist io___31 = { 0, 6, 0, "(2A)", 0 };
static cilist io___32 = { 0, 6, 0, "(I4,A)", 0 };
static cilist io___33 = { 0, 6, 0, "(A,I3,A)", 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 */
/* Parameter adjustments */
--ams;
--nc;
--nb;
--na;
geo -= 4;
--labels;
/* Function Body */
nerr = 0;
*int__ = TRUE_;
numat = 0;
na[1] = 0;
nb[1] = 0;
nc[1] = 0;
nb[2] = 0;
nc[2] = 0;
nc[3] = 0;
maxtxt = 0;
for (*natoms = 1; *natoms <= 100; ++(*natoms)) {
io___5.ciunit = *iread;
i__1 = s_rsfe(&io___5);
if (i__1 != 0) {
goto L70;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L70;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L70;
}
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) == 0) {
goto L70;
}
/* SEE IF TEXT IS ASSOCIATED WITH THIS ELEMENT */
i__ = i_indx(line, "(", (ftnlen)80, (ftnlen)1);
if (i__ != 0) {
/* YES, ELEMENT IS LABELLED. */
k = i_indx(line, ")", (ftnlen)80, (ftnlen)1);
s_copy(atomtx_1.txtatm + (*natoms - 1 << 3), line + (i__ - 1), (
ftnlen)8, k - (i__ - 1));
/* Computing MAX */
i__1 = maxtxt, i__2 = k - i__ + 1;
maxtxt = max(i__1,i__2);
i__1 = k;
/* Writing concatenation */
i__3[0] = i__ - 1, a__1[0] = line;
i__3[1] = 80 - i__1, a__1[1] = line + i__1;
s_cat(string, a__1, i__3, &c__2, (ftnlen)80);
s_copy(line, string, (ftnlen)80, (ftnlen)80);
} else {
s_copy(atomtx_1.txtatm + (*natoms - 1 << 3), " ", (ftnlen)8, (
ftnlen)1);
}
/* *********************************************************************** */
for (i__ = 1; i__ <= 80; ++i__) {
iline = *(unsigned char *)&line[i__ - 1];
if (iline >= 'a' && iline <= 'z') {
*(unsigned char *)&line[i__ - 1] = (char) (iline + 'A' - 'a');
}
/* L10: */
}
/* *********************************************************************** */
nvalue = 0;
leadsp = TRUE_;
for (i__ = 1; i__ <= 80; ++i__) {
if (leadsp && *(unsigned char *)&line[i__ - 1] != ' ') {
++nvalue;
istart[nvalue - 1] = i__;
}
leadsp = *(unsigned char *)&line[i__ - 1] == ' ';
/* L20: */
}
for (j = 1; j <= 107; ++j) {
/* L30: */
i__1 = istart[0] - 1;
/* Writing concatenation */
i__3[0] = 1, a__1[0] = " ";
i__3[1] = istart[0] + 2 - i__1, a__1[1] = line + i__1;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)81);
/* Writing concatenation */
i__4[0] = 2, a__2[0] = elemnt + (j - 1 << 1);
i__4[1] = 1, a__2[1] = " ";
s_cat(ch__2, a__2, i__4, &c__2, (ftnlen)3);
if (i_indx(ch__1, ch__2, istart[0] + 2 - i__1 + 1, (ftnlen)3) !=
0) {
goto L40;
}
}
i__1 = istart[0] - 1;
/* Writing concatenation */
i__3[0] = 1, a__1[0] = " ";
i__3[1] = istart[0] + 2 - i__1, a__1[1] = line + i__1;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)81);
if (i_indx(ch__1, " X", istart[0] + 2 - i__1 + 1, (ftnlen)2) != 0) {
j = 99;
goto L40;
}
s_wsfe(&io___15);
do_fio(&c__1, " ELEMENT NOT RECOGNIZED: ", (ftnlen)25);
i__1 = istart[0] - 1;
do_fio(&c__1, line + i__1, istart[0] + 2 - i__1);
e_wsfe();
++nerr;
L40:
labels[*natoms] = j;
if (j != 99) {
++numat;
/* Computing MAX */
i__1 = istart[1] - 1;
atmass_1.atmass[numat - 1] = reada_(line, istart, (max(i__1,1)));
if (atmass_1.atmass[numat - 1] > 1e-15) {
s_wsfe(&io___16);
do_fio(&c__1, (char *)&(*natoms), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&atmass_1.atmass[numat - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
atmass_1.atmass[numat - 1] = ams[j];
}
/* # WRITE(6,*)NATOMS,NUMAT,ATMASS(NUMAT) */
}
s_copy(tgeo + (*natoms * 3 - 3) * 12, " ", (ftnlen)12, (ftnlen)1);
s_copy(tgeo + (*natoms * 3 - 2) * 12, " ", (ftnlen)12, (ftnlen)1);
s_copy(tgeo + (*natoms * 3 - 1) * 12, " ", (ftnlen)12, (ftnlen)1);
if (*natoms == 1) {
goto L50;
}
na[*natoms] = (integer) reada_(line, &istart[1], (ftnlen)80);
i__1 = istart[2] - 1;
getval_(line + i__1, &geo[*natoms * 3 + 1], tgeo + (*natoms * 3 - 3) *
12, 80 - i__1, (ftnlen)12);
if (*natoms == 2) {
goto L50;
}
nb[*natoms] = (integer) reada_(line, &istart[3], (ftnlen)80);
i__1 = istart[4] - 1;
getval_(line + i__1, &geo[*natoms * 3 + 2], tgeo + (*natoms * 3 - 2) *
12, 80 - i__1, (ftnlen)12);
if (*natoms == 3) {
goto L50;
}
nc[*natoms] = (integer) reada_(line, &istart[5], (ftnlen)80);
i__1 = istart[6] - 1;
getval_(line + i__1, &geo[*natoms * 3 + 3], tgeo + (*natoms * 3 - 1) *
12, 80 - i__1, (ftnlen)12);
L50:
/* L60: */
;
}
L70:
--(*natoms);
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L80: */
lgeo[j + i__ * 3 - 4] = -1;
}
}
ivar = -1;
geovar_1.nvar = 0;
geosym_1.ndep = 0;
kerr = 0;
L90:
io___21.ciunit = *iread;
i__1 = s_rsfe(&io___21);
if (i__1 != 0) {
goto L180;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L180;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L180;
}
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) == 0) {
if (ivar == -1) {
merr = 0;
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L100: */
if (geo[j + i__ * 3] < -998.) {
++merr;
}
}
/* L110: */
}
/* IF ALL SYMBOLS ARE DEFINED, THEN DO NOT READ 'FIXED' SYMBOLS */
if (merr == 0) {
goto L180;
}
ivar = geovar_1.nvar;
goto L90;
} else {
goto L180;
}
}
/* *********************************************************************** */
for (i__ = 1; i__ <= 80; ++i__) {
iline = *(unsigned char *)&line[i__ - 1];
if (iline >= 'a' && iline <= 'z') {
*(unsigned char *)&line[i__ - 1] = (char) (iline + 'A' - 'a');
}
/* L120: */
}
/* *********************************************************************** */
for (i__ = 1; i__ <= 80; ++i__) {
/* L130: */
if (*(unsigned char *)&line[i__ - 1] != ' ') {
goto L140;
}
}
L140:
i__1 = i__ + 12;
for (l = i__; l <= i__1; ++l) {
/* L150: */
if (*(unsigned char *)&line[l - 1] == ' ') {
goto L160;
}
}
L160:
sum = reada_(line, &l, (ftnlen)80);
n = 0;
lerr = 0;
i__1 = *natoms;
for (j = 1; j <= i__1; ++j) {
for (k = 1; k <= 3; ++k) {
if (s_cmp(tgeo + (k + j * 3 - 4) * 12, line + (i__ - 1), (ftnlen)
12, l - (i__ - 1)) == 0 || s_cmp(tgeo + ((k + j * 3 - 4) *
12 + 1), line + (i__ - 1), (ftnlen)11, l - (i__ - 1)) ==
0 && *(unsigned char *)&tgeo[(k + j * 3 - 4) * 12] == '-')
{
if (lgeo[k + j * 3 - 4] != -1) {
lerr = 1;
}
++lgeo[k + j * 3 - 4];
++n;
geo[k + j * 3] = sum;
if (n == 1) {
++geovar_1.nvar;
geovar_1.loc[(geovar_1.nvar << 1) - 2] = j;
geovar_1.loc[(geovar_1.nvar << 1) - 1] = k;
geovar_1.xparam[geovar_1.nvar - 1] = sum;
s_copy(simbol_1.simbol + (geovar_1.nvar - 1) * 10, tgeo +
(k + j * 3 - 4) * 12, (ftnlen)10, (ftnlen)12);
if (*(unsigned char *)&simbol_1.simbol[(geovar_1.nvar - 1)
* 10] == '-') {
s_wsfe(&io___27);
do_fio(&c__1, " NEGATIVE SYMBOLICS MUST BE PRECEEDED"
" BY THE POSITIVE EQUIVALENT", (ftnlen)65);
e_wsfe();
s_wsfe(&io___28);
/* Writing concatenation */
i__3[0] = 19, a__1[0] = " FAULTY SYMBOLIC: ";
i__3[1] = 10, a__1[1] = simbol_1.simbol + (
geovar_1.nvar - 1) * 10;
s_cat(ch__3, a__1, i__3, &c__2, (ftnlen)29);
do_fio(&c__1, ch__3, (ftnlen)29);
e_wsfe();
s_stop("", (ftnlen)0);
}
}
if (n > 1) {
++geosym_1.ndep;
geosym_1.locpar[geosym_1.ndep - 1] = geovar_1.loc[(
geovar_1.nvar << 1) - 2];
geosym_1.idepfn[geosym_1.ndep - 1] = geovar_1.loc[(
geovar_1.nvar << 1) - 1];
if (*(unsigned char *)&tgeo[(k + j * 3 - 4) * 12] == '-')
{
geosym_1.idepfn[geosym_1.ndep - 1] = 14;
if (geovar_1.loc[(geovar_1.nvar << 1) - 1] != 3) {
++kerr;
s_wsfe(&io___29);
do_fio(&c__1, " ONLY DIHEDRAL SYMBOLICS CAN BE P"
"RECEEDED BY A \"-\" SIGN", (ftnlen)55);
e_wsfe();
}
}
geosym_1.locdep[geosym_1.ndep - 1] = j;
}
}
/* L170: */
}
}
kerr += lerr;
if (lerr == 1) {
s_wsfe(&io___30);
do_fio(&c__1, " THE FOLLOWING SYMBOL HAS BEEN DEFINED MORE THAN ONCE:"
, (ftnlen)54);
do_fio(&c__1, line + (i__ - 1), l - (i__ - 1));
e_wsfe();
++nerr;
}
if (n == 0) {
s_wsfe(&io___31);
do_fio(&c__1, " THE FOLLOWING SYMBOLIC WAS NOT USED:", (ftnlen)37);
do_fio(&c__1, line + (i__ - 1), l - (i__ - 1));
e_wsfe();
++nerr;
}
goto L90;
L180:
merr = 0;
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L190: */
if (geo[j + i__ * 3] < -998.) {
++merr;
}
}
/* # WRITE(6,'(2X,A,3F12.6,3I4)')ELEMNT(LABELS(I)), */
/* # 1(GEO(J,I),J=1,3), NA(I), NB(I), NC(I) */
/* L200: */
}
if (merr != 0) {
s_wsfe(&io___32);
do_fio(&c__1, (char *)&merr, (ftnlen)sizeof(integer));
do_fio(&c__1, " GEOMETRY VARIABLES WERE NOT DEFINED", (ftnlen)36);
e_wsfe();
}
if (merr + kerr + nerr != 0) {
s_wsfe(&io___33);
do_fio(&c__1, " THE GEOMETRY DATA-SET CONTAINED", (ftnlen)32);
i__1 = merr + kerr + nerr;
do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
do_fio(&c__1, " ERRORS", (ftnlen)7);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* SORT PARAMETERS TO BE OPTIMIZED INTO INCREASING ORDER OF ATOMS */
if (ivar != -1) {
geovar_1.nvar = ivar;
}
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
j = 100000;
i__2 = geovar_1.nvar;
for (l = i__; l <= i__2; ++l) {
if (j > (geovar_1.loc[(l << 1) - 2] << 2) + geovar_1.loc[(l << 1)
- 1]) {
k = l;
j = (geovar_1.loc[(l << 1) - 2] << 2) + geovar_1.loc[(l << 1)
- 1];
}
/* L210: */
}
s_copy(string, simbol_1.simbol + (i__ - 1) * 10, (ftnlen)10, (ftnlen)
10);
s_copy(simbol_1.simbol + (i__ - 1) * 10, simbol_1.simbol + (k - 1) *
10, (ftnlen)10, (ftnlen)10);
s_copy(simbol_1.simbol + (k - 1) * 10, string, (ftnlen)10, (ftnlen)80)
;
sum = geovar_1.xparam[i__ - 1];
geovar_1.xparam[i__ - 1] = geovar_1.xparam[k - 1];
geovar_1.xparam[k - 1] = sum;
for (j = 1; j <= 2; ++j) {
l = geovar_1.loc[j + (i__ << 1) - 3];
geovar_1.loc[j + (i__ << 1) - 3] = geovar_1.loc[j + (k << 1) - 3];
/* L220: */
geovar_1.loc[j + (k << 1) - 3] = l;
}
/* L230: */
}
/* # IF(NVAR.NE.0)WRITE(6,'(//,'' PARAMETERS TO BE OPTIMIZED'')') */
degree = asin(1.) / 90;
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* # WRITE(6,'(2I6,F12.6)')LOC(1,I),LOC(2,I),XPARAM(I) */
/* L240: */
if (geovar_1.loc[(i__ << 1) - 1] != 1) {
geovar_1.xparam[i__ - 1] *= degree;
}
}
/* # IF(NDEP.NE.0)WRITE(6,'(//,'' SYMMETRY FUNCTIONS '')') */
/* # DO 28 I=1,NDEP */
/* # 28 WRITE(6,'(3I6)')LOCPAR(I),IDEPFN(I),LOCDEP(I) */
*(unsigned char *)atomtx_1.ltxt = (char) maxtxt;
return 0;
} /* getgeg_ */
/* DECK XERPRN */
/* Subroutine */ int xerprn_(char *prefix, integer *npref, char *messg,
integer *nwrap, ftnlen prefix_len, ftnlen messg_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
static integer i__, n, iu[5];
static char cbuff[148];
static integer lpref, nextc, lwrap, nunit;
extern integer i1mach_(integer *);
static integer lpiece, idelta, lenmsg;
extern /* Subroutine */ int xgetua_(integer *, integer *);
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, "(A)", 0 };
static cilist io___13 = { 0, 0, 0, "(A)", 0 };
/* ***BEGIN PROLOGUE XERPRN */
/* ***SUBSIDIARY */
/* ***PURPOSE Print error messages processed by XERMSG. */
/* ***LIBRARY SLATEC (XERROR) */
/* ***CATEGORY R3C */
/* ***TYPE ALL (XERPRN-A) */
/* ***KEYWORDS ERROR MESSAGES, PRINTING, XERROR */
/* ***AUTHOR Fong, Kirby, (NMFECC at LLNL) */
/* ***DESCRIPTION */
/* This routine sends one or more lines to each of the (up to five) */
/* logical units to which error messages are to be sent. This routine */
/* is called several times by XERMSG, sometimes with a single line to */
/* print and sometimes with a (potentially very long) message that may */
/* wrap around into multiple lines. */
/* PREFIX Input argument of type CHARACTER. This argument contains */
/* characters to be put at the beginning of each line before */
/* the body of the message. No more than 16 characters of */
/* PREFIX will be used. */
/* NPREF Input argument of type INTEGER. This argument is the number */
/* of characters to use from PREFIX. If it is negative, the */
/* intrinsic function LEN is used to determine its length. If */
/* it is zero, PREFIX is not used. If it exceeds 16 or if */
/* LEN(PREFIX) exceeds 16, only the first 16 characters will be */
/* used. If NPREF is positive and the length of PREFIX is less */
/* than NPREF, a copy of PREFIX extended with blanks to length */
/* NPREF will be used. */
/* MESSG Input argument of type CHARACTER. This is the text of a */
/* message to be printed. If it is a long message, it will be */
/* broken into pieces for printing on multiple lines. Each line */
/* will start with the appropriate prefix and be followed by a */
/* piece of the message. NWRAP is the number of characters per */
/* piece; that is, after each NWRAP characters, we break and */
/* start a new line. In addition the characters '$$' embedded */
/* in MESSG are a sentinel for a new line. The counting of */
/* characters up to NWRAP starts over for each new line. The */
/* value of NWRAP typically used by XERMSG is 72 since many */
/* older error messages in the SLATEC Library are laid out to */
/* rely on wrap-around every 72 characters. */
/* NWRAP Input argument of type INTEGER. This gives the maximum size */
/* piece into which to break MESSG for printing on multiple */
/* lines. An embedded '$$' ends a line, and the count restarts */
/* at the following character. If a line break does not occur */
/* on a blank (it would split a word) that word is moved to the */
/* next line. Values of NWRAP less than 16 will be treated as */
/* 16. Values of NWRAP greater than 132 will be treated as 132. */
/* The actual line length will be NPREF + NWRAP after NPREF has */
/* been adjusted to fall between 0 and 16 and NWRAP has been */
/* adjusted to fall between 16 and 132. */
/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */
/* Error-handling Package, SAND82-0800, Sandia */
/* Laboratories, 1982. */
/* ***ROUTINES CALLED I1MACH, XGETUA */
/* ***REVISION HISTORY (YYMMDD) */
/* 880621 DATE WRITTEN */
/* 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF */
/* JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK */
/* THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE */
/* SLASH CHARACTER IN FORMAT STATEMENTS. */
/* 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO */
/* STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK */
/* LINES TO BE PRINTED. */
/* 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF */
/* CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. */
/* 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. */
/* 891214 Prologue converted to Version 4.0 format. (WRB) */
/* 900510 Added code to break messages between words. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE XERPRN */
/* ***FIRST EXECUTABLE STATEMENT XERPRN */
xgetua_(iu, &nunit);
/* A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD */
/* ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD */
/* ERROR MESSAGE UNIT. */
n = i1mach_(&c__4);
i__1 = nunit;
for (i__ = 1; i__ <= i__1; ++i__) {
if (iu[i__ - 1] == 0) {
iu[i__ - 1] = n;
}
/* L10: */
}
/* LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE */
/* BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING */
/* THE REST OF THIS ROUTINE. */
if (*npref < 0) {
lpref = i_len(prefix, prefix_len);
} else {
lpref = *npref;
}
lpref = min(16,lpref);
if (lpref != 0) {
s_copy(cbuff, prefix, lpref, prefix_len);
}
/* LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE */
/* TIME FROM MESSG TO PRINT ON ONE LINE. */
/* Computing MAX */
i__1 = 16, i__2 = min(132,*nwrap);
lwrap = max(i__1,i__2);
/* SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. */
lenmsg = i_len(messg, messg_len);
n = lenmsg;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*(unsigned char *)&messg[lenmsg - 1] != ' ') {
goto L30;
}
--lenmsg;
/* L20: */
}
L30:
/* IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. */
if (lenmsg == 0) {
i__1 = lpref;
s_copy(cbuff + i__1, " ", lpref + 1 - i__1, (ftnlen)1);
i__1 = nunit;
for (i__ = 1; i__ <= i__1; ++i__) {
io___9.ciunit = iu[i__ - 1];
s_wsfe(&io___9);
do_fio(&c__1, cbuff, lpref + 1);
e_wsfe();
/* L40: */
}
return 0;
}
/* SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING */
/* STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. */
/* WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. */
/* WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. */
/* WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE */
/* INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE */
/* OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH */
/* OF THE SECOND ARGUMENT. */
/* THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE */
/* FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER */
/* OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT */
/* POSITION NEXTC. */
/* LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE */
/* REMAINDER OF THE CHARACTER STRING. LPIECE */
/* SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, */
/* WHICHEVER IS LESS. */
/* LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: */
/* NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE */
/* PRINT NOTHING TO AVOID PRODUCING UNNECESSARY */
/* BLANK LINES. THIS TAKES CARE OF THE SITUATION */
/* WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF */
/* EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE */
/* SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC */
/* SHOULD BE INCREMENTED BY 2. */
/* LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. */
/* ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 */
/* RESET LPIECE = LPIECE-1. NOTE THAT THIS */
/* PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. */
/* LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY */
/* AT THE END OF A LINE. */
nextc = 1;
L50:
lpiece = i_indx(messg + (nextc - 1), "$$", lenmsg - (nextc - 1), (ftnlen)
2);
if (lpiece == 0) {
/* THERE WAS NO NEW LINE SENTINEL FOUND. */
idelta = 0;
/* Computing MIN */
i__1 = lwrap, i__2 = lenmsg + 1 - nextc;
lpiece = min(i__1,i__2);
if (lpiece < lenmsg + 1 - nextc) {
for (i__ = lpiece + 1; i__ >= 2; --i__) {
i__1 = nextc + i__ - 2;
if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, (ftnlen)
1) == 0) {
lpiece = i__ - 1;
idelta = 1;
goto L54;
}
/* L52: */
}
}
L54:
i__1 = lpref;
s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1,
nextc + lpiece - 1 - (nextc - 1));
nextc = nextc + lpiece + idelta;
} else if (lpiece == 1) {
/* WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). */
/* DON'T PRINT A BLANK LINE. */
nextc += 2;
goto L50;
} else if (lpiece > lwrap + 1) {
/* LPIECE SHOULD BE SET DOWN TO LWRAP. */
idelta = 0;
lpiece = lwrap;
for (i__ = lpiece + 1; i__ >= 2; --i__) {
i__1 = nextc + i__ - 2;
if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, (ftnlen)1) ==
0) {
lpiece = i__ - 1;
idelta = 1;
goto L58;
}
/* L56: */
}
L58:
i__1 = lpref;
s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1,
nextc + lpiece - 1 - (nextc - 1));
nextc = nextc + lpiece + idelta;
} else {
/* IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. */
/* WE SHOULD DECREMENT LPIECE BY ONE. */
--lpiece;
i__1 = lpref;
s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1,
nextc + lpiece - 1 - (nextc - 1));
nextc = nextc + lpiece + 2;
}
/* PRINT */
i__1 = nunit;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = iu[i__ - 1];
s_wsfe(&io___13);
do_fio(&c__1, cbuff, lpref + lpiece);
e_wsfe();
/* L60: */
}
if (nextc <= lenmsg) {
goto L50;
}
return 0;
} /* xerprn_ */
/* $Procedure REPMCT ( Replace marker with cardinal text ) */
/* Subroutine */ int repmct_(char *in, char *marker, integer *value, char *
case__, char *out, ftnlen in_len, ftnlen marker_len, ftnlen case_len,
ftnlen out_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
char card[145];
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen),
chkin_(char *, ftnlen), ucase_(char *, char *, ftnlen, ftnlen),
errch_(char *, char *, ftnlen, ftnlen), ljust_(char *, char *,
ftnlen, ftnlen);
integer mrknbf;
extern integer lastnb_(char *, ftnlen);
integer mrknbl;
char tmpcas[1];
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen);
extern integer frstnb_(char *, ftnlen);
integer mrkpsb;
extern /* Subroutine */ int repsub_(char *, integer *, integer *, char *,
char *, ftnlen, ftnlen, ftnlen);
integer mrkpse;
extern /* Subroutine */ int setmsg_(char *, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int inttxt_(integer *, char *, ftnlen);
/* $ Abstract */
/* Replace a marker with the text representation of a */
/* cardinal number. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CHARACTER */
/* CONVERSION */
/* STRING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* IN I Input string. */
/* MARKER I Marker to be replaced. */
/* VALUE I Cardinal value. */
/* CASE I Case of replacement text. */
/* OUT O Output string. */
/* MAXLCN P Maximum length of a cardinal number. */
/* $ Detailed_Input */
/* IN is an arbitrary character string. */
/* MARKER is an arbitrary character string. The first */
/* occurrence of MARKER in the input string is */
/* to be replaced by the text representation of */
/* the cardinal number VALUE. */
/* Leading and trailing blanks in MARKER are NOT */
/* significant. In particular, no substitution is */
/* performed if MARKER is blank. */
/* VALUE is an arbitrary integer. */
/* CASE indicates the case of the replacement text. */
/* CASE may be any of the following: */
/* CASE Meaning Example */
/* ---- ----------- ----------------------- */
/* U, u Uppercase ONE HUNDRED FIFTY-THREE */
/* L, l Lowercase one hundred fifty-three */
/* C, c Capitalized One hundred fifty-three */
/* $ Detailed_Output */
/* OUT is the string obtained by substituting the text */
/* representation of the cardinal number VALUE for */
/* the first occurrence of MARKER in the input string. */
/* OUT and IN must be identical or disjoint. */
/* $ Parameters */
/* MAXLCN is the maximum expected length of any cardinal */
/* text. 145 characters are sufficient to hold the */
/* text representing any value in the range */
/* ( -10**12, 10**12 ) */
/* An example of a number whose text representation */
/* is of maximum length is */
/* - 777 777 777 777 */
/* $ Exceptions */
/* 1) If OUT does not have sufficient length to accommodate the */
/* result of the substitution, the result will be truncated on */
/* the right. */
/* 2) If MARKER is blank, or if MARKER is not a substring of IN, */
/* no substitution is performed. (OUT and IN are identical.) */
/* 3) If the value of CASE is not recognized, the error */
/* SPICE(INVALIDCASE) is signalled. OUT is not changed. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is one of a family of related routines for inserting values */
/* into strings. They are typically used to construct messages that */
/* are partly fixed, and partly determined at run time. For example, */
/* a message like */
/* 'Fifty-one pictures were found in directory [USER.DATA].' */
/* might be constructed from the fixed string */
/* '#1 pictures were found in directory #2.' */
/* by the calls */
/* CALL REPMCT ( STRING, '#1', NPICS, 'C', STRING ) */
/* CALL REPMC ( STRING, '#2', DIRNAM, STRING ) */
/* which substitute the cardinal text 'Fifty-one' and the character */
/* string '[USER.DATA]' for the markers '#1' and '#2' respectively. */
/* The complete list of routines is shown below. */
/* REPMC ( Replace marker with character string value ) */
/* REPMD ( Replace marker with double precision value ) */
/* REPMF ( Replace marker with formatted d.p. value ) */
/* REPMI ( Replace marker with integer value ) */
/* REPMCT ( Replace marker with cardinal text) */
/* REPMOT ( Replace marker with ordinal text ) */
/* $ Examples */
/* The following examples illustrate the use of REPMCT to */
/* replace a marker within a string with the cardinal text */
/* corresponding to an integer. */
/* Uppercase */
/* --------- */
/* Let */
/* MARKER = '#' */
/* IN = 'INVALID COMMAND. WORD # WAS NOT RECOGNIZED.' */
/* Then following the call, */
/* CALL REPMCT ( IN, '#', 5, 'U', IN ) */
/* IN is */
/* 'INVALID COMMAND. WORD FIVE WAS NOT RECOGNIZED.' */
/* Lowercase */
/* --------- */
/* Let */
/* MARKER = ' XX ' */
/* IN = 'Word XX of the XX sentence was misspelled.' */
/* Then following the call, */
/* CALL REPMCT ( IN, ' XX ', 5, 'L', OUT ) */
/* OUT is */
/* 'Word five of the XX sentence was misspelled.' */
/* Capitalized */
/* ----------- */
/* Let */
/* MARKER = ' XX ' */
/* IN = 'Name: YY. Rank: XX.' */
/* Then following the calls, */
/* CALL REPMC ( IN, 'YY', 'Moriarty', OUT ) */
/* CALL REPMCT ( OUT, 'XX', 1, 'C', OUT ) */
/* OUT is */
/* 'Name: Moriarty. Rank: One.' */
/* $ Restrictions */
/* 1) VALUE must be in the range accepted by subroutine INTTXT. */
/* This range is currently */
/* ( -10**12, 10**12 ) */
/* Note that the endpoints of the interval are excluded. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 21-SEP-2013 (BVS) */
/* Minor efficiency update: the routine now looks up the first */
/* and last non-blank characters only once. */
/* - 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, 30-AUG-1990 (NJB) (IMU) */
/* -& */
/* $ Index_Entries */
/* replace marker with cardinal text */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("REPMCT", (ftnlen)6);
}
/* Bail out if CASE is not recognized. */
ljust_(case__, tmpcas, (ftnlen)1, (ftnlen)1);
ucase_(tmpcas, tmpcas, (ftnlen)1, (ftnlen)1);
if (*(unsigned char *)tmpcas != 'U' && *(unsigned char *)tmpcas != 'L' &&
*(unsigned char *)tmpcas != 'C') {
setmsg_("Case (#) must be U, L, or C.", (ftnlen)28);
errch_("#", case__, (ftnlen)1, (ftnlen)1);
sigerr_("SPICE(INVALIDCASE)", (ftnlen)18);
chkout_("REPMCT", (ftnlen)6);
return 0;
}
/* If MARKER is blank, no substitution is possible. */
if (s_cmp(marker, " ", marker_len, (ftnlen)1) == 0) {
s_copy(out, in, out_len, in_len);
chkout_("REPMCT", (ftnlen)6);
return 0;
}
/* Locate the leftmost occurrence of MARKER, if there is one */
/* (ignoring leading and trailing blanks). If MARKER is not */
/* a substring of IN, no substitution can be performed. */
mrknbf = frstnb_(marker, marker_len);
mrknbl = lastnb_(marker, marker_len);
mrkpsb = i_indx(in, marker + (mrknbf - 1), in_len, mrknbl - (mrknbf - 1));
if (mrkpsb == 0) {
s_copy(out, in, out_len, in_len);
chkout_("REPMCT", (ftnlen)6);
return 0;
}
mrkpse = mrkpsb + mrknbl - mrknbf;
/* Okay, CASE is recognized and MARKER has been found. */
/* Generate the cardinal text corresponding to VALUE. */
inttxt_(value, card, (ftnlen)145);
/* CARD is always returned in upper case; change to the specified */
/* case, if required. */
if (*(unsigned char *)tmpcas == 'L') {
lcase_(card, card, (ftnlen)145, (ftnlen)145);
} else if (*(unsigned char *)tmpcas == 'C') {
lcase_(card + 1, card + 1, (ftnlen)144, (ftnlen)144);
}
/* Replace MARKER with CARD. */
repsub_(in, &mrkpsb, &mrkpse, card, out, in_len, lastnb_(card, (ftnlen)
145), out_len);
chkout_("REPMCT", (ftnlen)6);
return 0;
} /* repmct_ */
/* Subroutine */ int getgeo_(integer *iread, integer *labels, doublereal *geo,
integer *lopt, integer *na, integer *nb, integer *nc, doublereal *
ams, integer *natoms, logical *int__)
{
/* Initialized data */
static char elemnt[2*107] = "H " "HE" "LI" "BE" "B " "C " "N " "O " "F "
"NE" "NA" "MG" "AL" "SI" "P " "S " "CL" "AR" "K " "CA" "SC" "TI"
"V " "CR" "MN" "FE" "CO" "NI" "CU" "ZN" "GA" "GE" "AS" "SE" "BR"
"KR" "RB" "SR" "Y " "ZR" "NB" "MO" "TC" "RU" "RH" "PD" "AG" "CD"
"IN" "SN" "SB" "TE" "I " "XE" "CS" "BA" "LA" "CE" "PR" "ND" "PM"
"SM" "EU" "GD" "TB" "DY" "HO" "ER" "TM" "YB" "LU" "HF" "TA" "W "
"RE" "OS" "IR" "PT" "AU" "HG" "TL" "PB" "BI" "PO" "AT" "RN" "FR"
"RA" "AC" "TH" "PA" "U " "NP" "PU" "AM" "CM" "BK" "CF" "XX" "FM"
"MD" "CB" "++" "+ " "--" "- " "TV";
static char comma[1] = ",";
static char space[1] = " ";
static char nine[1] = "9";
static char zero[1] = "0";
/* Format strings */
static char fmt_260[] = "(i4,2x,3(f10.5,2x,i2,2x),3(i2,1x))";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3[2];
doublereal d__1, d__2;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
double sqrt(doublereal), d_sign(doublereal *, doublereal *), asin(
doublereal);
/* Local variables */
static integer i__, j, k, l;
static doublereal ca, sa;
static integer jj;
static char ele[2], tab[1];
static doublereal xyz[360] /* was [3][120] */;
static integer itab;
static doublereal real__;
static integer khar;
static char line[80];
static integer ndmy;
static char turn[1];
static doublereal temp1, temp2;
extern doublereal reada_(char *, integer *, ftnlen);
static integer icapa, label, iline, icapz, ilowa;
static doublereal value[40];
extern /* Subroutine */ int geout_(integer *);
static integer numat, iserr;
static doublereal const__;
static integer ilowz;
static doublereal degree;
static integer icomma;
static logical ircdrc, leadsp;
extern /* Subroutine */ int nuchar_(char *, doublereal *, integer *,
ftnlen);
static integer nvalue;
static doublereal weight;
static integer istart[40];
static char string[80];
static integer maxtxt;
extern /* Subroutine */ int xyzint_(doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *);
/* Fortran I/O blocks */
static cilist io___16 = { 1, 0, 1, "(A)", 0 };
static cilist io___29 = { 0, 6, 0, "(' ILLEGAL ATOMIC NUMBER')", 0 };
static cilist io___32 = { 0, 6, 0, "(' UNRECOGNIZED ELEMENT NAME: (',A,"
"')')", 0 };
static cilist io___33 = { 0, 6, 0, "(' FOR ATOM',I4,' ISOTOPIC MASS:' "
" ,F15.5)", 0 };
static cilist io___34 = { 0, 6, 0, "(//10X,'**** MAX. NUMBER OF ATOMS A"
"LLOWED:',I4)", 0 };
static cilist io___36 = { 0, 6, 0, "(A)", 0 };
static cilist io___38 = { 0, 6, 0, "(A)", 0 };
static cilist io___41 = { 0, 6, 0, "(//10X,' WARNING: INTERNAL COORDINAT"
"ES ARE ASSUMED -',/10X,' FOR THREE-ATOM SYSTEMS ',//)", 0 };
static cilist io___42 = { 0, 6, 0, "(A)", 0 };
static cilist io___43 = { 0, 5, 0, "(A)", 0 };
static cilist io___46 = { 0, 6, 0, "(/10X,A)", 0 };
static cilist io___53 = { 0, 6, 0, "(A)", 0 };
static cilist io___54 = { 0, 6, 0, "(//10X,' AN UNOPTIMIZABLE GEOMETRIC "
"PARAMETER HAS',/10X,' BEEN MARKED FOR OPTIMIZATION. THIS IS A NO"
"N-FATAL ' ,'ERROR')", 0 };
static cilist io___55 = { 0, 6, 0, "( ' ERROR DURING READ AT ATOM NUMBER"
" ', I3 )", 0 };
static cilist io___56 = { 0, 6, 0, "(' DATA CURRENTLY READ IN ARE ')", 0 }
;
static cilist io___57 = { 0, 6, 0, fmt_260, 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 */
/* *********************************************************************** */
/* GETGEO READS IN THE GEOMETRY. THE ELEMENT IS SPECIFIED BY IT'S */
/* CHEMICAL SYMBOL, OR, OPTIONALLY, BY IT'S ATOMIC NUMBER. */
/* ON INPUT IREAD = CHANNEL NUMBER FOR READ, NORMALLY 5 */
/* AMS = DEFAULT ATOMIC MASSES. */
/* ON OUTPUT LABELS = ATOMIC NUMBERS OF ALL ATOMS, INCLUDING DUMMIES. */
/* GEO = INTERNAL COORDINATES, IN ANGSTROMS, AND DEGREES. */
/* LOPT = INTEGER ARRAY, A '1' MEANS OPTIMIZE THIS PARAMETER, */
/* '0' MEANS DO NOT OPTIMIZE, AND A '-1' LABELS THE */
/* REACTION COORDINATE. */
/* NA = INTEGER ARRAY OF ATOMS (SEE DATA INPUT) */
/* NB = INTEGER ARRAY OF ATOMS (SEE DATA INPUT) */
/* NC = INTEGER ARRAY OF ATOMS (SEE DATA INPUT) */
/* ATMASS = ATOMIC MASSES OF ATOMS. */
/* *********************************************************************** */
/* Parameter adjustments */
--ams;
--nc;
--nb;
--na;
lopt -= 4;
geo -= 4;
--labels;
/* Function Body */
*(unsigned char *)tab = '\t';
ircdrc = i_indx(keywrd_1.keywrd, "IRC", (ftnlen)241, (ftnlen)3) + i_indx(
keywrd_1.keywrd, "DRC", (ftnlen)241, (ftnlen)3) != 0;
ilowa = 'a';
ilowz = 'z';
icapa = 'A';
icapz = 'Z';
maxtxt = 0;
*natoms = 0;
numat = 0;
iserr = 0;
for (i__ = 1; i__ <= 360; ++i__) {
/* L10: */
s_copy(simbol_1.simbol + (i__ - 1) * 10, "---", (ftnlen)10, (ftnlen)3)
;
}
L20:
io___16.ciunit = *iread;
i__1 = s_rsfe(&io___16);
if (i__1 != 0) {
goto L100001;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L100001;
}
i__1 = e_rsfe();
L100001:
if (i__1 < 0) {
goto L130;
}
if (i__1 > 0) {
goto L230;
}
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) == 0) {
goto L130;
}
++(*natoms);
/* SEE IF TEXT IS ASSOCIATED WITH THIS ELEMENT */
i__ = i_indx(line, "(", (ftnlen)80, (ftnlen)1);
if (i__ != 0) {
/* YES, ELEMENT IS LABELLED. */
k = i_indx(line, ")", (ftnlen)80, (ftnlen)1);
s_copy(atomtx_1.txtatm + (*natoms - 1 << 3), line + (i__ - 1), (
ftnlen)8, k - (i__ - 1));
/* Computing MAX */
i__1 = maxtxt, i__2 = k - i__ + 1;
maxtxt = max(i__1,i__2);
i__1 = k;
/* Writing concatenation */
i__3[0] = i__ - 1, a__1[0] = line;
i__3[1] = 80 - i__1, a__1[1] = line + i__1;
s_cat(string, a__1, i__3, &c__2, (ftnlen)80);
s_copy(line, string, (ftnlen)80, (ftnlen)80);
} else {
s_copy(atomtx_1.txtatm + (*natoms - 1 << 3), " ", (ftnlen)8, (ftnlen)
1);
}
/* CLEAN THE INPUT DATA */
/* *********************************************************************** */
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);
}
/* L30: */
}
/* *********************************************************************** */
icomma = *(unsigned char *)&comma[0];
itab = *(unsigned char *)tab;
for (i__ = 1; i__ <= 80; ++i__) {
khar = *(unsigned char *)&line[i__ - 1];
if (khar == icomma || khar == itab) {
*(unsigned char *)&line[i__ - 1] = *(unsigned char *)&space[0];
}
/* L40: */
}
/* INITIALIZE ISTART TO INTERPRET BLANKS AS ZERO'S */
for (i__ = 1; i__ <= 10; ++i__) {
/* L50: */
istart[i__ - 1] = 80;
}
/* FIND INITIAL DIGIT OF ALL NUMBERS, CHECK FOR LEADING SPACES FOLLOWED */
/* BY A CHARACTER AND STORE IN ISTART */
leadsp = TRUE_;
nvalue = 0;
for (i__ = 1; i__ <= 80; ++i__) {
if (leadsp && *(unsigned char *)&line[i__ - 1] != *(unsigned char *)&
space[0]) {
++nvalue;
istart[nvalue - 1] = i__;
}
leadsp = *(unsigned char *)&line[i__ - 1] == *(unsigned char *)&space[
0];
/* L60: */
}
/* ESTABLISH THE ELEMENT'S NAME AND ISOTOPE, CHECK FOR ERRORS OR E.O.DATA */
weight = 0.;
i__1 = istart[0] - 1;
s_copy(string, line + i__1, (ftnlen)80, istart[1] - 1 - i__1);
if (*(unsigned char *)string >= *(unsigned char *)&zero[0] && *(unsigned
char *)string <= *(unsigned char *)&nine[0]) {
/* ATOMIC NUMBER USED: NO ISOTOPE ALLOWED */
label = (integer) reada_(string, &c__1, (ftnlen)80);
if (label == 0) {
goto L120;
}
if (label < 0 || label > 107) {
s_wsfe(&io___29);
e_wsfe();
goto L240;
}
goto L80;
}
/* ATOMIC SYMBOL USED */
real__ = (d__1 = reada_(string, &c__1, (ftnlen)80), abs(d__1));
if (real__ < 1e-15) {
/* NO ISOTOPE */
s_copy(ele, string, (ftnlen)2, (ftnlen)2);
} else {
weight = real__;
if (*(unsigned char *)&string[1] >= *(unsigned char *)&zero[0] && *(
unsigned char *)&string[1] <= *(unsigned char *)&nine[0]) {
s_copy(ele, string, (ftnlen)2, (ftnlen)1);
} else {
s_copy(ele, string, (ftnlen)2, (ftnlen)2);
}
}
/* CHECK FOR ERROR IN ATOMIC SYMBOL */
if (*(unsigned char *)ele == '-' && *(unsigned char *)&ele[1] != '-') {
*(unsigned char *)&ele[1] = ' ';
}
for (i__ = 1; i__ <= 107; ++i__) {
if (s_cmp(ele, elemnt + (i__ - 1 << 1), (ftnlen)2, (ftnlen)2) == 0) {
label = i__;
goto L80;
}
/* L70: */
}
if (*(unsigned char *)ele == 'X') {
label = 99;
goto L80;
}
s_wsfe(&io___32);
do_fio(&c__1, ele, (ftnlen)2);
e_wsfe();
goto L240;
/* ALL O.K. */
L80:
if (label != 99) {
++numat;
}
if (weight != 0.) {
s_wsfe(&io___33);
do_fio(&c__1, (char *)&(*natoms), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(doublereal));
e_wsfe();
atmass_1.atmass[numat - 1] = weight;
} else {
if (label != 99) {
atmass_1.atmass[numat - 1] = ams[label];
}
}
if (*natoms > 120) {
s_wsfe(&io___34);
do_fio(&c__1, (char *)&c__120, (ftnlen)sizeof(integer));
e_wsfe();
s_stop("", (ftnlen)0);
}
labels[*natoms] = label;
geo[*natoms * 3 + 1] = reada_(line, &istart[1], (ftnlen)80);
geo[*natoms * 3 + 2] = reada_(line, &istart[3], (ftnlen)80);
geo[*natoms * 3 + 3] = reada_(line, &istart[5], (ftnlen)80);
if (ircdrc) {
i__1 = istart[2] - 1;
s_copy(turn, line + i__1, (ftnlen)1, istart[2] - i__1);
if (*(unsigned char *)turn == 'T') {
lopt[*natoms * 3 + 1] = 1;
if (*natoms == 1) {
s_wsfe(&io___36);
do_fio(&c__1, " IN DRC MONITOR POTENTIAL ENERGY TURNING POIN"
"TS", (ftnlen)47);
e_wsfe();
}
} else {
lopt[*natoms * 3 + 1] = 0;
}
i__1 = istart[4] - 1;
s_copy(turn, line + i__1, (ftnlen)1, istart[4] - i__1);
if (*(unsigned char *)turn == 'T') {
lopt[*natoms * 3 + 2] = 1;
} else {
lopt[*natoms * 3 + 2] = 0;
}
i__1 = istart[6] - 1;
s_copy(turn, line + i__1, (ftnlen)1, istart[6] - i__1);
if (*(unsigned char *)turn == 'T') {
lopt[*natoms * 3 + 3] = 1;
} else {
lopt[*natoms * 3 + 3] = 0;
}
} else {
lopt[*natoms * 3 + 1] = (integer) reada_(line, &istart[2], (ftnlen)80)
;
lopt[*natoms * 3 + 2] = (integer) reada_(line, &istart[4], (ftnlen)80)
;
lopt[*natoms * 3 + 3] = (integer) reada_(line, &istart[6], (ftnlen)80)
;
for (i__ = 3; i__ <= 7; i__ += 2) {
i__1 = istart[i__ - 1] - 1;
i__2 = istart[i__ - 1] - 1;
if (*(unsigned char *)&line[i__1] >= icapa && *(unsigned char *)&
line[i__2] <= icapz) {
iserr = 1;
}
/* L90: */
}
}
na[*natoms] = (integer) reada_(line, &istart[7], (ftnlen)80);
nb[*natoms] = (integer) reada_(line, &istart[8], (ftnlen)80);
nc[*natoms] = (integer) reada_(line, &istart[9], (ftnlen)80);
/* SPECIAL CASE OF USERS FORGETTING TO ADD DIHEDRAL DATA FOR ATOM 3 */
if (*natoms == 3) {
if (lopt[12] == 2) {
na[3] = 1;
nb[3] = 2;
geo[12] = 0.;
lopt[12] = 0;
} else if (lopt[12] == 1 && (d__1 = geo[12] - 2., abs(d__1)) < 1e-4) {
na[3] = 2;
nb[3] = 1;
geo[12] = 0.;
lopt[12] = 0;
}
}
if (lopt[*natoms * 3 + 1] > 1 || lopt[*natoms * 3 + 2] > 1 || lopt[*
natoms * 3 + 3] > 1) {
iserr = 1;
}
if (iserr == 1) {
/* MUST BE GAUSSIAN GEOMETRY INPUT */
i__1 = *natoms;
for (i__ = 2; i__ <= i__1; ++i__) {
for (k = 1; k <= 3; ++k) {
j = (integer) (geo[k + i__ * 3] + .4);
if ((d__1 = geo[k + i__ * 3] - j, abs(d__1)) > 1e-5) {
/* GEOMETRY CANNOT BE GAUSSIAN */
s_wsfe(&io___38);
do_fio(&c__1, " GEOMETRY IS FAULTY. GEOMETRY READ IN IS",
(ftnlen)41);
e_wsfe();
const__ = .017453292519988887;
i__2 = *natoms;
for (l = 1; l <= i__2; ++l) {
geo[l * 3 + 2] *= const__;
/* L100: */
geo[l * 3 + 3] *= const__;
}
geout_(&c__6);
s_stop("", (ftnlen)0);
}
/* L110: */
}
}
*natoms = -1;
return 0;
}
goto L20;
/* ALL DATA READ IN, CLEAN UP AND RETURN */
L120:
--(*natoms);
L130:
na[2] = 1;
*(unsigned char *)atomtx_1.ltxt = (char) maxtxt;
if (*natoms > 3) {
*int__ = na[4] != 0;
} else {
if (geo[11] < 10. && *natoms == 3) {
s_wsfe(&io___41);
e_wsfe();
}
*int__ = TRUE_;
}
if (*int__) {
geo[8] = 0.;
}
/* READ IN VELOCITY VECTOR, IF PRESENT */
if (i_indx(keywrd_1.keywrd, "VELO", (ftnlen)241, (ftnlen)4) > 0) {
if (*int__) {
s_wsfe(&io___42);
do_fio(&c__1, " COORDINATES MUST BE CARTESIAN WHEN VELOCITY VECT"
"OR IS USED.", (ftnlen)60);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* # WRITE(6,'(/10X,A)')'INITIAL VELOCITY VECTOR FOR DRC' */
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
s_rsfe(&io___43);
do_fio(&c__1, line, (ftnlen)80);
e_rsfe();
nuchar_(line, value, &ndmy, (ftnlen)80);
if (ndmy != 3) {
s_wsfe(&io___46);
do_fio(&c__1, " THERE MUST BE EXACTLY THREE VELOCITY DATA P"
"ER LINE", (ftnlen)52);
e_wsfe();
s_stop("", (ftnlen)0);
}
for (j = 1; j <= 3; ++j) {
/* L140: */
path_1.react[j + (i__ + 2) * 3 - 4] = value[j - 1];
}
/* # WRITE(6,'(2X,A2,2X,3F13.5)')ELEMNT(LABELS(I)),(VALUE(J),J=1,3) */
/* L150: */
}
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 2; ++j) {
/* L160: */
path_1.react[i__ + j * 3 - 4] = geo[i__ + (j + 1) * 3] - geo[
i__ + 3];
}
}
/* NOW TO ROTATE VELOCITY VECTOR TO SUIT INTERNAL COORDINATE DEFINITION */
/* ROTATE AROUND THE 1-2 X-AXIS TO AS TO ELIMINATE REACT(3,2) */
/* (PUT ATOM 2 IN X-Y PLANE) */
/* Computing 2nd power */
d__1 = path_1.react[1];
/* Computing 2nd power */
d__2 = path_1.react[2];
sa = path_1.react[2] / sqrt(d__1 * d__1 + d__2 * d__2 + 1e-20);
/* Computing 2nd power */
d__2 = sa;
d__1 = sqrt(1. - d__2 * d__2);
ca = d_sign(&d__1, &path_1.react[1]);
/* # LABELS(NATOMS+1)=1 */
/* # LABELS(NATOMS+2)=1 */
/* # WRITE(6,*)' FIRST ROTATION, ABOUT 1-2 X-AXIS' */
i__1 = *natoms + 2;
for (i__ = 1; i__ <= i__1; ++i__) {
temp1 = path_1.react[i__ * 3 - 2] * ca + path_1.react[i__ * 3 - 1]
* sa;
temp2 = -path_1.react[i__ * 3 - 2] * sa + path_1.react[i__ * 3 -
1] * ca;
path_1.react[i__ * 3 - 2] = temp1;
path_1.react[i__ * 3 - 1] = temp2;
/* # WRITE(6,'(2X,A2,2X,3F13.5)')ELEMNT(LABELS(I)),(REACT(J,I),J=1,3) */
/* L170: */
}
/* ROTATE AROUND THE 1-2 Z-AXIS TO AS TO ELIMINATE REACT(2,2) */
/* (PUT ATOM 2 ON X AXIS) */
/* Computing 2nd power */
d__1 = path_1.react[1];
/* Computing 2nd power */
d__2 = path_1.react[0];
ca = path_1.react[0] / sqrt(d__1 * d__1 + d__2 * d__2 + 1e-20);
/* Computing 2nd power */
d__2 = ca;
d__1 = sqrt(1. - d__2 * d__2);
sa = d_sign(&d__1, &path_1.react[1]);
/* # WRITE(6,*)' SECOND ROTATION, ABOUT 1-2 Z-AXIS' */
i__1 = *natoms + 2;
for (i__ = 1; i__ <= i__1; ++i__) {
temp1 = path_1.react[i__ * 3 - 3] * ca + path_1.react[i__ * 3 - 2]
* sa;
temp2 = -path_1.react[i__ * 3 - 3] * sa + path_1.react[i__ * 3 -
2] * ca;
path_1.react[i__ * 3 - 3] = temp1;
path_1.react[i__ * 3 - 2] = temp2;
/* # WRITE(6,'(2X,A2,2X,3F13.5)')ELEMNT(LABELS(I)),(REACT(J,I),J=1,3) */
/* L180: */
}
/* ROTATE AROUND THE 2-3 X-AXIS TO AS TO ELIMINATE REACT(3,3) */
/* (PUT ATOM 3 ON X-Y PLANE) */
/* Computing 2nd power */
d__1 = path_1.react[4];
/* Computing 2nd power */
d__2 = path_1.react[5];
sa = path_1.react[5] / sqrt(d__1 * d__1 + d__2 * d__2 + 1e-20);
/* Computing 2nd power */
d__2 = sa;
d__1 = sqrt(1. - d__2 * d__2);
ca = d_sign(&d__1, &path_1.react[4]);
/* # WRITE(6,*)' THIRD ROTATION, ABOUT 2-3 X-AXIS' */
i__1 = *natoms + 2;
for (i__ = 1; i__ <= i__1; ++i__) {
temp1 = path_1.react[i__ * 3 - 2] * ca + path_1.react[i__ * 3 - 1]
* sa;
temp2 = -path_1.react[i__ * 3 - 2] * sa + path_1.react[i__ * 3 -
1] * ca;
path_1.react[i__ * 3 - 2] = temp1;
path_1.react[i__ * 3 - 1] = temp2;
/* # WRITE(6,'(2X,A2,2X,3F13.5)')ELEMNT(LABELS(I)),(REACT(J,I),J=1,3) */
/* L190: */
}
/* STRIP OFF FIRST TWO COORDINATES; THESE WERE THE COORDINATE AXIS */
/* DEFINITIONS */
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L200: */
path_1.react[j + i__ * 3 - 4] = path_1.react[j + (i__ + 2) *
3 - 4];
}
}
}
if (! (*int__)) {
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L210: */
xyz[j + i__ * 3 - 4] = geo[j + i__ * 3];
}
}
degree = 90. / asin(1.);
xyzint_(xyz, natoms, &na[1], &nb[1], &nc[1], °ree, &geo[4]);
if (i_indx(keywrd_1.keywrd, " XYZ", (ftnlen)241, (ftnlen)4) == 0) {
/* UNCONDITIONALLY SET FLAGS FOR INTERNAL COORDINATES */
for (i__ = 1; i__ <= 3; ++i__) {
for (j = i__; j <= 3; ++j) {
/* L220: */
lopt[j + i__ * 3] = 0;
}
}
}
if ((d__1 = geo[11] - 180., abs(d__1)) < 1e-4 || abs(geo[11]) < 1e-4)
{
s_wsfe(&io___53);
do_fio(&c__1, " DUE TO PROGRAM BUG, THE FIRST THREE ATOMS MUST N"
"OT LIE IN A STRAIGHT LINE.", (ftnlen)75);
e_wsfe();
s_stop("", (ftnlen)0);
}
} else if (! ircdrc) {
lopt[8] = 0;
if (lopt[4] + lopt[5] + lopt[6] + lopt[9] + lopt[12] > 0) {
lopt[4] = 0;
lopt[5] = 0;
lopt[6] = 0;
lopt[9] = 0;
lopt[12] = 0;
s_wsfe(&io___54);
e_wsfe();
}
}
if (na[3] == 0) {
nb[3] = 1;
na[3] = 2;
}
return 0;
/* ERROR CONDITIONS */
L230:
if (*iread == 5) {
s_wsfe(&io___55);
do_fio(&c__1, (char *)&(*natoms), (ftnlen)sizeof(integer));
e_wsfe();
} else {
*natoms = 0;
return 0;
}
L240:
j = *natoms - 1;
s_wsfe(&io___56);
e_wsfe();
i__1 = j;
for (k = 1; k <= i__1; ++k) {
/* L250: */
s_wsfe(&io___57);
do_fio(&c__1, (char *)&labels[k], (ftnlen)sizeof(integer));
for (jj = 1; jj <= 3; ++jj) {
do_fio(&c__1, (char *)&geo[jj + k * 3], (ftnlen)sizeof(doublereal)
);
do_fio(&c__1, (char *)&lopt[jj + k * 3], (ftnlen)sizeof(integer));
}
do_fio(&c__1, (char *)&na[k], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nb[k], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nc[k], (ftnlen)sizeof(integer));
e_wsfe();
}
s_stop("", (ftnlen)0);
return 0;
} /* getgeo_ */
/* Subroutine */ int paths_()
{
/* Initialized data */
static char type__[10*3+1] = "ANGSTROMS DEGREES DEGREES ";
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
integer i_indx(), s_wsfe(), do_fio(), e_wsfe();
/* Subroutine */ int s_stop();
/* Local variables */
static integer mdfp[20];
static doublereal xdfp[20], delf0, delf1;
static integer i__;
extern /* Subroutine */ int flepo_();
static doublereal funct, rnord, c3, xlast[360], x3, funct1, gd[360];
extern doublereal second_();
extern /* Subroutine */ int dfpsav_();
static doublereal cc1, cc2, cb1, totime, cb2, aconst, bconst, cconst;
extern /* Subroutine */ int writmo_();
static integer lpr;
/* Fortran I/O blocks */
static cilist io___8 = { 0, 6, 0, "(//10X,' RESTARTING AT POINT',I3)", 0 }
;
static cilist io___9 = { 0, 6, 0, "(' ABOUT TO ENTER FLEPO FROM PATH')",
0 };
static cilist io___11 = { 0, 6, 0, "(' OPTIMIZED VALUES OF PARAMETERS, \
INITIAL POINT')", 0 };
static cilist io___14 = { 0, 6, 0, "(1X,16('*****')//17X,'REACTION COORD\
INATE = ' ,F12.4,2X,A10,19X//1X,16('*****'))", 0 };
static cilist io___16 = { 0, 6, 0, "(1X,16('*****')//19X,'REACTION COORD\
INATE = ' ,F12.4,2X,A10,19X//1X,16('*****'))", 0 };
static cilist io___28 = { 0, 6, 0, "(' GEOMETRY TOO UNSTABLE FOR EXTRAPO\
LATION TO BE USED'/ ,' - THE LAST GEOMETRY IS BEING USED TO START THE NEXT' \
,' CALCULATION')", 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 */
/* ***** Modified by Jiro Toyoda at 1994-05-25 ***** */
/* COMMON /TIME / TIME0 */
/* ***************************** at 1994-05-25 ***** */
/* *********************************************************************** */
/* PATH FOLLOWS A REACTION COORDINATE. THE REACTION COORDINATE IS ON */
/* ATOM LATOM, AND IS A DISTANCE IF LPARAM=1, */
/* AN ANGLE IF LPARAM=2, */
/* AN DIHEDRALIF LPARAM=3. */
/* *********************************************************************** */
alparm_1.iloop = 1;
if (i_indx(keywrd_1.keywrd, "RESTAR", (ftnlen)241, (ftnlen)6) != 0) {
mdfp[8] = 0;
dfpsav_(&totime, geovar_1.xparam, gd, xlast, &funct1, mdfp, xdfp);
s_wsfe(&io___8);
do_fio(&c__1, (char *)&alparm_1.iloop, (ftnlen)sizeof(integer));
e_wsfe();
}
if (alparm_1.iloop > 1) {
goto L10;
}
s_wsfe(&io___9);
e_wsfe();
timec_1.time0 = second_();
flepo_(geovar_1.xparam, &geovar_1.nvar, &funct);
s_wsfe(&io___11);
e_wsfe();
writmo_(&timec_1.time0, &funct);
timec_1.time0 = second_();
L10:
if (alparm_1.iloop > 2) {
goto L40;
}
geom_1.geo[path_1.lparam + path_1.latom * 3 - 4] = path_1.react[1];
if (alparm_1.iloop == 1) {
alparm_1.x0 = path_1.react[0];
alparm_1.x1 = alparm_1.x0;
alparm_1.x2 = path_1.react[1];
if (alparm_1.x2 < -100.) {
s_stop("", (ftnlen)0);
}
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
alparm_1.alparm[i__ * 3 - 2] = geovar_1.xparam[i__ - 1];
/* L20: */
alparm_1.alparm[i__ * 3 - 3] = geovar_1.xparam[i__ - 1];
}
alparm_1.iloop = 2;
}
flepo_(geovar_1.xparam, &geovar_1.nvar, &funct);
rnord = path_1.react[1];
if (path_1.lparam > 1) {
rnord *= 57.29577951;
}
s_wsfe(&io___14);
do_fio(&c__1, (char *)&rnord, (ftnlen)sizeof(doublereal));
do_fio(&c__1, type__ + (path_1.lparam - 1) * 10, (ftnlen)10);
e_wsfe();
writmo_(&timec_1.time0, &funct);
timec_1.time0 = second_();
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L30: */
alparm_1.alparm[i__ * 3 - 1] = geovar_1.xparam[i__ - 1];
}
/* NOW FOR THE MAIN INTERPOLATION ROUTE */
if (alparm_1.iloop == 2) {
alparm_1.iloop = 3;
}
L40:
lpr = alparm_1.iloop;
for (alparm_1.iloop = lpr; alparm_1.iloop <= 100; ++alparm_1.iloop) {
if (path_1.react[alparm_1.iloop - 1] < -100.) {
return 0;
}
rnord = path_1.react[alparm_1.iloop - 1];
if (path_1.lparam > 1) {
rnord *= 57.29577951;
}
s_wsfe(&io___16);
do_fio(&c__1, (char *)&rnord, (ftnlen)sizeof(doublereal));
do_fio(&c__1, type__ + (path_1.lparam - 1) * 10, (ftnlen)10);
e_wsfe();
x3 = path_1.react[alparm_1.iloop - 1];
/* Computing 2nd power */
d__1 = alparm_1.x0;
/* Computing 2nd power */
d__2 = alparm_1.x1;
/* Computing 2nd power */
d__3 = alparm_1.x1;
/* Computing 2nd power */
d__4 = alparm_1.x2;
c3 = (d__1 * d__1 - d__2 * d__2) * (alparm_1.x1 - alparm_1.x2) - (
d__3 * d__3 - d__4 * d__4) * (alparm_1.x0 - alparm_1.x1);
/* WRITE(6,'('' C3:'',F13.7)')C3 */
if (abs(c3) < 1e-8) {
/* WE USE A LINEAR INTERPOLATION */
cc1 = 0.;
cc2 = 0.;
} else {
/* WE DO A QUADRATIC INTERPOLATION */
cc1 = (alparm_1.x1 - alparm_1.x2) / c3;
cc2 = (alparm_1.x0 - alparm_1.x1) / c3;
}
cb1 = 1. / (alparm_1.x1 - alparm_1.x2);
/* Computing 2nd power */
d__1 = alparm_1.x1;
/* Computing 2nd power */
d__2 = alparm_1.x2;
cb2 = (d__1 * d__1 - d__2 * d__2) * cb1;
/* NOW TO CALCULATE THE INTERPOLATED COORDINATES */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
delf0 = alparm_1.alparm[i__ * 3 - 3] - alparm_1.alparm[i__ * 3 -
2];
delf1 = alparm_1.alparm[i__ * 3 - 2] - alparm_1.alparm[i__ * 3 -
1];
aconst = cc1 * delf0 - cc2 * delf1;
bconst = cb1 * delf1 - aconst * cb2;
/* Computing 2nd power */
d__1 = alparm_1.x2;
cconst = alparm_1.alparm[i__ * 3 - 1] - bconst * alparm_1.x2 -
aconst * (d__1 * d__1);
/* Computing 2nd power */
d__1 = x3;
geovar_1.xparam[i__ - 1] = cconst + bconst * x3 + aconst * (d__1 *
d__1);
alparm_1.alparm[i__ * 3 - 3] = alparm_1.alparm[i__ * 3 - 2];
/* L50: */
alparm_1.alparm[i__ * 3 - 2] = alparm_1.alparm[i__ * 3 - 1];
}
/* NOW TO CHECK THAT THE GUESSED GEOMETRY IS NOT TOO ABSURD */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L60: */
if ((d__1 = geovar_1.xparam[i__ - 1] - alparm_1.alparm[i__ * 3 -
1], abs(d__1)) > (float).2) {
goto L70;
}
}
goto L90;
L70:
s_wsfe(&io___28);
e_wsfe();
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L80: */
geovar_1.xparam[i__ - 1] = alparm_1.alparm[i__ * 3 - 1];
}
L90:
alparm_1.x0 = alparm_1.x1;
alparm_1.x1 = alparm_1.x2;
alparm_1.x2 = x3;
geom_1.geo[path_1.lparam + path_1.latom * 3 - 4] = path_1.react[
alparm_1.iloop - 1];
flepo_(geovar_1.xparam, &geovar_1.nvar, &funct);
writmo_(&timec_1.time0, &funct);
timec_1.time0 = second_();
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
alparm_1.alparm[i__ * 3 - 1] = geovar_1.xparam[i__ - 1];
}
/* L110: */
}
} /* paths_ */
/* $Procedure ERRDP ( Insert D.P. Number into Error Message Text ) */
/* Subroutine */ int errdp_(char *marker, doublereal *dpnum, ftnlen
marker_len)
{
/* System generated locals */
address a__1[3], a__2[2];
integer i__1, i__2[3], i__3[2];
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen),
s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern /* Subroutine */ int dpstr_(doublereal *, integer *, char *,
ftnlen), ljust_(char *, char *, ftnlen, ftnlen);
extern logical allowd_(void);
extern integer lastnb_(char *, ftnlen);
char lngmsg[1840];
extern /* Subroutine */ int getlms_(char *, ftnlen);
extern integer frstnb_(char *, ftnlen);
char dpstrg[21], tmpmsg[1840];
extern /* Subroutine */ int putlms_(char *, ftnlen);
integer strpos;
/* $ Abstract */
/* Substitute a double precision number for the first occurrence of */
/* a marker found in the current long error message. */
/* $ 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 */
/* ERROR */
/* $ Keywords */
/* ERROR, CONVERSION */
/* $ 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 */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* MARKER I A substring of the error message to be replaced. */
/* DPNUM I The d.p. number to substitute for MARKER. */
/* $ Detailed_Input */
/* MARKER is a character string which marks a position in */
/* the long error message where a character string */
/* representing an double precision number is to be */
/* substituted. Leading and trailing blanks in MARKER */
/* are not significant. */
/* Case IS significant; 'XX' is considered to be */
/* a different marker from 'xx'. */
/* DPNUM is an double precision number whose character */
/* representation will be substituted for the first */
/* occurrence of MARKER in the long error message. */
/* This occurrence of the substring indicated by MARKER */
/* will be removed, and replaced by a character string, */
/* with no leading or trailing blanks, representing */
/* DPNUM. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* LMSGLN is the maximum length of the long error message. See */
/* the include file errhnd.inc for the value of LMSGLN. */
/* $ Exceptions */
/* This routine does not detect any errors. */
/* However, this routine is part of the SPICELIB error */
/* handling mechanism. */
/* $ Files */
/* None. */
/* $ Particulars */
/* The effect of this routine is to update the current long */
/* error message. If no marker is found, (e.g., in the */
/* case that the long error message is blank), the routine */
/* has no effect. If multiple instances of the marker */
/* designated by MARKER are found, only the first one is */
/* replaced. */
/* If the character string resulting from the substitution */
/* exceeds the maximum length of the long error message, the */
/* characters on the right are lost. No error is signalled. */
/* This routine has no effect if changes to the long message */
/* are not allowed. */
/* $ Examples */
/* 1. In this example, the marker is: # */
/* The current long error message is: */
/* 'Invalid operation value. The value was #'. */
/* After the call, */
/* CALL ERRDP ( '#', 5.D0 ) */
/* The long error message becomes: */
/* 'Invalid operation value. The value was 5.0'. */
/* 2. In this example, the marker is: XX */
/* The current long error message is: */
/* 'Left endpoint exceeded right endpoint. The left'// */
/* 'endpoint was: XX. The right endpoint was: XX.' */
/* After the call, */
/* CALL ERRDP ( 'XX', 5.D0 ) */
/* The long error message becomes: */
/* 'Left endpoint exceeded right endpoint. The left'// */
/* 'endpoint was: 5.0. The right endpoint was: XX.' */
/* $ Restrictions */
/* The caller must ensure that the message length, after sub- */
/* stitution is performed, doesn't exceed LMSGLN characters. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* $ Version */
/* - SPICELIB Version 2.2.1, 08-JAN-2014 (BVS) */
/* Fixed header example (5.0 -> 5.D0). */
/* - SPICELIB Version 2.2.0, 29-JUL-2005 (NJB) */
/* Bug fix: increased length of internal string DPSTRG to */
/* handle 3-digit exponents. */
/* - SPICELIB Version 2.1.0, 29-JUL-1997 (NJB) */
/* Bug fix: extraneous leading blank has been removed from */
/* numeric string substituted for marker. */
/* Maximum length of the long error message is now represented */
/* by the parameter LMSGLN. Miscellaneous format changes to the */
/* header, code and in-line comments were made. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (NJB) */
/* -& */
/* $ Index_Entries */
/* insert d.p. number into error message text */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 2.1.0, 29-JUL-1997 (NJB) */
/* Bug fix: extraneous leading blank has been removed from */
/* numeric string substituted for marker. */
/* Maximum length of the long error message is now represented */
/* by the parameter LMSGLN. Miscellaneous format changes to the */
/* header, code and in-line comments were made. */
/* -& */
/* SPICELIB functions */
/* Local Variables: */
/* Length of DPSTRG is number of significant digits plus 7 */
/* (see DPSTR header) */
/* Executable Code: */
/* Changes to the long error message have to be allowed, or we */
/* do nothing. */
if (! allowd_()) {
return 0;
}
/* MARKER has to have some non-blank characters, or we do nothing. */
if (lastnb_(marker, marker_len) == 0) {
return 0;
}
/* Get a copy of the current long error message. Convert DPNUM */
/* to a character string. Ask for 14 significant digits in */
/* string. */
getlms_(lngmsg, (ftnlen)1840);
dpstr_(dpnum, &c__14, dpstrg, (ftnlen)21);
ljust_(dpstrg, dpstrg, (ftnlen)21, (ftnlen)21);
/* Locate the leftmost occurrence of MARKER, if there is one */
/* (ignoring leading and trailing blanks): */
i__1 = frstnb_(marker, marker_len) - 1;
strpos = i_indx(lngmsg, marker + i__1, (ftnlen)1840, lastnb_(marker,
marker_len) - i__1);
if (strpos == 0) {
return 0;
} else {
/* We put together TMPMSG, a copy of LNGMSG with MARKER */
/* replaced by the character representation of DPNUM: */
if (strpos > 1) {
if (strpos + lastnb_(marker, marker_len) - frstnb_(marker,
marker_len) < lastnb_(lngmsg, (ftnlen)1840)) {
/* There's more of the long message after the marker... */
i__1 = strpos + lastnb_(marker, marker_len) - frstnb_(marker,
marker_len);
/* Writing concatenation */
i__2[0] = strpos - 1, a__1[0] = lngmsg;
i__2[1] = lastnb_(dpstrg, (ftnlen)21), a__1[1] = dpstrg;
i__2[2] = 1840 - i__1, a__1[2] = lngmsg + i__1;
s_cat(tmpmsg, a__1, i__2, &c__3, (ftnlen)1840);
} else {
/* Writing concatenation */
i__3[0] = strpos - 1, a__2[0] = lngmsg;
i__3[1] = lastnb_(dpstrg, (ftnlen)21), a__2[1] = dpstrg;
s_cat(tmpmsg, a__2, i__3, &c__2, (ftnlen)1840);
}
} else {
/* We're starting with the d.p. number, so we know it fits... */
if (lastnb_(marker, marker_len) - frstnb_(marker, marker_len) <
lastnb_(lngmsg, (ftnlen)1840)) {
/* There's more of the long message after the marker... */
i__1 = strpos + lastnb_(marker, marker_len) - frstnb_(marker,
marker_len);
/* Writing concatenation */
i__3[0] = lastnb_(dpstrg, (ftnlen)21), a__2[0] = dpstrg;
i__3[1] = 1840 - i__1, a__2[1] = lngmsg + i__1;
s_cat(tmpmsg, a__2, i__3, &c__2, (ftnlen)1840);
} else {
/* The marker's the whole string: */
s_copy(tmpmsg, dpstrg, (ftnlen)1840, (ftnlen)21);
}
}
/* Update the long message: */
putlms_(tmpmsg, (ftnlen)1840);
}
return 0;
} /* errdp_ */
/* $Procedure ANA ( AN or A ? ) */
/* Character */ VOID ana_(char *ret_val, ftnlen ret_val_len, char *word, char
*case__, ftnlen word_len, ftnlen case_len)
{
/* Initialized data */
static char a[2*3] = "A " "A " "a ";
static char an[2*3] = "AN" "An" "an";
static char anword[8*22] = "HEIR " "HONEST " "HONOR " "H "
"HOUR " "HORS " "HOMBRE " "F " "L " "M "
"N " "R " "S " "X " "UNIN " "UNIM "
"ONEI " "ONER " "SPK " "EK " "IK " "SCLK ";
static char aword[8*33] = "HORSE " "ONE " "ONE- " "ONCE "
"ONENESS " "UIG " "UIN " "UKA " "UKE " "UKO "
"UKI " "UKU " "ULOT " "UNANI " "UNI " "UNINU "
"UPA " "URA " "URE " "URO " "USA " "USE "
"USU " "UTE " "UTI " "UTO " "UVA " "UVE "
"UVU " "EU " "EWE " "UTRI " "U ";
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen), s_rnge(char *, integer,
char *, integer);
/* Local variables */
static integer caps, i__;
static char begin[1];
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static char start[32*7];
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int replch_(char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen);
static char mycase[1], myword[32];
/* $ Abstract */
/* Return the correct article "a" or "an" used to modify a word */
/* and return it capitalized, lower case, or upper case. */
/* $ 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 */
/* WORD */
/* $ Keywords */
/* UTILITY */
/* WORD */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* WORD I is a word that should be modified by "a" or "an" */
/* CASE I 'U', 'L', or 'C' to specify capitalization of ANA. */
/* ANA O 'A' or 'AN' appropriately capitalized. */
/* $ Detailed_Input */
/* WORD is any english word for which you want to write the */
/* correct phrase "a(an) response(answer)". The case */
/* of the letters of word do not matter. */
/* Leading white space in word is ignored. The characters */
/* " and ' are ignored. Thus ''' apple '' ' and */
/* '"apple"' and ' apple' and 'apple' are all treated as */
/* the same word. */
/* CASE is a character that describes how the value returned */
/* in ANA should be capitalized. The rules are: */
/* 'U' --- ANA is returned in all caps ( A, AN ) */
/* 'C' --- ANA is returned capitalized ( A, An ) */
/* 'L' --- ANA is returned lower case ( a, an ) */
/* The case of CASE does not matter. Any value other */
/* than those specified result in ANA being returned */
/* in all lower case. */
/* $ Detailed_Output */
/* ANA is a character function an will return the correct */
/* indefinite article needed to modify the word contained */
/* in WORD. ANA should be declared to be CHARACTER*(2) */
/* (or CHARACTER*(N) where N > 1) in the calling */
/* program. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error Free */
/* 1) If the uppercase value of CASE is not 'U', 'C' or 'L', it shall */
/* be treated as 'L'. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine allows you to construct grammatically correct phrases */
/* when you need to modify a word by an indefinite article. Using */
/* the pronunciations contained in the Webster's Ninth Collegiate */
/* Dictionary, the phrase */
/* ANA(WORD, CASE) // ' ' // WORD */
/* will be grammatically correct. */
/* $ Examples */
/* Suppose you wished to construct one of the messages */
/* 'a new file' */
/* 'an existing file' */
/* and that the NEW/EXISTING word was in the variable WORD. Then */
/* you could write */
/* MESSAGE = ANA( WORD, 'L' ) // ' ' // WORD // ' file ' */
/* CALL CMPRSS ( ' ', 1, MESSAGE, MESSAGE ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* Webster's Ninth Collegiate Dictionary. */
/* $ Author_and_Institution */
/* B.V. Semenov (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.2, 28-FEB-2008 (BVS) */
/* Corrected the contents of the Required_Reading section. */
/* - SPICELIB Version 1.1.1, 22-SEP-2004 (EDW) */
/* Added Copyright section. */
/* - SPICELIB Version 1.1.0, 18-JAN-2001 (WLT) */
/* Made SCLK and "an" word. */
/* - SPICELIB Version 1.0.0, 29-NOV-1995 (WLT) */
/* -& */
/* $ Index_Entries */
/* GET THE CORRECT INDEFINITE ARTICLE */
/* -& */
ucase_(word, myword, word_len, (ftnlen)32);
replch_(myword, "'", " ", myword, (ftnlen)32, (ftnlen)1, (ftnlen)1, (
ftnlen)32);
replch_(myword, "\"", " ", myword, (ftnlen)32, (ftnlen)1, (ftnlen)1, (
ftnlen)32);
ljust_(myword, myword, (ftnlen)32, (ftnlen)32);
ucase_(case__, mycase, case_len, (ftnlen)1);
s_copy(ret_val, " ", ret_val_len, (ftnlen)1);
if (*(unsigned char *)mycase == 'U') {
caps = 1;
} else if (*(unsigned char *)mycase == 'C') {
caps = 2;
} else {
caps = 3;
}
/* Handle the obvious things first. */
*(unsigned char *)begin = *(unsigned char *)myword;
if (i_indx("AI", begin, (ftnlen)2, (ftnlen)1) > 0) {
s_copy(ret_val, an + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("an", i__1, "ana_", (ftnlen)235)) << 1), ret_val_len, (
ftnlen)2);
return ;
} else if (i_indx("BCDGJKPQTVWYZ", begin, (ftnlen)13, (ftnlen)1) > 0) {
s_copy(ret_val, a + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("a", i__1, "ana_", (ftnlen)240)) << 1), ret_val_len, (
ftnlen)2);
return ;
}
/* If we are still here, we need to be a bit more careful */
/* in our determination of ANA. */
/* Get the beginnings of the input word. */
for (i__ = 1; i__ <= 7; ++i__) {
s_copy(start + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1 : s_rnge(
"start", i__1, "ana_", (ftnlen)252)) << 5), myword, (ftnlen)
32, i__);
}
/* Now see if the start of the input word belongs to */
/* one of the special collections. */
for (i__ = 7; i__ >= 2; --i__) {
if (isrchc_(start + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1 :
s_rnge("start", i__1, "ana_", (ftnlen)261)) << 5), &c__33,
aword, (ftnlen)32, (ftnlen)8) != 0) {
s_copy(ret_val, a + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("a", i__1, "ana_", (ftnlen)263)) << 1),
ret_val_len, (ftnlen)2);
return ;
}
if (isrchc_(start + (((i__1 = i__ - 1) < 7 && 0 <= i__1 ? i__1 :
s_rnge("start", i__1, "ana_", (ftnlen)268)) << 5), &c__22,
anword, (ftnlen)32, (ftnlen)8) != 0) {
s_copy(ret_val, an + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("an", i__1, "ana_", (ftnlen)270)) << 1),
ret_val_len, (ftnlen)2);
return ;
}
}
/* If we got this far we can determine the ANAe by */
/* just looking at the beginning of the string. */
if (i_indx("AEIOU", myword, (ftnlen)5, (ftnlen)1) > 0) {
s_copy(ret_val, an + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("an", i__1, "ana_", (ftnlen)282)) << 1), ret_val_len, (
ftnlen)2);
} else {
s_copy(ret_val, a + (((i__1 = caps - 1) < 3 && 0 <= i__1 ? i__1 :
s_rnge("a", i__1, "ana_", (ftnlen)286)) << 1), ret_val_len, (
ftnlen)2);
}
return ;
} /* ana_ */
/* Subroutine */ int makpol_(doublereal *coord)
{
/* Format strings */
static char fmt_160[] = "(\002 T\002,i1,\002 = \002,f11.7,\002 "
"\002,f11.7,\002 \002,f11.7)";
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, j, k, im1, nan, nbn, ncn, ioff, joff, koff, last,
mers;
extern doublereal reada_(char *, integer *, ftnlen);
extern /* Subroutine */ int geout_(integer *);
static doublereal degree;
extern /* Subroutine */ int gmetry_(doublereal *, doublereal *), xyzint_(
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *);
/* Fortran I/O blocks */
static cilist io___14 = { 0, 6, 0, fmt_160, 0 };
static cilist io___15 = { 0, 6, 0, "(/,10X,A)", 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 */
/* *********************************************************************** */
/* MAKPOL TAKES A PRIMITIVE UNIT CELL AND GENERATES A TOTAL OF 'MERS' */
/* COPIES. THE RESULTING GEOMETRY IS PLACED IN GEO. ARRAYS LOC, */
/* XPARAM, NA, NB, NC, SIMBOL, TXTATM, LABELS, LOCPAR, IDEPFN, AND */
/* LOCDEP ARE EXPANDED TO SUIT. ARRAY TVEC IS MODIFIED, AS ARE SCALARS */
/* NVAR, NATOMS, AND NDEP. */
/* SYMMETRY IS FORCED ON, OR ADDED ON, IN ORDER TO MAKE THE NEW MERS */
/* EQUIVALENT TO THE SUPPLIED MER. */
/* *********************************************************************** */
/* Parameter adjustments */
coord -= 4;
/* Function Body */
ioff = 0;
i__1 = i_indx(keywrd_1.keywrd, " MERS", (ftnlen)241, (ftnlen)5);
mers = (integer) reada_(keywrd_1.keywrd, &i__1, (ftnlen)241);
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L270: */
if (geokst_1.labels[i__ - 1] == 99) {
geokst_1.labels[i__ - 1] = 100;
}
}
gmetry_(geom_1.geo, &coord[4]);
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L280: */
if (geokst_1.labels[i__ - 1] == 100) {
geokst_1.labels[i__ - 1] = 99;
}
}
nan = geokst_1.na[geokst_1.natoms - 2];
nbn = geokst_1.nb[geokst_1.natoms - 2];
ncn = geokst_1.nc[geokst_1.natoms - 2];
i__1 = mers + 1;
for (i__ = 2; i__ <= i__1; ++i__) {
im1 = ioff;
ioff = ioff + geokst_1.natoms - 2;
/* FILL THE NA, NB, AND NC ADDRESSES FOR THE NEW ATOMS */
i__2 = geokst_1.natoms - 2;
for (j = 1; j <= i__2; ++j) {
if (j != 1 && i__ > mers) {
goto L310;
}
s_copy(simbol_1.simbol + (ioff + j - 1) * 10, simbol_1.simbol + (
im1 + j - 1) * 10, (ftnlen)10, (ftnlen)10);
if (ioff + j != geokst_1.natoms - 1) {
geokst_1.na[ioff + j - 1] = geokst_1.na[im1 + j - 1] +
geokst_1.natoms - 2;
geokst_1.nb[ioff + j - 1] = geokst_1.nb[im1 + j - 1] +
geokst_1.natoms - 2;
geokst_1.nc[ioff + j - 1] = geokst_1.nc[im1 + j - 1] +
geokst_1.natoms - 2;
}
geokst_1.labels[ioff + j - 1] = geokst_1.labels[im1 + j - 1];
s_copy(atomtx_1.txtatm + (ioff + j - 1 << 3), atomtx_1.txtatm + (
im1 + j - 1 << 3), (ftnlen)8, (ftnlen)8);
for (k = 1; k <= 3; ++k) {
/* L300: */
coord[k + (ioff + j) * 3] = coord[k + (im1 + j) * 3] +
euler_1.tvec[k - 1];
}
L310:
;
}
if (i__ == 2) {
/* SPECIAL TREATMENT FOR THE FIRST THREE ATOMS OF THE SECOND MER */
geokst_1.na[geokst_1.natoms - 2] = nan;
geokst_1.nb[geokst_1.natoms - 2] = nbn;
geokst_1.nc[geokst_1.natoms - 2] = ncn;
geokst_1.nb[geokst_1.natoms - 1] = geokst_1.na[geokst_1.natoms -
3];
geokst_1.nc[geokst_1.natoms - 1] = geokst_1.nb[geokst_1.natoms -
3];
geokst_1.nc[geokst_1.natoms] = geokst_1.na[geokst_1.natoms - 3];
}
/* # DO 320 J=1,NATOMS-2 */
/* # 320 WRITE(6,'(3I5,3F12.5,3I4)')I,J,LABELS(IFF+J), */
/* # 1(COORD(K,IOFF+J),K=1,3), */
/* # 2NA(IOFF+J), NB(IOFF+J), NC(IOFF+J) */
/* L330: */
}
/* USE ATOMS OF FIRST MER TO DEFINE THE OTHER MERS. FOR ATOMS 1, 2, AND */
/* 3, USE DATA FROM THE SECOND MER. */
i__1 = geokst_1.natoms - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
for (k = 1; k <= 3; ++k) {
if (k >= i__) {
koff = geokst_1.natoms - 2;
joff = 3;
} else {
koff = 0;
joff = 2;
}
i__2 = mers + 1;
for (j = joff; j <= i__2; ++j) {
if (i__ != 1 && j > mers) {
goto L340;
}
++geosym_1.ndep;
geosym_1.locpar[geosym_1.ndep - 1] = i__ + koff;
geosym_1.idepfn[geosym_1.ndep - 1] = k;
geosym_1.locdep[geosym_1.ndep - 1] = (geokst_1.natoms - 2) * (
j - 1) + i__;
L340:
;
}
/* L350: */
}
/* L360: */
}
/* CARTESIAN COORDINATES OF THE TV */
last = (geokst_1.natoms - 2) * mers + 2;
coord[last * 3 + 1] = coord[(ioff + 1) * 3 + 1];
coord[last * 3 + 2] = coord[(ioff + 1) * 3 + 2];
coord[last * 3 + 3] = coord[(ioff + 1) * 3 + 3];
/* REMOVE OPTIMIZATION FLAGS OF LAST TWO ATOMS SUPPLIED BY THE USER */
for (i__ = 1; i__ <= 6; ++i__) {
/* L331: */
if (geovar_1.loc[(geovar_1.nvar << 1) - 2] > geokst_1.natoms - 2) {
--geovar_1.nvar;
}
}
/* PUT ON OPTIMIZATION FLAGES FOR FIRST THREE ATOMS OF THE SECOND MER */
geovar_1.loc[(geovar_1.nvar + 1 << 1) - 2] = geokst_1.natoms - 1;
geovar_1.loc[(geovar_1.nvar + 1 << 1) - 1] = 1;
geovar_1.loc[(geovar_1.nvar + 2 << 1) - 2] = geokst_1.natoms - 1;
geovar_1.loc[(geovar_1.nvar + 2 << 1) - 1] = 2;
geovar_1.loc[(geovar_1.nvar + 3 << 1) - 2] = geokst_1.natoms - 1;
geovar_1.loc[(geovar_1.nvar + 3 << 1) - 1] = 3;
geovar_1.loc[(geovar_1.nvar + 4 << 1) - 2] = geokst_1.natoms;
geovar_1.loc[(geovar_1.nvar + 4 << 1) - 1] = 2;
geovar_1.loc[(geovar_1.nvar + 5 << 1) - 2] = geokst_1.natoms;
geovar_1.loc[(geovar_1.nvar + 5 << 1) - 1] = 3;
geovar_1.loc[(geovar_1.nvar + 6 << 1) - 2] = geokst_1.natoms + 1;
geovar_1.loc[(geovar_1.nvar + 6 << 1) - 1] = 3;
/* RE-DO SPECIFICATION OF THE TV */
geokst_1.labels[last - 2] = 99;
geokst_1.labels[last - 1] = 107;
s_copy(atomtx_1.txtatm + (last - 2 << 3), " ", (ftnlen)8, (ftnlen)1);
s_copy(atomtx_1.txtatm + (last - 1 << 3), " ", (ftnlen)8, (ftnlen)1);
geokst_1.na[last - 1] = 1;
geokst_1.nb[last - 1] = last - 1;
geokst_1.nc[last - 1] = last - 2;
geovar_1.loc[(geovar_1.nvar + 7 << 1) - 2] = last;
geovar_1.loc[(geovar_1.nvar + 7 << 1) - 1] = 1;
/* CONVERT TO INTERNAL COORDINATES. USE CONNECTIVITY CREATED HERE */
degree = 1.;
geokst_1.na[1] = -2;
xyzint_(&coord[4], &last, geokst_1.na, geokst_1.nb, geokst_1.nc, °ree,
geom_1.geo);
/* RE-SIZE THE TRANSLATION VECTOR */
euler_1.tvec[0] = coord[last * 3 + 1];
euler_1.tvec[1] = coord[last * 3 + 2];
euler_1.tvec[2] = coord[last * 3 + 3];
/* THE COORDINATES OF THE FIRST 3 ATOMS NEED TO BE OPTIMIZED */
geovar_1.xparam[geovar_1.nvar] = geom_1.geo[(geokst_1.natoms - 1) * 3 - 3]
;
geovar_1.xparam[geovar_1.nvar + 1] = geom_1.geo[(geokst_1.natoms - 1) * 3
- 2];
geovar_1.xparam[geovar_1.nvar + 2] = geom_1.geo[(geokst_1.natoms - 1) * 3
- 1];
geovar_1.xparam[geovar_1.nvar + 3] = geom_1.geo[geokst_1.natoms * 3 - 2];
geovar_1.xparam[geovar_1.nvar + 4] = geom_1.geo[geokst_1.natoms * 3 - 1];
geovar_1.xparam[geovar_1.nvar + 5] = geom_1.geo[(geokst_1.natoms + 1) * 3
- 1];
geokst_1.natoms = last;
geovar_1.xparam[geovar_1.nvar + 6] = geom_1.geo[geokst_1.natoms * 3 - 3];
geovar_1.nvar += 7;
s_wsfe(&io___14);
i__1 = euler_1.id;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
for (j = 1; j <= 3; ++j) {
do_fio(&c__1, (char *)&euler_1.tvec[j + i__ * 3 - 4], (ftnlen)
sizeof(doublereal));
}
}
e_wsfe();
/* L150: */
s_wsfe(&io___15);
do_fio(&c__1, " EXPANDED POLYMER UNIT CELL", (ftnlen)27);
e_wsfe();
geout_(&c__1);
return 0;
} /* makpol_ */
/* Subroutine */ int initsv_(integer *indeps)
{
/* Initialized data */
static doublereal rvdw[53] = { 1.08,1.,1.8,999.,999.,1.53,1.48,1.36,1.3,
999.,2.3,999.,2.05,2.1,1.75,1.7,1.65,999.,2.8,2.75,999.,999.,999.,
999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,1.8,999.,
999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,
999.,999.,999.,2.05 };
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen), i_dnnt(doublereal *);
double log(doublereal);
integer pow_ii(integer *, integer *);
/* Local variables */
static integer i__, n;
static doublereal x;
static integer i4;
static doublereal x0, z3, z4;
#define iw ((integer *)&chanel_1 + 5)
static integer iat;
static doublereal epsi, avdw;
extern doublereal reada_(char *, integer *, ftnlen);
static doublereal delsc, disex;
#define dirsm ((doublereal *)&solv_1 + 1325)
static doublereal rsolv;
static integer indels, indise;
extern /* Subroutine */ int dvfill_(integer *, doublereal *);
#define dirsmh ((doublereal *)&solv_1 + 4571)
static integer maxnps, inrsol;
static doublereal usevdw[53];
/* Fortran I/O blocks */
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 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 */
for (i__ = 1; i__ <= 53; ++i__) {
/* L10: */
usevdw[i__ - 1] = rvdw[i__ - 1];
}
epsi = reada_(keywrd_1.keywrd, indeps, (ftnlen)241);
solv_1.fepsi = (epsi - 1.) / (epsi + .5);
solvps_1.nps = 0;
*iw = 6;
solv_1.nden = molkst_1.norbs * 3 - (molkst_1.numat << 1);
maxnps = sqrt(324000.25099999999f) - solv_1.nden - .5f;
maxnps = min(maxnps,400);
/* WRITE(IW,*) 'MAXIMUM NUMBER OF SEGMENTS ALLOWED:',MAXNPS */
if (solv_1.nden * (solv_1.nden + 1) / 2 > 162000) {
io___10.ciunit = *iw;
s_wsle(&io___10);
do_lio(&c__9, &c__1, "PARAMETER LENABC IS TOO SMALL FOR THIS SYSTEM",
(ftnlen)45);
e_wsle();
s_stop("PARAMETER LENABC IS TOO SMALL FOR THIS SYSTEM", (ftnlen)45);
}
rsolv = 1.;
inrsol = i_indx(keywrd_1.keywrd, "RSOLV=", (ftnlen)241, (ftnlen)6);
if (inrsol != 0) {
rsolv = reada_(keywrd_1.keywrd, &inrsol, (ftnlen)241);
}
if (rsolv < 0.f) {
s_stop(" RSOLV MUST NOT BE NEGATIVE", (ftnlen)27);
}
delsc = rsolv;
indels = i_indx(keywrd_1.keywrd, "DELSC=", (ftnlen)241, (ftnlen)6);
if (indels != 0) {
delsc = reada_(keywrd_1.keywrd, &indels, (ftnlen)241);
}
if (delsc < .1) {
io___15.ciunit = *iw;
s_wsle(&io___15);
do_lio(&c__9, &c__1, " DELSC TOO SMALL: SET TO 0.1", (ftnlen)28);
e_wsle();
}
if (delsc > rsolv + .5) {
s_stop(" DELSC UNREASONABLY LARGE", (ftnlen)25);
}
solv_1.rds = max(delsc,.1);
disex = 2.;
indise = i_indx(keywrd_1.keywrd, "DISEX=", (ftnlen)241, (ftnlen)6);
if (indise != 0) {
disex = reada_(keywrd_1.keywrd, &indise, (ftnlen)241);
}
i__1 = molkst_1.numat;
for (i__ = 1; i__ <= i__1; ++i__) {
iat = molkst_1.nat[i__ - 1];
if (iat > 53) {
s_stop("MISSING VAN DER WAALS RADIUS", (ftnlen)28);
} else {
avdw = usevdw[iat - 1];
if (avdw > 10.) {
s_stop("MISSING VAN DER WAALS RADIUS", (ftnlen)28);
}
}
solv_1.srad[i__ - 1] = avdw + rsolv;
/* L20: */
}
solv_1.nspa = 60;
if (i_indx(keywrd_1.keywrd, "NSPA=", (ftnlen)241, (ftnlen)5) != 0) {
i__1 = i_indx(keywrd_1.keywrd, "NSPA", (ftnlen)241, (ftnlen)4);
d__1 = reada_(keywrd_1.keywrd, &i__1, (ftnlen)241);
solv_1.nspa = i_dnnt(&d__1);
}
x0 = log(solv_1.nspa * .1 - .199999);
z3 = log(3.);
z4 = log(4.);
i4 = (integer) (x0 / z4);
solvps_1.nps2 = 0;
i__1 = i4;
for (i__ = 0; i__ <= i__1; ++i__) {
x = x0 - i__ * z4;
i__2 = (integer) (x / z3);
n = pow_ii(&c__3, &i__2) * pow_ii(&c__4, &i__);
/* L7: */
if (n > solvps_1.nps2) {
solvps_1.nps2 = n;
}
}
solvps_1.nps = solvps_1.nps2 / 3;
if (solvps_1.nps2 % 3 != 0) {
solvps_1.nps = solvps_1.nps2 / 4;
}
solvps_1.nps2 = solvps_1.nps2 * 10 + 2;
/* Computing MAX */
i__1 = 12, i__2 = solvps_1.nps * 10 + 2;
solvps_1.nps = max(i__1,i__2);
dvfill_(&solvps_1.nps2, dirsm);
dvfill_(&solvps_1.nps, dirsmh);
solvps_1.nps = -solvps_1.nps;
/* Computing 2nd power */
d__1 = (rsolv + 1.5 - solv_1.rds) * 4 * disex;
solv_1.disex2 = d__1 * d__1 / solv_1.nspa;
dvfill_(&c__1082, dirvec_1.dirvec);
return 0;
} /* initsv_ */
/* Subroutine */ int search_(doublereal *xparam, doublereal *alpha,
doublereal *sig, integer *nvar, doublereal *gmin, logical *okf,
doublereal *funct)
{
/* Initialized data */
static integer icalcn = 0;
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
double d_sign(doublereal *, doublereal *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
double sqrt(doublereal);
/* Local variables */
static doublereal g;
static integer i__;
static doublereal ga, gb, ta, tb;
extern doublereal dot_(doublereal *, doublereal *, integer *);
static doublereal sum, grad[360], gref[360], xref[360], gtot;
static logical nopr;
static doublereal tiny, xmin1[360];
static logical debug;
static doublereal gminn;
static integer looks, itrys;
extern /* Subroutine */ int compfg_(doublereal *, logical *, doublereal *,
logical *, doublereal *, logical *);
static doublereal tolerg, gstore;
/* Fortran I/O blocks */
static cilist io___12 = { 0, 6, 0, "(' SEARCH DIRECTION VECTOR')", 0 };
static cilist io___13 = { 0, 6, 0, "(6F12.6)", 0 };
static cilist io___14 = { 0, 6, 0, "(' INITIAL GRADIENT VECTOR')", 0 };
static cilist io___15 = { 0, 6, 0, "(6F12.6)", 0 };
static cilist io___17 = { 0, 6, 0, "(' GRADIENT AT START OF SEARCH:',F16"
".6)", 0 };
static cilist io___27 = { 0, 6, 0, "(' LOOKS',I3,' ALPHA =',F12.6,' GRAD"
"IENT',F12.3, ' G =',F16.6)", 0 };
static cilist io___28 = { 0, 6, 0, "(' AT EXIT FROM SEARCH')", 0 };
static cilist io___29 = { 0, 6, 0, "(' XPARAM',6F12.6)", 0 };
static cilist io___30 = { 0, 6, 0, "(' GNEXT1',6F12.6)", 0 };
static cilist io___31 = { 0, 6, 0, "(' GMIN1 ',6F12.6)", 0 };
static cilist io___32 = { 0, 6, 0, "(' AMIN, ANEXT,GMIN',4F12.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 */
/* *********************************************************************** */
/* SEARCH PERFORMS A LINE SEARCH FOR POWSQ. IT MINIMIZES THE NORM OF */
/* THE GRADIENT VECTOR IN THE DIRECTION SIG. */
/* ON INPUT XPARAM = CURRENT POINT IN NVAR DIMENSIONAL SPACE. */
/* ALPHA = STEP SIZE (IN FACT ALPHA IS CALCULATED IN SEARCH). */
/* SIG = SEARCH DIRECTION VECTOR. */
/* NVAR = NUMBER OF PARAMETERS IN SIG (& XPARAM) */
/* ON OUTPUT XPARAM = PARAMETERS OF MINIMUM. */
/* ALPHA = DISTANCE TO MINIMUM. */
/* GMIN = GRADIENT NORM AT MINIMUM. */
/* OKF = FUNCTION WAS IMPROVED. */
/* *********************************************************************** */
/* Parameter adjustments */
--sig;
--xparam;
/* Function Body */
if (icalcn != numcal_1.numcal) {
icalcn = numcal_1.numcal;
/* TOLG = CRITERION FOR EXIT BY RELATIVE CHANGE IN GRADIENT. */
debug = i_indx(keywrd_1.keywrd, "LINMIN", (ftnlen)241, (ftnlen)6) !=
0;
nopr = ! debug;
looks = 0;
*okf = TRUE_;
tiny = .1;
tolerg = .02;
g = 100.;
*alpha = .1;
}
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
gref[i__ - 1] = sigma2_1.gmin1[i__ - 1];
sigma2_1.gnext1[i__ - 1] = sigma2_1.gmin1[i__ - 1];
xmin1[i__ - 1] = xparam[i__];
/* L10: */
xref[i__ - 1] = xparam[i__];
}
if (abs(*alpha) > .2f) {
*alpha = d_sign(&c_b4, alpha);
}
if (debug) {
s_wsfe(&io___12);
e_wsfe();
s_wsfe(&io___13);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&sig[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
s_wsfe(&io___14);
e_wsfe();
s_wsfe(&io___15);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&sigma2_1.gmin1[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
gb = dot_(sigma2_1.gmin1, gref, nvar);
if (debug) {
s_wsfe(&io___17);
d__1 = sqrt(gb);
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
}
gstore = gb;
sigma1_1.amin = 0.;
gminn = 1e9;
ta = 0.;
ga = gb;
gb = 1e9;
itrys = 0;
goto L30;
L20:
sum = ga / (ga - gb);
++itrys;
if (abs(sum) > 3.) {
sum = d_sign(&c_b17, &sum);
}
*alpha = (tb - ta) * sum + ta;
/* XPARAM IS THE GEOMETRY OF THE PREDICTED MINIMUM ALONG THE LINE */
L30:
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L40: */
xparam[i__] = xref[i__ - 1] + *alpha * sig[i__];
}
/* CALCULATE GRADIENT NORM AND GRADIENTS AT THE PREDICTED MINIMUM */
if (itrys == 1) {
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L50: */
grad[i__ - 1] = 0.;
}
}
compfg_(&xparam[1], &c_true, funct, &c_true, grad, &c_true);
++looks;
/* G IS THE PROJECTION OF THE GRADIENT ALONG SIG. */
g = dot_(gref, grad, nvar);
gtot = sqrt(dot_(grad, grad, nvar));
if (! nopr) {
s_wsfe(&io___27);
do_fio(&c__1, (char *)&looks, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*alpha), (ftnlen)sizeof(doublereal));
d__1 = sqrt(dot_(grad, grad, nvar));
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&g, (ftnlen)sizeof(doublereal));
e_wsfe();
}
if (gtot < gminn) {
gminn = gtot;
if ((d__1 = sigma1_1.amin - *alpha, abs(d__1)) > .01) {
/* WE CAN MOVE ANEXT TO A POINT NEAR, BUT NOT TOO NEAR, AMIN, SO THAT THE */
/* SECOND DERIVATIVESWILLBEREALISTIC(D2E/DX2=(GNEXT1-GMIN1)/(ANEXT-AMIN)) */
sigma1_1.anext = sigma1_1.amin;
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L60: */
sigma2_1.gnext1[i__ - 1] = sigma2_1.gmin1[i__ - 1];
}
}
sigma1_1.amin = *alpha;
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
if (gminn < *gmin) {
xmin1[i__ - 1] = xparam[i__];
}
/* L70: */
sigma2_1.gmin1[i__ - 1] = grad[i__ - 1];
}
if (*gmin > gminn) {
*gmin = gminn;
}
}
if (itrys > 8) {
goto L80;
}
if ((d__1 = g / gstore, abs(d__1)) < tiny || abs(g) < tolerg) {
goto L80;
}
/* Computing MAX */
d__1 = abs(ga), d__2 = abs(gb);
if (abs(g) < max(d__1,d__2) || ga * gb > 0. && g * ga < 0.) {
/* G IS AN IMPROVEMENT ON GA OR GB. */
if (abs(gb) < abs(ga)) {
ta = *alpha;
ga = g;
goto L20;
} else {
tb = *alpha;
gb = g;
goto L20;
}
} else {
/* # WRITE(6,'(//10X,'' FAILED IN SEARCH, SEARCH CONTINUING'')') */
goto L80;
}
L80:
gminn = sqrt(dot_(sigma2_1.gmin1, sigma2_1.gmin1, nvar));
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L90: */
xparam[i__] = xmin1[i__ - 1];
}
if (debug) {
s_wsfe(&io___28);
e_wsfe();
s_wsfe(&io___29);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&xparam[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
s_wsfe(&io___30);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&sigma2_1.gnext1[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
s_wsfe(&io___31);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&sigma2_1.gmin1[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
s_wsfe(&io___32);
do_fio(&c__1, (char *)&sigma1_1.amin, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&sigma1_1.anext, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*gmin), (ftnlen)sizeof(doublereal));
e_wsfe();
}
if (gminn > *gmin) {
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
xparam[i__] = xref[i__ - 1];
}
}
return 0;
} /* search_ */
/* $Procedure SIGDGT ( Retain significant digits ) */
/* Subroutine */ int sigdgt_(char *in, char *out, ftnlen in_len, ftnlen
out_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
extern integer cpos_(char *, char *, integer *, ftnlen, ftnlen);
integer zero, i__, j, k, l, begin;
char lchar[1];
extern integer lastnb_(char *, ftnlen), frstnb_(char *, ftnlen);
integer end;
/* $ Abstract */
/* Retain only the significant digits in a numeric string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CHARACTER, PARSING */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* IN I Input numeric string. */
/* OUT O Numeric string, with insignificant digits removed. */
/* $ Detailed_Input */
/* IN is a numeric string. */
/* $ Detailed_Output */
/* OUT is the same numeric string with insignificant */
/* zeros and spaces removed. The special case '.000...' */
/* becomes just '0'. OUT may overwrite IN. If the */
/* output string is too long, it is truncated on the */
/* right. */
/* $ Parameters */
/* None. */
/* $ Particulars */
/* There are only two interesting cases: */
/* 1) There is a decimal point and an exponent immediately */
/* preceded by zero ('...0E', '...0D', '...0e', '...0d') */
/* or by a space ('... E', '... D', '... e', '... d'). */
/* 2) There is a decimal point and no exponent, and the last non- */
/* blank character is a zero ('...0'). */
/* In each of these cases, go to the zero in question, and step */
/* backwards until you find something other than a blank or a zero. */
/* Finally, remove all leading spaces, and all occurrences of more */
/* than one consecutive space within the string. */
/* $ Examples */
/* The following examples illustrate the use of SIGDGT. */
/* '0.123456000000D-04' becomes '0.123456D-04' */
/* ' -9.2100000000000' '-9.21' */
/* ' 13' '13' */
/* ' 00013' '00013' */
/* ' .314 159 265 300 000 e1' '.314 159 265 3e1' */
/* ' 123 45 6' '123 45 6' */
/* ' .000000000' '0' */
/* $ Restrictions */
/* None. */
/* $ Exceptions */
/* Error free. */
/* If IN is a non-numeric string, the contents of OUT are */
/* unpredictable. */
/* $ Files */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* retain significant digits */
/* -& */
/* $ Revisions */
/* - Beta Version 1.3.0, 21-MAR-1989 (WLT) */
/* Previous fix was unbelievably bad, very buggy. This */
/* has been fixed along with other bugs and non-standard */
/* code has been removed. */
/* - Beta Version 1.2.0, 28-FEB-1989 (WLT) */
/* Reference to INSSUB replaced by SUFFIX */
/* - Beta Version 1.1.1, 17-FEB-1989 (HAN) (NJB) */
/* Declaration of the unused function ISRCHC removed. */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Find the first and last non-blank characters in the string. */
/* Computing MAX */
i__1 = 1, i__2 = frstnb_(in, in_len);
begin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = lastnb_(in, in_len);
end = max(i__1,i__2);
*(unsigned char *)lchar = ' ';
/* Trivial case. */
if (begin == end) {
*(unsigned char *)out = *(unsigned char *)&in[begin - 1];
if (i_len(out, out_len) > 1) {
s_copy(out + 1, " ", out_len - 1, (ftnlen)1);
}
/* If there is no decimal point, all zeros are significant. */
} else if (i_indx(in, ".", in_len, (ftnlen)1) == 0) {
l = 1;
k = begin;
while(l <= i_len(out, out_len) && k <= end) {
*(unsigned char *)&out[l - 1] = *(unsigned char *)&in[k - 1];
/* Don't increment L if the last item copied was a space */
/* (we don't want to copy extra spaces). */
if (*(unsigned char *)&in[k - 1] != ' ' || *(unsigned char *)
lchar != ' ') {
++l;
}
*(unsigned char *)lchar = *(unsigned char *)&in[k - 1];
++k;
}
if (l <= i_len(out, out_len)) {
s_copy(out + (l - 1), " ", out_len - (l - 1), (ftnlen)1);
}
} else {
/* Is there is a decimal point and an exponent immediately */
/* preceded by zero ('...0E', '...0D', '...0e', '...0d') or */
/* by a space ('... E', '... D', '... e', '... d')? */
zero = i_indx(in, "0E", in_len, (ftnlen)2);
if (zero == 0) {
zero = i_indx(in, "0D", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, "0e", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, "0d", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, " E", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, " D", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, " e", in_len, (ftnlen)2);
}
if (zero == 0) {
zero = i_indx(in, " d", in_len, (ftnlen)2);
}
/* Begin there, and move toward the front of the string until */
/* something other than a blank or a zero is encountered. Then */
/* remove the superfluous characters. */
if (zero > 0) {
j = zero + 1;
i__ = zero;
while(*(unsigned char *)&in[i__ - 1] == '0' || *(unsigned char *)&
in[i__ - 1] == ' ') {
--i__;
}
l = 1;
k = begin;
while(l <= i_len(out, out_len) && k <= i__) {
*(unsigned char *)&out[l - 1] = *(unsigned char *)&in[k - 1];
/* Don't increment L if the last item copied was a space. */
if (*(unsigned char *)&in[k - 1] != ' ' || *(unsigned char *)
lchar != ' ') {
++l;
}
*(unsigned char *)lchar = *(unsigned char *)&in[k - 1];
++k;
}
k = j;
while(l <= i_len(out, out_len) && k <= end) {
*(unsigned char *)&out[l - 1] = *(unsigned char *)&in[k - 1];
/* Increment L only if we don't have two consecutive */
/* spaces. */
if (*(unsigned char *)&in[k - 1] != ' ' || *(unsigned char *)
lchar != ' ') {
++l;
}
*(unsigned char *)lchar = *(unsigned char *)&in[k - 1];
++k;
}
if (l <= i_len(out, out_len)) {
s_copy(out + (l - 1), " ", out_len - (l - 1), (ftnlen)1);
}
/* Is there is a decimal point and no exponent, and is the last */
/* non-blank character a zero ('...0')? Then truncate the string */
/* after the last character that is neither a blank nor a zero. */
} else if (*(unsigned char *)&in[end - 1] == '0' && cpos_(in, "EeDd",
&c__1, in_len, (ftnlen)4) == 0) {
i__ = end;
while(*(unsigned char *)&in[i__ - 1] == '0' || *(unsigned char *)&
in[i__ - 1] == ' ') {
--i__;
}
l = 1;
k = begin;
while(l <= i_len(out, out_len) && k <= i__) {
*(unsigned char *)&out[l - 1] = *(unsigned char *)&in[k - 1];
/* Increment L only if we don't have two consecutive */
/* spaces. */
if (*(unsigned char *)&in[k - 1] != ' ' || *(unsigned char *)
lchar != ' ') {
++l;
}
*(unsigned char *)lchar = *(unsigned char *)&in[k - 1];
++k;
}
if (l <= i_len(out, out_len)) {
s_copy(out + (l - 1), " ", out_len - (l - 1), (ftnlen)1);
}
} else {
l = 1;
k = begin;
while(l <= i_len(out, out_len) && k <= end) {
*(unsigned char *)&out[l - 1] = *(unsigned char *)&in[k - 1];
/* Increment L only if we don't have two consecutive spaces. */
if (*(unsigned char *)&in[k - 1] != ' ' || *(unsigned char *)
lchar != ' ') {
++l;
}
*(unsigned char *)lchar = *(unsigned char *)&in[k - 1];
++k;
}
if (l <= i_len(out, out_len)) {
s_copy(out + (l - 1), " ", out_len - (l - 1), (ftnlen)1);
}
}
}
/* Special case. The string '.0000....' reduces to '.' after the */
/* zeros are removed. */
if (s_cmp(out, ".", out_len, (ftnlen)1) == 0) {
s_copy(out, "0", out_len, (ftnlen)1);
}
return 0;
} /* sigdgt_ */
/* Subroutine */ int dhcore_(doublereal *coord, doublereal *h__, doublereal *
w, doublereal *enuclr, integer *nati, integer *natx, doublereal *step)
{
/* Initialized data */
static integer nb[9] = { 1,0,0,10,0,0,0,0,45 };
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer i__, j, k, i1, i2, j2, j1, j7, ia, ib, ic;
static doublereal di[81] /* was [9][9] */;
static integer ja, jb, jc, ii, ij, ni, nj, kr;
static doublereal e1b[10], e2a[10], ddi[81] /* was [9][9] */, wjd[101];
static integer kro;
static doublereal de1b[10], de2a[10], dwjd[101], enuc;
static integer nrow;
static doublereal denuc, csave;
static logical mindo;
extern /* Subroutine */ int h1elec_(integer *, integer *, doublereal *,
doublereal *, doublereal *);
static integer nband2;
static doublereal cutoff;
extern /* Subroutine */ int rotate_(integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *);
/* 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 */
/* DHCORE GENERATES THE 1-ELECTRON AND 2-ELECTRON INTEGRALS DERIVATIVES */
/* WITH RESPECT TO THE CARTESIAN COORDINATE COORD (NATX,NATI). */
/* INPUT */
/* COORD : CARTESIAN COORDINATES OF THE MOLECULE. */
/* NATI,NATX : INDICES OF THE MOVING COORDINATE. */
/* STEP : STEP SIZE OF THE 2-POINTS FINITE DIFFERENCE. */
/* OUTPUT */
/* H : 1-ELECTRON INTEGRALS DERIVATIVES (PACKED CANONICAL). */
/* W : 2-ELECTRON INTEGRALS DERIVATIVES (ORDERED AS REQUIRED */
/* IN DFOCK2 AND DIJKL1). */
/* ENUCLR : NUCLEAR ENERGY DERIVATIVE. */
/* Parameter adjustments */
--w;
--h__;
coord -= 4;
/* Function Body */
if (first) {
cutoff = 1e10;
first = FALSE_;
mindo = i_indx(keywrd_1.keywrd, "MINDO", (ftnlen)241, (ftnlen)5) != 0;
}
i__1 = molkst_2.norbs * (molkst_2.norbs + 1) / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
h__[i__] = 0.;
}
*enuclr = 0.;
kr = 1;
nrow = 0;
i__ = *nati;
csave = coord[*natx + *nati * 3];
ia = molkst_2.nfirst[*nati - 1];
ib = molkst_2.nlast[*nati - 1];
ic = molkst_2.nmidle[*nati - 1];
ni = molkst_2.nat[*nati - 1];
nrow = -nb[ib - ia];
i__1 = molkst_2.numat;
for (j = 1; j <= i__1; ++j) {
/* L20: */
nrow += nb[molkst_2.nlast[j - 1] - molkst_2.nfirst[j - 1]];
}
/* # NCOL=NB(NLAST(NATI)-NFIRST(NATI)) */
nband2 = 0;
i__1 = molkst_2.numat;
for (j = 1; j <= i__1; ++j) {
if (j == *nati) {
goto L120;
}
ja = molkst_2.nfirst[j - 1];
jb = molkst_2.nlast[j - 1];
jc = molkst_2.nmidle[j - 1];
nj = molkst_2.nat[j - 1];
coord[*natx + *nati * 3] = csave + *step;
h1elec_(&ni, &nj, &coord[*nati * 3 + 1], &coord[j * 3 + 1], di);
/* THE FOLLOWING STYLE WAS NECESSARY TO GET ROUND A BUG IN THE */
/* GOULD COMPILER */
coord[*natx + *nati * 3] = csave + *step * -1.;
h1elec_(&ni, &nj, &coord[*nati * 3 + 1], &coord[j * 3 + 1], ddi);
/* FILL THE ATOM-OTHER ATOM ONE-ELECTRON MATRIX. */
i2 = 0;
if (ia > ja) {
i__2 = ib;
for (i1 = ia; i1 <= i__2; ++i1) {
ij = i1 * (i1 - 1) / 2 + ja - 1;
++i2;
j2 = 0;
i__3 = jb;
for (j1 = ja; j1 <= i__3; ++j1) {
++ij;
++j2;
/* L30: */
h__[ij] += di[i2 + j2 * 9 - 10] - ddi[i2 + j2 * 9 - 10];
}
}
} else {
i__3 = jb;
for (i1 = ja; i1 <= i__3; ++i1) {
ij = i1 * (i1 - 1) / 2 + ia - 1;
++i2;
j2 = 0;
i__2 = ib;
for (j1 = ia; j1 <= i__2; ++j1) {
++ij;
++j2;
/* L40: */
h__[ij] += di[j2 + i2 * 9 - 10] - ddi[j2 + i2 * 9 - 10];
}
}
}
/* CALCULATE THE TWO-ELECTRON INTEGRALS, W; THE ELECTRON NUCLEAR TERM */
/* E1B AND E2A; AND THE NUCLEAR-NUCLEAR TERM ENUC. */
kro = kr;
nband2 += nb[molkst_2.nlast[j - 1] - molkst_2.nfirst[j - 1]];
if (mindo) {
coord[*natx + *nati * 3] = csave + *step;
rotate_(&ni, &nj, &coord[*nati * 3 + 1], &coord[j * 3 + 1], wjd, &
kr, e1b, e2a, &enuc, &cutoff);
kr = kro;
coord[*natx + *nati * 3] = csave + *step * -1.;
rotate_(&ni, &nj, &coord[*nati * 3 + 1], &coord[j * 3 + 1], dwjd,
&kr, de1b, de2a, &denuc, &cutoff);
if (kr > kro) {
i__2 = kr - kro + 1;
for (k = 1; k <= i__2; ++k) {
/* L50: */
w[kro + k - 1] = wjd[k - 1] - dwjd[k - 1];
}
}
} else {
coord[*natx + *nati * 3] = csave + *step;
rotate_(&ni, &nj, &coord[*nati * 3 + 1], &coord[j * 3 + 1], wjd, &
kr, e1b, e2a, &enuc, &cutoff);
kr = kro;
coord[*natx + *nati * 3] = csave + *step * -1.;
rotate_(&ni, &nj, &coord[*nati * 3 + 1], &coord[j * 3 + 1], dwjd,
&kr, de1b, de2a, &denuc, &cutoff);
if (kr > kro) {
i__2 = kr - kro + 1;
for (k = 1; k <= i__2; ++k) {
/* L60: */
wjd[k - 1] -= dwjd[k - 1];
}
j7 = 0;
i__2 = kr;
for (i1 = kro; i1 <= i__2; ++i1) {
++j7;
/* L70: */
w[i1] = wjd[j7 - 1];
}
}
}
coord[*natx + *nati * 3] = csave;
*enuclr = *enuclr + enuc - denuc;
/* ADD ON THE ELECTRON-NUCLEAR ATTRACTION TERM FOR ATOM I. */
i2 = 0;
i__2 = ic;
for (i1 = ia; i1 <= i__2; ++i1) {
ii = i1 * (i1 - 1) / 2 + ia - 1;
i__3 = i1;
for (j1 = ia; j1 <= i__3; ++j1) {
++ii;
++i2;
/* L80: */
h__[ii] = h__[ii] + e1b[i2 - 1] - de1b[i2 - 1];
}
}
/* CONTRIB D, CNDO. */
i__3 = ib;
for (i1 = ic + 1; i1 <= i__3; ++i1) {
ii = i1 * (i1 + 1) / 2;
/* L90: */
h__[ii] = h__[ii] + e1b[0] - de1b[0];
}
/* ADD ON THE ELECTRON-NUCLEAR ATTRACTION TERM FOR ATOM J. */
i2 = 0;
i__3 = jc;
for (i1 = ja; i1 <= i__3; ++i1) {
ii = i1 * (i1 - 1) / 2 + ja - 1;
i__2 = i1;
for (j1 = ja; j1 <= i__2; ++j1) {
++ii;
++i2;
/* L100: */
h__[ii] = h__[ii] + e2a[i2 - 1] - de2a[i2 - 1];
}
}
/* CONTRIB D, CNDO. */
i__2 = jb;
for (i1 = jc + 1; i1 <= i__2; ++i1) {
ii = i1 * (i1 + 1) / 2;
/* L110: */
h__[ii] = h__[ii] + e2a[0] - de2a[0];
}
L120:
;
}
/* 'SIZE' OF H IS NROW * NCOL */
return 0;
} /* dhcore_ */
/* 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_ */
/* Subroutine */ int prcomf_0_(int n__, char *file, char *delim, char *
command, char *error, char *level, ftnlen file_len, ftnlen delim_len,
ftnlen command_len, ftnlen error_len, ftnlen level_len)
{
/* Initialized data */
static integer nest = 0;
/* System generated locals */
integer i__1;
cilist ci__1;
cllist cl__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), f_clos(cllist *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern logical have_(char *, ftnlen);
static integer i__, j;
static char files[80*8];
static integer units[8];
extern /* Subroutine */ int lbuild_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
extern integer lastnb_(char *, ftnlen);
static integer iostat;
extern /* Subroutine */ int rstbuf_(void), putbuf_(char *, ftnlen),
txtopr_(char *, integer *, ftnlen);
/* $ Abstract */
/* Keep track of nested command files. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Keywords */
/* PARSE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* FILE I Command file. */
/* DELIM I Symbol delimiting the end of a command. */
/* COMMAND O Command read from FILE. */
/* ERROR O Error flag. */
/* LEVEL O A list of all files currently open. */
/* $ Detailed_Input */
/* FILE is the name of a file from which a sequence of commands */
/* is to be read. These commands may include commands to */
/* read from other files. */
/* DELIM is the character which delimits the end of each */
/* instruction in FILE. */
/* $ Detailed_Output */
/* COMMAND is a command read from the current file. */
/* If no files are currently open, COMMAND = DELIM. */
/* ERROR is a descriptive error message, which is blank when */
/* no error occurs. */
/* LEVEL is a list of the files currently open, in the order */
/* in which they were opened. It is provided for trace- */
/* back purposes. */
/* $ Detailed_Description */
/* PRCOMF opens, reads, and closes sets of (possibly nested) */
/* command files. For example, consider the following command */
/* files. */
/* FILE_A : A1 FILE_B : B1 FILE_C : C1 */
/* A2 START FILE_C C2 */
/* A3 B2 C3 */
/* START FILE_B B3 */
/* A4 B4 */
/* A5 */
/* If the command 'START FILE_A' were issued, we would expect the */
/* following sequence of commands to ensue: */
/* A1, A2, A3, B1, C1, C2, C3, B2, B3, B4, A4, A5. */
/* The first file immediately becomes, ipso facto, the current file. */
/* Subsequently, instructions are read from the current file until */
/* either a START or the end of the file is encountered. Each time */
/* a new START is encountered, the current file (that is, the */
/* location of the next command in the file) is placed on a stack, */
/* and the first command is read from the new file (which then */
/* becomes the current file). Each time the end of the current file */
/* is encountered, the previous file is popped off the top of the */
/* stack to become the current file. This continues until there are */
/* no files remaining on the stack. */
/* On occasion, the user may wish to exit from a file without */
/* reading the rest of the file. In this case, the previous file */
/* is popped off the stack without further ado. */
/* Also, the user may wish to abruptly stop an entire nested */
/* set of files. In this case, all of the files are popped off */
/* the stack, and no further commands are returned. */
/* PRCOMF and its entry points may be used to process any such */
/* set of files. These entry points are: */
/* - PRCLR ( ERROR ) */
/* This clears the stack. It may thus be used to implement */
/* a STOP command. In any case, it must be called before */
/* any of the other entry points are called. */
/* - PRSTRT ( FILE, ERROR ) */
/* This introduces a new file, causing the current file (if */
/* any) to be placed on the stack, and replacing it with FILE. */
/* It may thus be used to implement a START command. */
/* If the file cannot be opened, or the stack is already */
/* full (it can hold up to seven files), ERROR will contain */
/* a descriptive error message upon return. Otherwise, it */
/* will be blank. */
/* - PRREAD ( COMMAND ) */
/* This causes the next command to be read from the current */
/* file. If the end of the current file is reached, the */
/* previous file is popped off the stack, and the next command */
/* from this file is read instead. (If no files remain to be */
/* read, DELIM is returned.) */
/* - PREXIT */
/* This causes the previous file to be popped off the top of */
/* the stack to replace the current file. It may thus be used */
/* to implement an EXIT command. */
/* - PRTRCE ( LEVEL ) */
/* Should an error occur during the execution of a nested */
/* file, it may be helpful to know the sequence in which */
/* the nested files were invoked. PRTRCE returns a list of */
/* the files currently open, in the order in which they were */
/* invoked. */
/* $ Input_Files */
/* All files read by PRCOMF are opened with logical units */
/* determined at run time. */
/* $ Output_Files */
/* None. */
/* $ Input_Common */
/* None. */
/* $ Output_Common */
/* None. */
/* $ Examples */
/* See Detailed_Description. */
/* $ Restrictions */
/* The declared length of ERROR should be at least 80, to avoid */
/* truncationof error messages. */
/* $ Author_and_Institution */
/* W. L. Taber (JPL) */
/* I. M. Underwood (JPL) */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* Version 1, 6-SEP-1986 */
/* -& */
/* OPTLIB functions */
/* Local variables */
/* NFILES is the maximum number of files that may be open at */
/* any given time. THus, nesting of procedures is limited to */
/* a depth of NFILES. */
/* NEST is the number of files currently open. */
/* FILES are the names of the files on the stack. UNITS are */
/* the logical units to which they are connected. */
switch(n__) {
case 1: goto L_prclr;
case 2: goto L_prstrt;
case 3: goto L_prread;
case 4: goto L_prexit;
case 5: goto L_prtrce;
}
return 0;
/* $ Procedure PRCLR */
L_prclr:
/* $ Abstract */
/* Clear the file stack. */
/* $ 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. */
/* $ Brief_I/O */
/* None. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* None. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Pop all the files off the stack. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
while(nest > 0) {
cl__1.cerr = 0;
cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)326)];
cl__1.csta = 0;
f_clos(&cl__1);
--nest;
}
return 0;
/* $ Procedure PRSTRT */
L_prstrt:
/* $ Abstract */
/* Put the current file on the stack, and replace it with FILE. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* FILE I New command file. */
/* ERROR O Error flag. */
/* $ Detailed_Input */
/* FILE is the new current file from which commands are */
/* to be read. */
/* $ Detailed_Output */
/* ERROR is blank when no error occurs, and otherwise contains */
/* a descriptive message. Possible errors are: */
/* - The stack is full. */
/* - FILE could not be opened. */
/* $ Input_Files */
/* FILE is opened with a logical unit determined at run time. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* If the stack is full, return an error. Otherwise, try to open */
/* FILE. If an error occurs, return immediately. Otherwise, put */
/* the current file on the stack, and increase the nesting level. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
/* No error yet. */
s_copy(error, " ", error_len, (ftnlen)1);
/* Proceed only if the stack is not full. */
if (nest == 8) {
s_copy(error, "PRSTRT: Command files are nested too deeply.",
error_len, (ftnlen)44);
return 0;
} else {
++nest;
}
/* Get a new logical unit. If none are available, abort. */
txtopr_(file, &units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
"units", i__1, "prcomf_", (ftnlen)445)], file_len);
if (have_(error, error_len)) {
--nest;
} else {
s_copy(files + ((i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
"files", i__1, "prcomf_", (ftnlen)450)) * 80, file, (ftnlen)
80, file_len);
}
return 0;
/* $ Procedure PRREAD */
L_prread:
/* $ Abstract */
/* Read the next command from the current file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* DELIM I Character delimiting the end of a command. */
/* COMMAND O Next command from the current file. */
/* $ Detailed_Input */
/* DELIM is the character used to delimit the end of a */
/* command within a command file. */
/* $ Detailed_Output */
/* COMMAND is the next command read from the current file. */
/* If there is no current file, COMMND = DELIM. */
/* $ Input_Files */
/* All files read by PRCOMF are opened with logical units */
/* determined at run time. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Attempt to read the next statement from the current file. */
/* If the end of the file is encountered, pop the previous file */
/* off the top of the stack, and try to read from it. Keep this */
/* up until a command is read, or until no files remain open. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
/* Don't even bother unless at least one file is open. */
if (nest == 0) {
s_copy(command, delim, command_len, (ftnlen)1);
return 0;
}
/* Keep trying to read until we run out of files. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
"units", i__1, "prcomf_", (ftnlen)558)];
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, command, command_len);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
while(iostat != 0 && nest > 0) {
cl__1.cerr = 0;
cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)562)];
cl__1.csta = 0;
f_clos(&cl__1);
--nest;
if (nest >= 1) {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)566)];
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, command, command_len);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsfe();
L100002:
;
}
}
rstbuf_();
if (nest == 0) {
s_copy(command, delim, command_len, (ftnlen)1);
putbuf_(command, command_len);
return 0;
}
putbuf_(command, command_len);
/* Okay, we have something. Keep reading until DELIM is found. */
/* (Or until the file ends.) Add each successive line read to */
/* the end of COMMAND. Do not return the delimiter itself. */
j = 1;
i__ = i_indx(command, delim, command_len, (ftnlen)1);
while(i__ == 0 && iostat == 0) {
j = lastnb_(command, command_len) + 1;
*(unsigned char *)&command[j - 1] = ' ';
++j;
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)597)];
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, command + (j - 1), command_len - (j - 1));
if (iostat != 0) {
goto L100003;
}
iostat = e_rsfe();
L100003:
putbuf_(command + (j - 1), command_len - (j - 1));
i__ = i_indx(command, delim, command_len, (ftnlen)1);
}
if (i__ > 0) {
s_copy(command + (i__ - 1), " ", command_len - (i__ - 1), (ftnlen)1);
}
return 0;
/* $ Procedure PREXIT */
L_prexit:
/* $ Abstract */
/* Replace the current file with the one at the top of the stack. */
/* $ 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. */
/* $ Brief_I/O */
/* None. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* None. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Close the current file. Pop the previous file off the top of */
/* the stack. If there is no current file, of if there are no */
/* files on the stack, that's cool too. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
if (nest > 0) {
cl__1.cerr = 0;
cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)695)];
cl__1.csta = 0;
f_clos(&cl__1);
--nest;
}
return 0;
/* $ Procedure PRTRCE */
L_prtrce:
/* $ Abstract */
/* Provide a list of the files currently open, in the order in */
/* which they were opened. */
/* $ 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. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* LEVEL O List of all files currently open. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* LEVEL A list of all files that are currently open, in */
/* the order in which they were opened. For example, */
/* if FILE_A starts FILE_B, and FILE_B starts FILE_C, */
/* LEVEL would be 'FILE_A:FILE_B:_FILE_C'. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Just step through the stack, Jack. */
/* $ Examples */
/* See Detailed_Description. */
/* $ Restrictions */
/* LEVEL should be declared to be at least CHARACTER*640 by the */
/* calling program to ensure that enough space is available to */
/* list all open files. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
/* Not much to explain. Use LBUILD to build a list, delimited */
/* by colons. */
s_copy(level, " ", level_len, (ftnlen)1);
if (nest > 0) {
lbuild_(files, &nest, ":", level, (ftnlen)80, (ftnlen)1, level_len);
}
return 0;
} /* prcomf_ */
/* $Procedure STRAN */
/* Subroutine */ int stran_0_(int n__, char *input, char *output, logical *
tran, ftnlen input_len, ftnlen output_len)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen), s_rnge(char *, integer, char *, integer), i_len(
char *, ftnlen);
/* Local variables */
static integer ldef, leno, vdim, slot, lout, lsym, ptrs[810], i__, j;
extern integer cardc_(char *, ftnlen);
static integer l, n;
static logical check[200];
extern logical batch_(void);
static integer place;
extern /* Subroutine */ int lcase_(char *, char *, ftnlen, ftnlen);
static char delim[1];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static integer nname;
extern /* Subroutine */ int ucase_(char *, char *, ftnlen, ftnlen);
static char names[32*206];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen),
geteq_(char *, ftnlen);
extern integer ncpos_(char *, char *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int nthwd_(char *, integer *, char *, integer *,
ftnlen, ftnlen);
static char symbl[33];
static integer psize;
extern integer rtrim_(char *, ftnlen);
static logical checkd[200];
extern logical failed_(void);
static char alphab[32];
extern /* Subroutine */ int getdel_(char *, ftnlen);
extern logical matchm_(char *, char *, char *, char *, char *, char *,
ftnlen, ftnlen, ftnlen, ftnlen, ftnlen, ftnlen);
static char buffer[256*52];
extern integer isrchc_(char *, integer *, char *, ftnlen, ftnlen),
lastnb_(char *, ftnlen);
static logical gotone;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), repsub_(char *, integer *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
static char equote[1];
extern /* Subroutine */ int setmsg_(char *, ftnlen);
static char resvrd[32*12], symbol[33], pattrn[80];
static integer nxtchr;
extern /* Subroutine */ int suffix_(char *, integer *, char *, ftnlen,
ftnlen), rdstmn_(char *, char *, char *, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
extern /* Subroutine */ int sbget_1__(char *, char *, integer *, char *,
char *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), nthuqw_(char *
, integer *, char *, char *, integer *, ftnlen, ftnlen, ftnlen);
static char myprmt[80];
extern /* Subroutine */ int sbrem_1__(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
static integer lsttry;
extern /* Subroutine */ int sbset_1__(char *, char *, char *, integer *,
char *, ftnlen, ftnlen, ftnlen, ftnlen);
static char def[1024];
static integer loc;
static char key[32];
static logical new__;
extern /* Subroutine */ int sbinit_1__(integer *, integer *, integer *,
char *, integer *, char *, ftnlen, ftnlen);
/* $ Abstract */
/* Translate the symbols in an input string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Keywords */
/* PARSE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* INPUT I Input string containing symbols to be translated. */
/* OUTPUT O Output string, with all symbols translated. */
/* $ Detailed_Input */
/* INPUT is the input string to be translated. INPUT may contain */
/* any number of known symbols. */
/* $ Detailed_Output */
/* OUTPUT is the translation of the input string. The first */
/* of the symbols in INPUT will have been translated. */
/* When INPUT is either a DEFINE or an UNDEFINE command, */
/* OUTPUT is blank. */
/* OUTPUT may overwrite INPUT. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Exceptions */
/* The following exceptions are detected by this routine: */
/* 1) Attempt to define or undefine a symbol that does */
/* not begin with a letter. */
/* 2) Attempt to define or undefine a symbol that ends with */
/* a question mark '?' . */
/* 3) Failure to specify a symbol to define or undefine. */
/* 4) Attempting to define a reserved word. The reserved */
/* words are: */
/* 'START' */
/* 'STOP' */
/* 'EXIT' */
/* 'INQUIRE' */
/* 'SHOW' */
/* 'DEFINE' */
/* 'SHOW' */
/* 'UNDEFINE' */
/* 'HELP' */
/* In all of the above cases OUTPUT is set to blank and TRAN to */
/* FALSE. No new symbol is placed in the table of symbol */
/* definitions. */
/* In all of these cases the error BAD_SYMBOL_SPC is signalled. */
/* 5) Recursive symbol definitions are detected and disallowed. */
/* A long error message diagnosing the problem is set and */
/* the error RECURSIVE_SYMBOL is signalled. */
/* 5) Overflow of the input command caused by symbol resolution. */
/* In this case the OUTPUT is left at the state it had reached */
/* prior to the overflow condition and TRAN is returned as */
/* FALSE. The error SYMBOL_OVERFLOW is signalled. */
/* $ Detailed_Description */
/* A new symbol may be defined with the DEFINE command. The */
/* syntax is: */
/* DEFINE <symbol> <definition> */
/* where <symbol> is a valid symbol name and <definition> is any */
/* valid definition. The DEFINE command, the symbol name, and the */
/* definition are delimited by blanks. */
/* When a symbol is defined, the symbol and definition are inserted */
/* into the symbol table. */
/* An existing symbol may be removed from the table with the */
/* UNDEFINE command. The syntax is: */
/* UNDEFINE <symbol> */
/* where <symbol> is the name of an existing symbol. The UNDEFINE */
/* command and the symbol name are delimited by blanks. */
/* If the input string does not contain a definition statement, */
/* STRANS searches the input string for potential symbol names. */
/* When a valid symbol is encountered, it is removed from the */
/* string and replaced by the corresponding definition. This */
/* continues until no untranslated symbols remain. */
/* $ Examples */
/* Suppose that we are given the following definitions: */
/* DEFINE BODIES PLANET AND SATS */
/* DEFINE EUROPA 502 */
/* DEFINE GANYMEDE 503 */
/* DEFINE IO 501 */
/* DEFINE JUPITER 599 */
/* DEFINE PLANET JUPITER */
/* DEFINE CALLISTO 504 */
/* DEFINE SATS IO EUROPA GANYMEDE CALLISTO */
/* Then the string 'BODIES AND SOULS' would translate, */
/* at various stages, to: */
/* 'PLANET AND SATS AND SOULS' */
/* 'JUPITER AND SATS AND SOULS' */
/* '599 AND SATS AND SOULS' */
/* '599 AND IO EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 EUROPA GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 GANYMEDE CALLISTO AND SOULS' */
/* '599 AND 501 502 503 CALLISTO AND SOULS' */
/* '599 AND 501 502 503 504 AND SOULS' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* I. M. Underwood (JPL) */
/* $ Version_and_Date */
/* Version 1.2.0 29-Aug-1996 (WLT) */
/* Fixed the error message for the case in which someone */
/* tries to create a symbol that is more than 32 characters */
/* in length. */
/* Version 1.1, 14-SEP-1995 */
/* Reference to unused variable WORD deleted. */
/* Version 1, 8-SEP-1986 */
/* -& */
/* SPICELIB Functions */
/* Other supporting functions */
/* The following parameters are used to define our table */
/* of symbol translations. */
/* Longest allowed symbol name is given by WDSIZE */
/* Maximum number of allowed symbols is MAXN */
/* The longest we expect any symbol to be is MAXL characters */
/* The average number of characters per symbol is AVGL */
/* Finally, here are the arrays used to hold the symbol translations. */
/* Here's the storage we need for the reserved words. */
switch(n__) {
case 1: goto L_sympat;
case 2: goto L_symget;
}
/* Set up all of the data structures and special strings in */
/* the first pass through the routine. */
if (return_()) {
return 0;
}
chkin_("STRAN", (ftnlen)5);
if (first) {
first = FALSE_;
vdim = 51;
psize = 804;
nname = 200;
sbinit_1__(&nname, &psize, &vdim, names, ptrs, buffer, (ftnlen)32, (
ftnlen)256);
s_copy(resvrd, "START", (ftnlen)32, (ftnlen)5);
s_copy(resvrd + 32, "STOP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 64, "EXIT", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 96, "INQUIRE", (ftnlen)32, (ftnlen)7);
s_copy(resvrd + 128, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 160, "DEFINE", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 192, "SHOW", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 224, "UNDEFINE", (ftnlen)32, (ftnlen)8);
s_copy(resvrd + 256, "HELP", (ftnlen)32, (ftnlen)4);
s_copy(resvrd + 288, "RECALL", (ftnlen)32, (ftnlen)6);
s_copy(resvrd + 320, "DO", (ftnlen)32, (ftnlen)2);
s_copy(resvrd + 352, "EDIT", (ftnlen)32, (ftnlen)4);
s_copy(alphab, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", (ftnlen)32, (ftnlen)26);
}
/* Find out what the special marker character is for suppressing */
/* symbol evaluation. */
geteq_(equote, (ftnlen)1);
/* Is this a definition statement? The presence of DEFINE, INQUIRE or */
/* UNDEFINE at the beginning of the string will confirm this. */
nthwd_(input, &c__1, key, &loc, input_len, (ftnlen)32);
ucase_(key, key, (ftnlen)32, (ftnlen)32);
/* The keyword must be followed by a valid symbol name. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0 || s_cmp(key, "UNDEFINE", (
ftnlen)32, (ftnlen)8) == 0) {
nthwd_(input, &c__2, symbl, &loc, input_len, (ftnlen)33);
ucase_(symbl, symbol, (ftnlen)33, (ftnlen)33);
l = rtrim_(symbol, (ftnlen)33);
if (s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The \"#\" command must be followed by the name of the s"
"ymbol that you want to #. ", (ftnlen)79);
errch_("#", key, (ftnlen)1, (ftnlen)32);
lcase_(key, key, (ftnlen)32, (ftnlen)32);
errch_("#", key, (ftnlen)1, (ftnlen)32);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (i_indx(alphab, symbol, (ftnlen)32, (ftnlen)1) == 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols must begin with a letter ("
"A-Z) ", (ftnlen)58);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (l > 32) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#...\". Symbols may not be longer than "
"32 characters in length.", (ftnlen)77);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (*(unsigned char *)&symbol[l - 1] == '?') {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
lcase_(key, key, (ftnlen)32, (ftnlen)32);
setmsg_("You cannot # \"#\". Symbols may not end with a questio"
"n mark '?'. ", (ftnlen)65);
errch_("#", key, (ftnlen)1, (ftnlen)32);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if ((s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(
key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) && isrchc_(
symbol, &c__12, resvrd, (ftnlen)33, (ftnlen)32) > 0) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
setmsg_("The word '#' is a reserved word. You may not redefine i"
"t. ", (ftnlen)58);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("BAD_SYMBOL_SPEC", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
}
if (s_cmp(key, "INQUIRE", (ftnlen)32, (ftnlen)7) == 0) {
/* First of all we, can only INQUIRE for symbol definitions */
/* if the program is not running in "batch" mode. */
if (batch_()) {
setmsg_("You've attempted to INQUIRE for the value of a symbol w"
"hile the program is running in \"batch\" mode. You can I"
"NQUIRE for a symbol value only if you are running in INT"
"ERACTIVE mode. ", (ftnlen)180);
sigerr_("WRONG_MODE", (ftnlen)10);
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* See if there is anything following the symbol that is */
/* to be defined. This will be used as our prompt value. */
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
if (s_cmp(input + (nxtchr - 1), " ", input_len - (nxtchr - 1), (
ftnlen)1) != 0) {
s_copy(myprmt, input + (nxtchr - 1), (ftnlen)80, input_len - (
nxtchr - 1));
} else {
s_copy(myprmt, "Enter definition for", (ftnlen)80, (ftnlen)20);
suffix_(symbol, &c__1, myprmt, (ftnlen)33, (ftnlen)80);
suffix_(">", &c__1, myprmt, (ftnlen)1, (ftnlen)80);
}
getdel_(delim, (ftnlen)1);
rdstmn_(myprmt, delim, def, (ftnlen)80, (ftnlen)1, (ftnlen)1024);
sbset_1__(symbol, def, names, ptrs, buffer, (ftnlen)33, (ftnlen)1024,
(ftnlen)32, (ftnlen)256);
}
/* If this is a definition, and the symbol already exists in the */
/* symbol table, simply replace the existing definition with the */
/* string following the symbol name. If this is a new symbol, */
/* find the first symbol in the list that should follow the new */
/* one. Move the rest of the symbols back, and insert the new one */
/* at this point. */
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0) {
/* Computing MAX */
i__3 = loc + l;
i__1 = loc + l, i__2 = ncpos_(input, " ", &i__3, input_len, (ftnlen)1)
;
nxtchr = max(i__1,i__2);
sbset_1__(symbol, input + (nxtchr - 1), names, ptrs, buffer, (ftnlen)
33, input_len - (nxtchr - 1), (ftnlen)32, (ftnlen)256);
}
if (s_cmp(key, "DEFINE", (ftnlen)32, (ftnlen)6) == 0 || s_cmp(key, "INQU"
"IRE", (ftnlen)32, (ftnlen)7) == 0) {
if (failed_()) {
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* Now check for a recursive definition. To do this we have */
/* two parallel arrays to the NAMES array of the string */
/* buffer. The first array CHECK is used to indicate that */
/* in the course of the definition resolution of the */
/* new symbol, another symbol shows up. The second array */
/* called CHECKD indicats whether or not we have examined this */
/* existing symbol to see if contains the newly created */
/* symbol as part of its definition. */
/* So far we have nothing to check and haven't checked anything. */
n = cardc_(names, (ftnlen)32);
i__1 = n;
for (j = 1; j <= i__1; ++j) {
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("check",
i__2, "stran_", (ftnlen)545)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge("checkd",
i__2, "stran_", (ftnlen)546)] = FALSE_;
}
/* Find the location of our new symbol in the NAMES cell. */
place = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)32);
new__ = TRUE_;
while(new__) {
/* Look up the definition currently associated with */
/* the symbol we are checking. */
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, (ftnlen)1024);
j = 1;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)1, (
ftnlen)33);
while(loc > 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
slot = isrchc_(symbol, &n, names + 192, (ftnlen)33, (ftnlen)
32);
/* If the word is located in the same place as the */
/* symbol we've just defined, we've introduced */
/* a recursive symbol definition. Remove this */
/* symbol and diagnose the error. */
if (slot == place) {
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
s_copy(symbol, names + (((i__1 = place + 5) < 206 && 0 <=
i__1 ? i__1 : s_rnge("names", i__1, "stran_", (
ftnlen)582)) << 5), (ftnlen)33, (ftnlen)32);
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (
ftnlen)32, (ftnlen)256);
setmsg_("The definition of '#' is recursive. Recursivel"
"y defined symbol definitions are not allowed. ", (
ftnlen)93);
errch_("#", symbol, (ftnlen)1, (ftnlen)33);
sigerr_("RECURSIVE_SYMBOL", (ftnlen)16);
chkout_("STRAN", (ftnlen)5);
return 0;
} else if (slot > 0) {
/* Otherwise if this word is in the names list */
/* we may need to check this symbol to see if */
/* it lists the just defined symbol in its definition. */
if (checkd[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("checkd", i__1, "stran_", (ftnlen)602)]) {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)603)]
= FALSE_;
} else {
check[(i__1 = slot - 1) < 200 && 0 <= i__1 ? i__1 :
s_rnge("check", i__1, "stran_", (ftnlen)605)]
= TRUE_;
}
}
/* Locate the next unquoted word in the definition. */
++j;
nthuqw_(def, &j, equote, symbol, &loc, (ftnlen)1024, (ftnlen)
1, (ftnlen)33);
}
/* See if there are any new items to check. If there */
/* are create a new value for symbol, and mark the */
/* new item as being checked. */
new__ = FALSE_;
i__1 = n;
for (j = 1; j <= i__1; ++j) {
if (check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)625)] && ! new__) {
s_copy(symbol, names + (((i__2 = j + 5) < 206 && 0 <=
i__2 ? i__2 : s_rnge("names", i__2, "stran_", (
ftnlen)626)) << 5), (ftnlen)33, (ftnlen)32);
check[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"check", i__2, "stran_", (ftnlen)627)] = FALSE_;
checkd[(i__2 = j - 1) < 200 && 0 <= i__2 ? i__2 : s_rnge(
"checkd", i__2, "stran_", (ftnlen)628)] = TRUE_;
new__ = TRUE_;
}
}
}
/* If we get to this point, we have a new non-recursively */
/* defined symbol. */
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* If this is a deletion, and the symbol already exists in the */
/* symbol table, simply move the symbols that follow toward the */
/* front of the table. */
if (s_cmp(key, "UNDEFINE", (ftnlen)32, (ftnlen)8) == 0) {
sbrem_1__(symbol, names, ptrs, buffer, (ftnlen)33, (ftnlen)32, (
ftnlen)256);
s_copy(output, " ", output_len, (ftnlen)1);
*tran = FALSE_;
chkout_("STRAN", (ftnlen)5);
return 0;
}
/* This is not a definition statement. Look for potential symbols. */
/* Try to resolve the first symbol in the string by substituting the */
/* corresponding definition for the existing symbol. */
s_copy(output, input, output_len, input_len);
*tran = FALSE_;
j = 1;
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (ftnlen)
33);
while(! (*tran) && s_cmp(symbol, " ", (ftnlen)33, (ftnlen)1) != 0) {
ucase_(symbol, symbol, (ftnlen)33, (ftnlen)33);
sbget_1__(symbol, names, ptrs, buffer, def, &i__, (ftnlen)33, (ftnlen)
32, (ftnlen)256, (ftnlen)1024);
if (i__ > 0) {
lsym = lastnb_(symbol, (ftnlen)33);
ldef = lastnb_(def, (ftnlen)1024) + 1;
lout = lastnb_(output, output_len);
leno = i_len(output, output_len);
if (lout - lsym + ldef > leno) {
*tran = FALSE_;
setmsg_("As a result of attempting to resolve the symbols in"
" the input command, the command has overflowed the a"
"llocated memory. This is may be due to unintentional"
"ly using symbols that you had not intended to use. "
"You may protect portions of your string from symbol "
"evaluation by enclosing that portion of your string "
"between the character # as in 'DO #THIS PART WITHOUT"
" SYMBOLS#' . ", (ftnlen)376);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
errch_("#", equote, (ftnlen)1, (ftnlen)1);
sigerr_("SYMBOL_OVERFLOW", (ftnlen)15);
chkout_("STRAN", (ftnlen)5);
return 0;
}
i__1 = loc + lsym - 1;
repsub_(output, &loc, &i__1, def, output, output_len, ldef,
output_len);
*tran = TRUE_;
} else {
++j;
}
nthuqw_(output, &j, equote, symbol, &loc, output_len, (ftnlen)1, (
ftnlen)33);
}
chkout_("STRAN", (ftnlen)5);
return 0;
/* The following entry point allows us to set up a search */
/* of defined symbols that match a wild-card pattern. It must */
/* be called prior to getting any symbol definitions. */
L_sympat:
lsttry = 0;
s_copy(pattrn, input, (ftnlen)80, input_len);
return 0;
/* The following entry point fetches the next symbol and its */
/* definition for the next SYMBOL whose name */
/* matches a previously supplied template via the entry point */
/* above --- SYMPAT. */
/* If there is no matching symbol, we get back blanks. Note */
/* that no translation of the definition is performed. */
L_symget:
s_copy(input, " ", input_len, (ftnlen)1);
s_copy(output, " ", output_len, (ftnlen)1);
n = cardc_(names, (ftnlen)32);
while(lsttry < n) {
++lsttry;
gotone = matchm_(names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)767)) << 5),
pattrn, "*", "%", "~", "|", (ftnlen)32, (ftnlen)80, (ftnlen)1,
(ftnlen)1, (ftnlen)1, (ftnlen)1);
if (gotone) {
s_copy(symbol, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)771)) << 5)
, (ftnlen)33, (ftnlen)32);
s_copy(input, names + (((i__1 = lsttry + 5) < 206 && 0 <= i__1 ?
i__1 : s_rnge("names", i__1, "stran_", (ftnlen)772)) << 5)
, input_len, (ftnlen)32);
sbget_1__(symbol, names, ptrs, buffer, output, &i__, (ftnlen)33, (
ftnlen)32, (ftnlen)256, output_len);
return 0;
}
}
return 0;
} /* stran_ */
/* $Procedure CPOSR ( Character position, reverse ) */
integer cposr_(char *str, char *chars, integer *start, ftnlen str_len, ftnlen
chars_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer i_len(char *, ftnlen), i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer b;
logical found;
integer lenstr;
/* $ Abstract */
/* Find the first occurrence in a string of a character belonging */
/* to a collection of characters, starting at a specified location, */
/* searching in reverse. */
/* $ 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 */
/* SCANNING */
/* $ Keywords */
/* CHARACTER */
/* SEARCH */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STR I Any character string. */
/* CHARS I A collection of characters. */
/* START I Position to begin looking for one of CHARS */
/* The function returns the index of the last character of STR */
/* at or before index START that is in the collection CHARS. */
/* $ Detailed_Input */
/* STR is any character string. */
/* CHARS is a character string containing a collection of */
/* characters. Spaces in CHARS are significant. */
/* START is the position in STR to begin looking for one of the */
/* characters in CHARS. */
/* $ Detailed_Output */
/* The function returns the index of the last character of STR (at */
/* or before index START) that is one of the characters in the */
/* string CHARS. If none of the characters is found, the function */
/* returns zero. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error Free. */
/* 1) If START is less than 1, CPOSR returns zero. */
/* 2) If START is greater than LEN(STRING), the search begins */
/* at the last character of the string. */
/* $ Files */
/* None. */
/* $ Particulars */
/* CPOSR is case sensitive. */
/* An entire family of related SPICELIB routines (POS, CPOS, NCPOS, */
/* POSR, CPOSR, NCPOSR) is desribed in the Required Reading. */
/* Those familiar with the True BASIC language should note that */
/* these functions are equivalent to the True BASIC intrinsic */
/* functions with the same name. */
/* $ Examples */
/* Let STRING = 'BOB, JOHN, TED, AND MARTIN ' */
/* 123456789012345678901234567890 */
/* Normal (sequential) searching: */
/* ------------------------------ */
/* CPOSR( STRING, ' ,', 30 ) = 30 */
/* CPOSR( STRING, ' ,', 29 ) = 29 */
/* CPOSR( STRING, ' ,', 28 ) = 28 */
/* CPOSR( STRING, ' ,', 27 ) = 27 */
/* CPOSR( STRING, ' ,', 26 ) = 20 */
/* CPOSR( STRING, ' ,', 19 ) = 16 */
/* CPOSR( STRING, ' ,', 15 ) = 15 */
/* CPOSR( STRING, ' ,', 14 ) = 11 */
/* CPOSR( STRING, ' ,', 10 ) = 10 */
/* CPOSR( STRING, ' ,', 9 ) = 5 */
/* CPOSR( STRING, ' ,', 4 ) = 4 */
/* CPOSR( STRING, ' ,', 3 ) = 0 */
/* START out of bounds: */
/* -------------------- */
/* CPOSR( STRING, ' ,', 231 ) = 30 */
/* CPOSR( STRING, ' ,', 31 ) = 30 */
/* CPOSR( STRING, ' ,', 0 ) = 0 */
/* CPOSR( STRING, ' ,', -10 ) = 0 */
/* Order within CHARS */
/* ------------------ */
/* CPOSR( STRING, 'JOHN', 23 ) = 18 */
/* CPOSR( STRING, 'OHNJ', 23 ) = 18 */
/* CPOSR( STRING, 'HNJO', 23 ) = 18 */
/* CPOSR( STRING, 'NJOH', 23 ) = 18 */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* H.A. Neilan (JPL) */
/* B.V. Semenov (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.3, 31-JAN-2008 (BVS) */
/* Removed non-standard end-of-declarations marker */
/* 'C%&END_DECLARATIONS' from comments. */
/* - SPICELIB Version 1.0.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.1, 26-MAR-1991 (HAN) */
/* The Required Reading file POSITION was renamed to SCANNING. */
/* This header was updated to reflect the change. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (WLT) */
/* -& */
/* $ Index_Entries */
/* backward search for the position of a character */
/* -& */
/* Local variables */
lenstr = i_len(str, str_len);
b = min(lenstr,*start);
found = FALSE_;
ret_val = 0;
while(! found) {
if (b <= 0) {
return ret_val;
} else if (i_indx(chars, str + (b - 1), chars_len, (ftnlen)1) != 0) {
ret_val = b;
return ret_val;
} else {
--b;
}
}
return ret_val;
} /* cposr_ */
/* $Procedure LPARSS ( Parse a list of items; return a set. ) */
/* Subroutine */ int lparss_(char *list, char *delims, char *set, ftnlen
list_len, ftnlen delims_len, ftnlen set_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
char bchr[1], echr[1];
integer nmax, b, e, n;
extern /* Subroutine */ int chkin_(char *, ftnlen);
logical valid;
extern integer sizec_(char *, ftnlen);
extern logical failed_(void);
extern /* Subroutine */ int scardc_(integer *, char *, ftnlen), validc_(
integer *, integer *, char *, ftnlen);
extern integer lastnb_(char *, ftnlen);
extern /* Subroutine */ int chkout_(char *, ftnlen), insrtc_(char *, char
*, ftnlen, ftnlen);
extern logical return_(void);
integer eol;
/* $ Abstract */
/* Parse a list of items delimited by multiple delimiters, */
/* placing the resulting items into a set. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* CELLS */
/* SETS */
/* $ Keywords */
/* CHARACTER */
/* PARSING */
/* SETS */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* LIST I List of items delimited by DELIMS on input. */
/* DELIMS I Single characters which delimit items. */
/* SET O Items in the list, validated, left justified. */
/* $ Detailed_Input */
/* LIST is a list of items delimited by any one of the */
/* characters in the string DELIMS. Consecutive */
/* delimiters, and delimiters at the beginning and */
/* end of the list, are considered to delimit blank */
/* items. A blank list is considered to contain */
/* a single (blank) item. */
/* DELIMS contains the individual characters which delimit */
/* the items in the list. These may be any ASCII */
/* characters, including blanks. */
/* However, by definition, consecutive blanks are NOT */
/* considered to be consecutive delimiters. Nor are */
/* a blank and any other delimiter considered to be */
/* consecutive delimiters. In addition, leading and */
/* trailing blanks are ignored. */
/* $ Detailed_Output */
/* SET is a set containing the items in the list, left */
/* justified. Any item in the list too long to fit */
/* into an element of SET is truncated on the right. */
/* The size of the set must be initialized prior */
/* to calling LPARSS. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If the size of the set is not large enough to accommodate all */
/* of the items in the set, the error is diagnosed by routines in */
/* the call tree of this routine. */
/* 2) If the string length of ITEMS is too short to accommodate */
/* an item, the item will be truncated on the right. */
/* 3) If the string length of ITEMS is too short to permit encoding */
/* of integers via ENCHAR, the error is diagnosed by routines in */
/* the call tree of this routine. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* The following examples illustrate the operation of LPARSS. */
/* 1) Let */
/* LIST = 'A number of words separated by */
/* spaces.' */
/* DELIMS = ' ,.' */
/* SIZE (SET) = 20 */
/* Then */
/* CARDC (SET) = 8 */
/* SET (1) = ' ' */
/* SET (2) = 'A' */
/* SET (3) = 'by' */
/* SET (4) = 'number' */
/* SET (5) = 'of' */
/* SET (6) = 'separated' */
/* SET (7) = 'spaces' */
/* SET (8) = 'words' */
/* 2) Let */
/* LIST = ' 1986-187// 13:15:12.184 ' */
/* DELIMS = ' ,/-:' */
/* SIZE (SET) = 20 */
/* Then */
/* CARDC (SET) = 6 */
/* SET (1) = ' ' */
/* SET (2) = '12.184' */
/* SET (3) = '13' */
/* SET (4) = '15' */
/* SET (5) = '187' */
/* SET (6) = '1986' */
/* 3) Let LIST = ' ,This, is, ,an,, example, ' */
/* DELIMS = ' ,' */
/* SIZE (SET) = 20 */
/* Then */
/* CARDC (SET) = 5 */
/* SET (1) = ' ' */
/* SET (2) = 'This' */
/* SET (3) = 'an' */
/* SET (4) = 'example' */
/* SET (5) = 'is' */
/* 4) Let LIST = 'Mary had a little lamb, little lamb */
/* whose fleece was white as snow.' */
/* DELIMS = ' ,.' */
/* SIZE (SET) = 6 */
/* An error would be signaled because the set is not */
/* large enough to accommodate all of the items in the */
/* list. */
/* 5) Let LIST = '1 2 3 4 5 6 7 8 9 10.' */
/* DELIMS = ' .' */
/* SIZE (SET) = 10 */
/* An error would be signaled because the set is not */
/* large enough to accommodate all of the items in the */
/* list. Note that delimiters at the end (or beginning) */
/* of list are considered to delimit blank items. */
/* 6) Let LIST = '1 2 3 4 5 6 7 8 9 10.' */
/* DELIMS = '.' */
/* SIZE (SET) = 10 */
/* Then */
/* CARDC (SET) = 2 */
/* SET (1) = ' ' */
/* SET (2) = '1 2 3 4 5 6 7 8 9 10' */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* N.J. Bachman (JPL) */
/* H.A. Neilan (JPL) */
/* I.M. Underwood (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 1.1.0, 26-OCT-2005 (NJB) */
/* Bug fix: code was modified to avoid out-of-range */
/* substring bound conditions. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (HAN) (IMU) */
/* -& */
/* $ Index_Entries */
/* parse a list of items and return a set */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 1.1.0, 26-OCT-2005 (NJB) */
/* Bug fix: code was modified to avoid out-of-range */
/* substring bound conditions. The previous version */
/* of this routine used DO WHILE statements of the form */
/* DO WHILE ( ( B .LE. EOL ) */
/* . .AND. ( LIST(B:B) .EQ. BLANK ) ) */
/* Such statements can cause index range violations when the */
/* index B is greater than the length of the string LIST. */
/* Whether or not such violations occur is platform-dependent. */
/* - Beta Version 2.0.0, 10-JAN-1989 (HAN) */
/* Error handling was added, and old error flags and their */
/* checks were removed. An error is signaled if the set */
/* is not large enough to accommodate all of the items in */
/* the list. */
/* The header documentation was updated to reflect the error */
/* handling changes, and more examples were added. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("LPARSS", (ftnlen)6);
}
/* Because speed is essential in many list parsing applications, */
/* LPARSS, like LPARSE, parses the input list in a single pass. */
/* What follows is nearly identical to LPARSE, except the FORTRAN */
/* INDEX function is used to test for delimiters, instead of testing */
/* each character for simple equality. Also, the items are inserted */
/* into a set instead of simply placed at the end of an array. */
/* No items yet. */
n = 0;
/* What is the size of the set? */
nmax = sizec_(set, set_len);
/* The array has not been validated yet. */
valid = FALSE_;
/* Blank list contains a blank item. No need to validate. */
if (s_cmp(list, " ", list_len, (ftnlen)1) == 0) {
scardc_(&c__0, set, set_len);
insrtc_(" ", set, (ftnlen)1, set_len);
valid = TRUE_;
} else {
/* Eliminate trailing blanks. EOL is the last non-blank */
/* character in the list. */
eol = lastnb_(list, list_len);
/* As the King said to Alice: 'Begin at the beginning. */
/* Continue until you reach the end. Then stop.' */
/* When searching for items, B is the beginning of the current */
/* item; E is the end. E points to the next non-blank delimiter, */
/* if any; otherwise E points to either the last character */
/* preceding the next item, or to the last character of the list. */
b = 1;
while(b <= eol) {
/* Skip any blanks before the next item or delimiter. */
/* At this point in the loop, we know */
/* B <= EOL */
*(unsigned char *)bchr = *(unsigned char *)&list[b - 1];
while(b <= eol && *(unsigned char *)bchr == 32) {
++b;
if (b <= eol) {
*(unsigned char *)bchr = *(unsigned char *)&list[b - 1];
}
}
/* At this point B is the index of the next non-blank */
/* character BCHR, or else */
/* B == EOL + 1 */
/* The item ends at the next delimiter. */
e = b;
if (e <= eol) {
*(unsigned char *)echr = *(unsigned char *)&list[e - 1];
} else {
*(unsigned char *)echr = ' ';
}
while(e <= eol && i_indx(delims, echr, delims_len, (ftnlen)1) ==
0) {
++e;
if (e <= eol) {
*(unsigned char *)echr = *(unsigned char *)&list[e - 1];
}
}
/* (This is different from LPARSE. If the delimiter was */
/* a blank, find the next non-blank character. If it's not */
/* a delimiter, back up. This prevents constructions */
/* like 'a , b', where the delimiters are blank and comma, */
/* from being interpreted as three items instead of two. */
/* By definition, consecutive blanks, or a blank and any */
/* other delimiter, do not count as consecutive delimiters.) */
if (e <= eol && *(unsigned char *)echr == 32) {
/* Find the next non-blank character. */
while(e <= eol && *(unsigned char *)echr == 32) {
++e;
if (e <= eol) {
*(unsigned char *)echr = *(unsigned char *)&list[e -
1];
}
}
if (e <= eol) {
if (i_indx(delims, echr, delims_len, (ftnlen)1) == 0) {
/* We're looking at a non-delimiter character. */
/* E is guaranteed to be > 1 if we're here, so the */
/* following subtraction is valid. */
--e;
}
}
}
/* The item now lies between B and E. Unless, of course, B and */
/* E are the same character; this can happen if the list */
/* starts or ends with a non-blank delimiter, or if we have */
/* stumbled upon consecutive delimiters. */
if (! valid) {
/* If the array has not been validated, it's just an */
/* array, and we can insert items directly into it. */
/* Unless it's full, in which case we validate now and */
/* insert later. */
if (n < nmax) {
++n;
if (e > b) {
s_copy(set + (n + 5) * set_len, list + (b - 1),
set_len, e - 1 - (b - 1));
} else {
s_copy(set + (n + 5) * set_len, " ", set_len, (ftnlen)
1);
}
} else {
validc_(&nmax, &nmax, set, set_len);
valid = TRUE_;
}
}
/* Once the set has been validated, the strings are inserted */
/* into the set if there's room. If there is not enough room */
/* in the set, let INSRTC signal the error. */
if (valid) {
if (e > b) {
insrtc_(list + (b - 1), set, e - 1 - (b - 1), set_len);
} else {
insrtc_(" ", set, (ftnlen)1, set_len);
}
if (failed_()) {
chkout_("LPARSS", (ftnlen)6);
return 0;
}
}
/* If there are more items to be found, continue with the */
/* character following E (which is a delimiter). */
b = e + 1;
}
/* If the array has not yet been validated, validate it before */
/* returning. */
if (! valid) {
validc_(&nmax, &n, set, set_len);
}
/* If the list ended with a (non-blank) delimiter, insert a */
/* blank item into the set. If there isn't any room, signal */
/* an error. */
if (i_indx(delims, list + (eol - 1), delims_len, (ftnlen)1) != 0) {
insrtc_(" ", set, (ftnlen)1, set_len);
/* If INSRTC failed to insert the blank because the set */
/* was already full, INSRTC will have signaled an error. */
/* No action is necessary here. */
}
}
chkout_("LPARSS", (ftnlen)6);
return 0;
} /* lparss_ */
/* $Procedure UPTO ( Up to the next index of a substring ) */
integer upto_(char *string, char *substr, integer *start, ftnlen string_len,
ftnlen substr_len)
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
integer i_len(char *, ftnlen), i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer b, i__, strlen;
/* $ Abstract */
/* Return up to (but not including) the index of the next occurrence */
/* of a substring within a string, after some initial offset. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CHARACTER, PARSING, SEARCH, STRING, TEXT */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STRING I Input string. */
/* SUBSTR I Target substring. */
/* START I Begin searching here. */
/* $ Detailed_Input */
/* STRING is an arbitrary input string. */
/* SUBSTR is the target substring to be located. */
/* START is the location at which to begin searching. That is, */
/* the search is confined to STRING(START: ). */
/* $ Detailed_Output */
/* The function returns one less than the next location of the */
/* target substring within the string, or the length of the string */
/* if the substring is not found. */
/* $ Exceptions */
/* 1) If START is greater than the length of the string, the */
/* function returns zero. */
/* 2) If START is less than one it is treated as if were one. */
/* $ Particulars */
/* UPTO is used primarily for extracting substrings bounded by */
/* a delimiter. Because the function returns the length of the */
/* string when the target substring is not found, the reference */
/* NEXT = STRING ( START : UPTO ( STRING, SUBSTR, START ) ) */
/* is always legal. */
/* $ Examples */
/* The following code fragment extracts (and prints) substrings */
/* bounded by slash (/) characters. */
/* BEGIN = 1 */
/* END = BEGIN */
/* DO WHILE ( END .NE. 0 ) */
/* END = UPTO ( STR, '/', BEGIN ) */
/* WRITE (6,*) 'Next token is ', STR(BEGIN:END) */
/* BEGIN = END + 2 */
/* END DO */
/* Notice that the loop ends when BEGIN is greater than the length */
/* of the string, causing the function to return zero. */
/* Notice also that the last token in the string is printed whether */
/* or not the string ends with a slash. */
/* If STRING is */
/* 'first/second/third/fourth' */
/* the output from the fragment is */
/* Next token is first */
/* Next token is second */
/* Next token is third */
/* Next token is fourth */
/* Contrast this with the following fragment, written using the */
/* intrinsic function INDEX. */
/* BEGIN = 1 */
/* END = BEGIN */
/* DO WHILE ( END .NE. 0 ) */
/* I = INDEX ( STR(BEGIN: ), '/' ) */
/* IF ( I .GT. 0 ) THEN */
/* END = BEGIN + I - 1 */
/* ELSE */
/* END = LEN ( STR ) */
/* END IF */
/* WRITE (6,*) 'Next token is ', STR(BEGIN:END) */
/* BEGIN = END + 2 */
/* IF ( BEGIN .GT. LEN ( STR ) ) THEN */
/* END = 0 */
/* END IF */
/* END DO */
/* $ Files */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 9, 1994 */
/* - META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of META/2 */
/* software as of May 3, 1994 */
/* Version B1.0.0, 4-APR-1988, (IMU) (WLT) */
/* -& */
/* Local variables */
/* Just like it says in the header. */
strlen = i_len(string, string_len);
b = max(1,*start);
if (b > strlen) {
ret_val = 0;
} else {
i__ = i_indx(string + (b - 1), substr, string_len - (b - 1),
substr_len);
if (i__ > 0) {
ret_val = b + i__ - 2;
} else {
ret_val = strlen;
}
}
return ret_val;
} /* upto_ */
/* Subroutine */ int mullik_(doublereal *c__, doublereal *h__, doublereal *f,
integer *norbs, doublereal *vecs, doublereal *store)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
char ch__1[80];
olist o__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer f_open(olist *), s_wsue(cilist *), do_uio(integer *, char *,
ftnlen), e_wsue(void);
/* Local variables */
static integer i__, j, k;
static doublereal bi, bj;
static integer if__, jf, ii, ij, jj, il, jl, im1;
extern /* Subroutine */ int rsp_(doublereal *, integer *, integer *,
doublereal *, doublereal *);
static doublereal sum, xyz[360] /* was [3][120] */, eigs[300];
extern /* Subroutine */ int mult_(doublereal *, doublereal *, doublereal *
, integer *);
static doublereal summ;
static integer ifact[300];
static logical graph;
extern /* Character */ VOID getnam_(char *, ftnlen, char *, ftnlen);
static integer linear;
extern /* Subroutine */ int densit_(doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, integer *),
vecprt_(doublereal *, integer *), gmetry_(doublereal *,
doublereal *);
/* Fortran I/O blocks */
static cilist io___19 = { 0, 13, 0, 0, 0 };
static cilist io___20 = { 0, 13, 0, 0, 0 };
static cilist io___21 = { 0, 13, 0, 0, 0 };
static cilist io___23 = { 0, 13, 0, 0, 0 };
static cilist io___24 = { 0, 13, 0, 0, 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 */
/* ********************************************************************* */
/* MULLIK DOES A MULLIKEN POPULATION ANALYSIS */
/* ON INPUT C = SQUARE ARRAY OF EIGENVECTORS. */
/* H = PACKED ARRAY OF ONE-ELECTRON MATRIX */
/* F = WORKSTORE OF SIZE AT LEAST NORBS*NORBS */
/* VECS = WORKSTORE OF SIZE AT LEAST NORBS*NORBS */
/* STORE = WORKSTORE OF SIZE AT LEAST (NORBS*(NORBS+1))/2 */
/* ********************************************************************* */
/* ********************************************************************* */
/* FIRST, RE-CALCULATE THE OVERLAP MATRIX */
/* ********************************************************************* */
/* Parameter adjustments */
--store;
--vecs;
--f;
--h__;
--c__;
/* Function Body */
graph = i_indx(keywrd_1.keywrd, "GRAPH", (ftnlen)241, (ftnlen)5) != 0;
i__1 = *norbs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
ifact[i__ - 1] = i__ * (i__ - 1) / 2;
}
ifact[*norbs] = *norbs * (*norbs + 1) / 2;
i__1 = molkst_1.numat;
for (i__ = 1; i__ <= i__1; ++i__) {
if__ = molkst_1.nfirst[i__ - 1];
il = molkst_1.nlast[i__ - 1];
im1 = i__ - 1;
bi = betas_1.betas[molkst_1.nat[i__ - 1] - 1];
i__2 = il;
for (k = if__; k <= i__2; ++k) {
ii = k * (k - 1) / 2;
i__3 = im1;
for (j = 1; j <= i__3; ++j) {
jf = molkst_1.nfirst[j - 1];
jl = molkst_1.nlast[j - 1];
bj = betas_1.betas[molkst_1.nat[j - 1] - 1];
i__4 = jl;
for (jj = jf; jj <= i__4; ++jj) {
ij = ii + jj;
h__[ij] = h__[ij] * 2. / (bi + bj) + 1e-14;
/* THE +1.D-14 IS TO PREVENT POSSIBLE ERRORS IN THE DIAGONALIZATION. */
store[ij] = h__[ij];
/* L20: */
bj = betas_1.betap[molkst_1.nat[j - 1] - 1];
}
/* L30: */
}
i__3 = k;
for (jj = if__; jj <= i__3; ++jj) {
ij = ii + jj;
store[ij] = 0.;
/* L40: */
h__[ij] = 0.;
}
/* L50: */
bi = betas_1.betap[molkst_1.nat[i__ - 1] - 1];
}
}
i__2 = *norbs;
for (i__ = 1; i__ <= i__2; ++i__) {
store[ifact[i__]] = 1.;
/* L60: */
h__[ifact[i__]] = 1.;
}
rsp_(&h__[1], norbs, norbs, eigs, &vecs[1]);
i__2 = *norbs;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L70: */
eigs[i__ - 1] = 1. / sqrt((d__1 = eigs[i__ - 1], abs(d__1)));
}
ij = 0;
i__2 = *norbs;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = i__;
for (j = 1; j <= i__1; ++j) {
++ij;
sum = 0.;
i__3 = *norbs;
for (k = 1; k <= i__3; ++k) {
/* L80: */
sum += vecs[i__ + (k - 1) * *norbs] * eigs[k - 1] * vecs[j + (
k - 1) * *norbs];
}
f[i__ + (j - 1) * *norbs] = sum;
/* L90: */
f[j + (i__ - 1) * *norbs] = sum;
}
}
if (graph) {
gmetry_(geom_1.geo, xyz);
/* WRITE TO DISK THE FOLLOWING DATA FOR GRAPHICS CALCULATION, IN ORDER: */
/* NUMBER OF ATOMS, ORBITAL, ELECTRONS */
/* ALL ATOMIC COORDINATES */
/* ORBITAL COUNTERS */
/* ORBITAL EXPONENTS, S, P, AND D, AND ATOMIC NUMBERS */
/* EIGENVECTORS (M.O.S NOT RE-NORMALIZED) */
/* INVERSE-SQUARE ROOT OF THE OVERLAP MATRIX. */
o__1.oerr = 1;
o__1.ounit = 13;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, "FOR013", (ftnlen)6);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "NEW";
o__1.oacc = 0;
o__1.ofm = "UNFORMATTED";
o__1.oblnk = 0;
i__1 = f_open(&o__1);
if (i__1 != 0) {
goto L31;
}
goto L32;
L31:
o__1.oerr = 0;
o__1.ounit = 13;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, "FOR013", (ftnlen)6);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = 0;
o__1.ofm = "UNFORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
L32:
s_wsue(&io___19);
do_uio(&c__1, (char *)&molkst_1.numat, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&(*norbs), (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&molkst_1.nelecs, (ftnlen)sizeof(integer));
for (i__ = 1; i__ <= 3; ++i__) {
i__1 = molkst_1.numat;
for (j = 1; j <= i__1; ++j) {
do_uio(&c__1, (char *)&xyz[i__ + j * 3 - 4], (ftnlen)sizeof(
doublereal));
}
}
e_wsue();
s_wsue(&io___20);
i__1 = molkst_1.numat;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&molkst_1.nlast[i__ - 1], (ftnlen)sizeof(
integer));
do_uio(&c__1, (char *)&molkst_1.nfirst[i__ - 1], (ftnlen)sizeof(
integer));
}
e_wsue();
s_wsue(&io___21);
i__1 = molkst_1.numat;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&expont_1.zs[molkst_1.nat[i__ - 1] - 1], (
ftnlen)sizeof(doublereal));
}
i__2 = molkst_1.numat;
for (i__ = 1; i__ <= i__2; ++i__) {
do_uio(&c__1, (char *)&expont_1.zp[molkst_1.nat[i__ - 1] - 1], (
ftnlen)sizeof(doublereal));
}
i__3 = molkst_1.numat;
for (i__ = 1; i__ <= i__3; ++i__) {
do_uio(&c__1, (char *)&expont_1.zd[molkst_1.nat[i__ - 1] - 1], (
ftnlen)sizeof(doublereal));
}
i__4 = molkst_1.numat;
for (i__ = 1; i__ <= i__4; ++i__) {
do_uio(&c__1, (char *)&molkst_1.nat[i__ - 1], (ftnlen)sizeof(
integer));
}
e_wsue();
linear = *norbs * *norbs;
s_wsue(&io___23);
i__1 = linear;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&c__[i__], (ftnlen)sizeof(doublereal));
}
e_wsue();
s_wsue(&io___24);
i__1 = linear;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&f[i__], (ftnlen)sizeof(doublereal));
}
e_wsue();
if (i_indx(keywrd_1.keywrd, "MULLIK", (ftnlen)241, (ftnlen)6) == 0) {
return 0;
}
}
/* OTHERWISE PERFORM MULLIKEN ANALYSIS */
mult_(&c__[1], &f[1], &vecs[1], norbs);
i__ = -1;
densit_(&vecs[1], norbs, norbs, &molkst_1.nclose, &molkst_1.nopen, &
molkst_1.fract, &c__[1], &c__2);
linear = *norbs * (*norbs + 1) / 2;
i__1 = linear;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
c__[i__] *= store[i__];
}
summ = 0.;
i__1 = *norbs;
for (i__ = 1; i__ <= i__1; ++i__) {
sum = 0.;
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
/* L110: */
sum += c__[ifact[i__ - 1] + j];
}
i__2 = *norbs;
for (j = i__ + 1; j <= i__2; ++j) {
/* L120: */
sum += c__[ifact[j - 1] + i__];
}
summ += sum;
/* L130: */
c__[ifact[i__]] = sum;
}
vecprt_(&c__[1], norbs);
return 0;
} /* mullik_ */
/* Subroutine */ int gettxt_()
{
/* System generated locals */
integer i__1;
char ch__1[80];
olist o__1;
alist al__1;
/* Builtin functions */
/* Subroutine */ int s_copy();
integer s_rsfe(), do_fio(), e_rsfe(), i_indx(), f_open(), f_rew(), s_wsfe(
), e_wsfe(), s_cmp();
/* Subroutine */ int s_stop();
/* Local variables */
static integer i__, j;
static char filen[50], ch[1];
static integer is[3];
extern /* Character */ VOID getnam_();
extern /* Subroutine */ int upcase_();
static char oldkey[80], ch2[1];
/* Fortran I/O blocks */
static cilist io___2 = { 1, 5, 1, "(A)", 0 };
static cilist io___7 = { 1, 4, 1, "(A)", 0 };
static cilist io___8 = { 1, 4, 1, "(A)", 0 };
static cilist io___9 = { 1, 5, 1, "(A)", 0 };
static cilist io___10 = { 1, 5, 1, "(A)", 0 };
static cilist io___11 = { 1, 4, 1, "(A)", 0 };
static cilist io___12 = { 1, 5, 1, "(A)", 0 };
static cilist io___13 = { 1, 5, 1, "(A)", 0 };
static cilist io___14 = { 1, 5, 1, "(A)", 0 };
static cilist io___15 = { 1, 4, 1, "(A)", 0 };
static cilist io___16 = { 1, 5, 1, "(A)", 0 };
static cilist io___17 = { 1, 5, 1, "(A)", 0 };
static cilist io___18 = { 1, 5, 1, "(A)", 0 };
static cilist io___19 = { 1, 5, 1, "(A)", 0 };
static cilist io___20 = { 0, 6, 0, "(A)", 0 };
static cilist io___23 = { 0, 6, 0, "(A,I2,A)", 0 };
static cilist io___24 = { 0, 6, 0, "(A)", 0 };
static cilist io___25 = { 0, 6, 0, "(A)", 0 };
is[0] = 161;
is[1] = 81;
is[2] = 1;
s_copy(keywrd_1.keywrd, " ", (ftnlen)241, (ftnlen)1);
s_copy(titles_1.koment, " NULL ", (ftnlen)81, (ftnlen)10);
s_copy(titles_1.title, " NULL ", (ftnlen)81, (ftnlen)10);
i__1 = s_rsfe(&io___2);
if (i__1 != 0) {
goto L100001;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd, (ftnlen)80);
if (i__1 != 0) {
goto L100001;
}
i__1 = e_rsfe();
L100001:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
s_copy(oldkey, keywrd_1.keywrd, (ftnlen)80, (ftnlen)241);
upcase_(keywrd_1.keywrd, (ftnlen)80);
if (i_indx(keywrd_1.keywrd, "SETUP", (ftnlen)241, (ftnlen)5) != 0) {
i__ = i_indx(keywrd_1.keywrd, "SETUP=", (ftnlen)241, (ftnlen)6);
if (i__ != 0) {
j = i_indx(keywrd_1.keywrd + (i__ - 1), " ", 241 - (i__ - 1), (
ftnlen)1);
i__1 = i__ + 5;
s_copy(filen, oldkey + i__1, (ftnlen)50, i__ + j - 1 - i__1);
} else {
s_copy(filen, "SETUP", (ftnlen)50, (ftnlen)5);
}
o__1.oerr = 0;
o__1.ounit = 4;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, filen, (ftnlen)50);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 4;
f_rew(&al__1);
i__1 = s_rsfe(&io___7);
if (i__1 != 0) {
goto L40;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 80, (ftnlen)80);
if (i__1 != 0) {
goto L40;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L40;
}
upcase_(keywrd_1.keywrd + 80, (ftnlen)80);
i__1 = s_rsfe(&io___8);
if (i__1 != 0) {
goto L10;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L10;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L10;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
L10:
i__1 = s_rsfe(&io___9);
if (i__1 != 0) {
goto L100002;
}
i__1 = do_fio(&c__1, titles_1.koment, (ftnlen)81);
if (i__1 != 0) {
goto L100002;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100002;
}
i__1 = e_rsfe();
L100002:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
} else if (i_indx(keywrd_1.keywrd, " +", (ftnlen)80, (ftnlen)2) != 0) {
/* READ SECOND KEYWORD LINE */
i__1 = s_rsfe(&io___10);
if (i__1 != 0) {
goto L100003;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 80, (ftnlen)80);
if (i__1 != 0) {
goto L100003;
}
i__1 = e_rsfe();
L100003:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
s_copy(oldkey, keywrd_1.keywrd + 80, (ftnlen)80, (ftnlen)80);
upcase_(keywrd_1.keywrd + 80, (ftnlen)80);
if (i_indx(keywrd_1.keywrd + 80, "SETUP", (ftnlen)80, (ftnlen)5) != 0)
{
i__ = i_indx(keywrd_1.keywrd, "SETUP=", (ftnlen)241, (ftnlen)6);
if (i__ != 0) {
j = i_indx(keywrd_1.keywrd + (i__ - 1), " ", 241 - (i__ - 1),
(ftnlen)1);
i__1 = i__ - 75;
s_copy(filen, oldkey + i__1, (ftnlen)50, i__ + j - 80 - i__1);
} else {
s_copy(filen, "SETUP", (ftnlen)50, (ftnlen)5);
}
o__1.oerr = 0;
o__1.ounit = 4;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, filen, (ftnlen)50);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 4;
f_rew(&al__1);
i__1 = s_rsfe(&io___11);
if (i__1 != 0) {
goto L20;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L20;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L20;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
L20:
;
} else if (i_indx(keywrd_1.keywrd + 80, " +", (ftnlen)80, (ftnlen)2)
!= 0) {
/* READ THIRD KEYWORD LINE */
i__1 = s_rsfe(&io___12);
if (i__1 != 0) {
goto L100004;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L100004;
}
i__1 = e_rsfe();
L100004:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
}
/* READ TITLE LINE */
i__1 = s_rsfe(&io___13);
if (i__1 != 0) {
goto L100005;
}
i__1 = do_fio(&c__1, titles_1.koment, (ftnlen)81);
if (i__1 != 0) {
goto L100005;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100005;
}
i__1 = e_rsfe();
L100005:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
} else if (i_indx(keywrd_1.keywrd, "&", (ftnlen)80, (ftnlen)1) != 0) {
i__1 = s_rsfe(&io___14);
if (i__1 != 0) {
goto L100006;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 80, (ftnlen)80);
if (i__1 != 0) {
goto L100006;
}
i__1 = e_rsfe();
L100006:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
s_copy(oldkey, keywrd_1.keywrd + 80, (ftnlen)80, (ftnlen)80);
upcase_(keywrd_1.keywrd + 80, (ftnlen)80);
if (i_indx(keywrd_1.keywrd + 80, "SETUP", (ftnlen)80, (ftnlen)5) != 0)
{
i__ = i_indx(keywrd_1.keywrd, "SETUP=", (ftnlen)241, (ftnlen)6);
if (i__ != 0) {
j = i_indx(keywrd_1.keywrd + (i__ - 1), " ", 241 - (i__ - 1),
(ftnlen)1);
i__1 = i__ - 75;
s_copy(filen, oldkey + i__1, (ftnlen)50, i__ + j - 80 - i__1);
/* write(*,*)' <'//FILEN//'>' */
/* stop */
} else {
s_copy(filen, "SETUP", (ftnlen)50, (ftnlen)5);
}
o__1.oerr = 0;
o__1.ounit = 4;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, filen, (ftnlen)50);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 4;
f_rew(&al__1);
i__1 = s_rsfe(&io___15);
if (i__1 != 0) {
goto L30;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L30;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L30;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
i__1 = s_rsfe(&io___16);
if (i__1 != 0) {
goto L100007;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100007;
}
i__1 = e_rsfe();
L100007:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
L30:
;
} else if (i_indx(keywrd_1.keywrd + 80, "&", (ftnlen)80, (ftnlen)1) !=
0) {
i__1 = s_rsfe(&io___17);
if (i__1 != 0) {
goto L100008;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L100008;
}
i__1 = e_rsfe();
L100008:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
} else {
i__1 = s_rsfe(&io___18);
if (i__1 != 0) {
goto L100009;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100009;
}
i__1 = e_rsfe();
L100009:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
}
} else {
i__1 = s_rsfe(&io___19);
if (i__1 != 0) {
goto L100010;
}
i__1 = do_fio(&c__1, titles_1.koment, (ftnlen)81);
if (i__1 != 0) {
goto L100010;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100010;
}
i__1 = e_rsfe();
L100010:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
}
goto L50;
L40:
s_wsfe(&io___20);
do_fio(&c__1, " SETUP FILE MISSING OR CORRUPT", (ftnlen)30);
e_wsfe();
L50:
for (j = 1; j <= 3; ++j) {
i__1 = is[j - 1] - 1;
if (s_cmp(keywrd_1.keywrd + i__1, " ", is[j - 1] - i__1, (ftnlen)1) !=
0) {
i__1 = is[j - 1] - 1;
s_copy(ch, keywrd_1.keywrd + i__1, (ftnlen)1, is[j - 1] - i__1);
i__1 = is[j - 1] - 1;
s_copy(keywrd_1.keywrd + i__1, " ", is[j - 1] - i__1, (ftnlen)1);
for (i__ = is[j - 1] + 1; i__ <= 239; ++i__) {
*(unsigned char *)ch2 = *(unsigned char *)&keywrd_1.keywrd[
i__ - 1];
*(unsigned char *)&keywrd_1.keywrd[i__ - 1] = *(unsigned char
*)ch;
*(unsigned char *)ch = *(unsigned char *)ch2;
i__1 = i__;
if (s_cmp(keywrd_1.keywrd + i__1, " ", i__ + 2 - i__1, (
ftnlen)2) == 0) {
i__1 = i__;
s_copy(keywrd_1.keywrd + i__1, ch, i__ + 1 - i__1, (
ftnlen)1);
goto L70;
}
/* L60: */
}
s_wsfe(&io___23);
do_fio(&c__1, " LINE", (ftnlen)5);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, " OF KEYWORDS DOES NOT HAVE ENOUGH", (ftnlen)33);
e_wsfe();
s_wsfe(&io___24);
do_fio(&c__1, " SPACES FOR PARSING. PLEASE CORRECT LINE.", (
ftnlen)42);
e_wsfe();
s_stop("", (ftnlen)0);
L70:
;
}
/* L80: */
}
return 0;
L90:
s_wsfe(&io___25);
do_fio(&c__1, " ERROR IN READ OF FIRST THREE LINES", (ftnlen)35);
e_wsfe();
L100:
s_stop("", (ftnlen)0);
} /* gettxt_ */
/* 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 NTHWD ( Nth word in a character string ) */
/* Subroutine */ int nthwd_(char *string, integer *nth, char *word, integer *
loc, ftnlen string_len, ftnlen word_len)
{
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
logical loop;
integer i__, n, length;
/* $ Abstract */
/* Return the Nth word in a character string, and its location */
/* in the string. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CHARACTER, PARSING, SEARCH, WORD */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* STRING I Input character string. */
/* NTH I Index of the word to be returned. */
/* WORD O The N'TH word in STRING. */
/* LOC O Location of WORD in STRING. */
/* $ Detailed_Input */
/* STRING is the input string to be parsed. It contains */
/* some number of words, where a word is any string */
/* of consecutive non-blank characters. */
/* NTH is the index of the word to be returned. (One for */
/* the first word, two for the second, and so on.) */
/* $ Detailed_Output */
/* WORD is the N'th word in STRING. If STRING is blank, */
/* or NTH is nonpositive or too large, WORD is blank. */
/* WORD may overwrite STRING. */
/* LOC is the location of WORD in STRING. (That is, WORD */
/* begins at STRING(LOC:LOC). If STRING is blank, or */
/* NTH is nonpositive or too large, LOC is zero. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* NTHWD, like NEXTWD, is useful primarily for parsing input */
/* commands consisting of one or more words, where a word is */
/* defined to be any sequence of consecutive non-blank characters. */
/* Successive calls to NEXTWD allow the calling routine to neatly */
/* parse and process one word at a time. */
/* The chief difference between the two routines is that */
/* NTHWD allows the calling routine to access the words making */
/* up the input string in random order. (NEXTWD allows only */
/* sequential access.) */
/* $ Examples */
/* Let STRING be ' Now is the time, for all good men to come.' */
/* If N = -1 WORD = ' ' LOC = 0 */
/* 0 ' ' 0 */
/* 1, 'Now' 2 */
/* 2, 'is' 6 */
/* 3, 'the' 9 */
/* 4, 'time,' 13 */
/* 5, 'for' 21 */
/* 6, 'all' 25 */
/* 7, 'good' 29 */
/* 8, 'men' 34 */
/* 9, 'to' 42 */
/* 10, 'come.' 45 */
/* 11, ' ' 0 */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 10-MAY-2006 (EDW) */
/* Added logic to prevent the evaluation of STRING(I:I) */
/* if I exceeds the length of STRING. Functionally, the */
/* evaluation had no effect on NTHWD's output, but the ifort */
/* F95 compiler flagged the evaluation as an array */
/* overrun error. This occurred because given: */
/* A .AND. B */
/* ifort evaluates A then B then performs the logical */
/* comparison. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* nth word in a character_string */
/* -& */
/* Local variables */
/* Trivial cases first. Blank STRING? Nonpositive NTH? */
if (s_cmp(string, " ", string_len, (ftnlen)1) == 0 || *nth < 1) {
s_copy(word, " ", word_len, (ftnlen)1);
*loc = 0;
return 0;
}
/* Skip leading blanks. */
*loc = 1;
while(*(unsigned char *)&string[*loc - 1] == ' ') {
++(*loc);
}
/* If we wanted the first word, we have the location. Otherwise, */
/* keep stepping through STRING. Quit when the N'TH word is found, */
/* or when the end of the string is reached. (The current word is */
/* ended whenever a blank is encountered.) */
/* N is the number of words found so far. */
/* I is the current location in STRING. */
n = 1;
i__ = *loc;
length = i_len(string, string_len);
while(i__ < length && n < *nth) {
++i__;
/* Blank signals end of the current word. */
if (*(unsigned char *)&string[i__ - 1] == ' ') {
/* Skip ahead to the next one. The logic ensures no */
/* evaluation of STRING(I:I) if I > LEN(STRING). */
loop = i__ <= length;
if (loop) {
loop = loop && *(unsigned char *)&string[i__ - 1] == ' ';
}
while(loop) {
++i__;
if (i__ > length) {
loop = FALSE_;
} else if (*(unsigned char *)&string[i__ - 1] != ' ') {
loop = FALSE_;
} else {
loop = TRUE_;
}
}
/* If not at the end of the string, we have another word. */
if (i__ <= length) {
++n;
*loc = i__;
}
}
}
/* Couldn't find enough words? Return blank and zero. */
if (n < *nth) {
s_copy(word, " ", word_len, (ftnlen)1);
*loc = 0;
/* Otherwise, find the rest of WORD (it continues until the next */
/* blank), and return the current LOC. */
} else {
i__ = i_indx(string + (*loc - 1), " ", string_len - (*loc - 1), (
ftnlen)1);
if (i__ == 0) {
s_copy(word, string + (*loc - 1), word_len, string_len - (*loc -
1));
} else {
s_copy(word, string + (*loc - 1), word_len, *loc + i__ - 1 - (*
loc - 1));
}
}
return 0;
} /* nthwd_ */
/* $Procedure BEUNS ( Be an unsigned integer? ) */
logical beuns_(char *string, ftnlen string_len)
{
/* System generated locals */
logical ret_val;
/* Builtin functions */
integer i_len(char *, ftnlen), i_indx(char *, char *, ftnlen, ftnlen),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__, l;
logical ok;
extern integer frstnb_(char *, ftnlen);
/* $ Abstract */
/* Determine whether a string represents an unsigned integer. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* WORDS */
/* $ Keywords */
/* ALPHANUMERIC */
/* NUMBERS */
/* SCANNING */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* STRING I Character string. */
/* The function returns TRUE if the string represents an unsigned */
/* integer. Otherwise, it returns FALSE. */
/* $ Detailed_Input */
/* STRING is any string. */
/* $ Detailed_Output */
/* If STRING contains a single word made entirely from the */
/* characters '0' through '9', then the function returns TRUE. */
/* Otherwise, it returns FALSE. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* Error free. */
/* $ Files */
/* None. */
/* $ Particulars */
/* By definition an unsigned integer is a word made exclusively */
/* from the characters '0', '1', '2', '3', '4', '5', '6', '7', '8', */
/* and '9'. */
/* $ Examples */
/* Four classes of numbers recognized by the various BE functions. */
/* UNS unsigned integer */
/* INT integer (includes INT) */
/* DEC decimal number (includes UNS, INT) */
/* NUM number (includes UNS, INT, NUM) */
/* The following table illustrates the differences between */
/* the classes. (Any number of leading and trailing blanks */
/* are acceptable.) */
/* String Accepted by */
/* ------------------ ------------------ */
/* 0 UNS, INT, DEC, NUM */
/* 21 */
/* 21994217453648 */
/* +0 INT, DEC, NUM */
/* -13 */
/* +21946 */
/* 1.23 DEC, NUM */
/* 12. */
/* .17 */
/* +4.1 */
/* -.25 */
/* 2.3e17 NUM */
/* 17.D-13275849 */
/* -.194265E+0004 */
/* Note that the functions don't take the magnitudes of the numbers */
/* into account. They may accept numbers that cannot be represented */
/* in Fortran variables. (For example, '2.19E999999999999' probably */
/* exceeds the maximum floating point number on any machine, but */
/* is perfectly acceptable to BENUM.) */
/* The following strings are not accepted by any of the functions. */
/* String Reason */
/* --------------- ---------------------------------------- */
/* 3/4 No implied operations (rational numbers) */
/* 37+14 No explicit operations */
/* E12 Must have mantissa */
/* 217,346.91 No commas */
/* 3.14 159 264 No embedded spaces */
/* PI No special numbers */
/* FIVE No textual numbers */
/* CXIV No roman numerals */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.0, 01-DEC-1995 (WLT) */
/* -& */
/* $ Index_Entries */
/* determine if a string is an unsigned integer */
/* -& */
/* SPICE functions */
/* Local variables */
/* Get the length of the string and the position of its */
/* first non-blank character. */
l = i_len(string, string_len);
i__ = frstnb_(string, string_len);
/* If there isn't a non-blank character, this isn't an */
/* unsigned integer. */
if (i__ == 0) {
ret_val = FALSE_;
return ret_val;
}
/* As far as we know right now, everything is ok. Examine */
/* characters until we run out of string or until we */
/* hit a non-digit character. */
ok = TRUE_;
while(ok && i__ <= l) {
if (i_indx("0123456789", string + (i__ - 1), (ftnlen)10, (ftnlen)1) >
0) {
++i__;
} else {
ok = FALSE_;
}
}
/* If the string still is ok as an unsigned integer, it must be */
/* one... */
if (ok) {
ret_val = TRUE_;
} else {
/* ... otherwise, it's an unsigned integer if the remainder is blank. */
ret_val = s_cmp(string + (i__ - 1), " ", string_len - (i__ - 1), (
ftnlen)1) == 0;
}
return ret_val;
} /* beuns_ */
/* Subroutine */ int hcore_(doublereal *coord, doublereal *h__, doublereal *w,
doublereal *wj, doublereal *wk, doublereal *enuclr)
{
/* Initialized data */
static integer icalcn = 0;
/* Format strings */
static char fmt_120[] = "(10f8.4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, j, i1, i2, j1, j2, ia, ib, ic;
static doublereal di[81] /* was [9][9] */;
static integer ja, jb, jc, ii, jj, ni, nj, kr;
static doublereal xf, yf, zf, e1b[10], e2a[10];
static integer im1, io1, jo1;
static doublereal wjd[100], wkd[100];
static integer kro;
static doublereal half;
static integer ione;
static doublereal fnuc, enuc;
extern doublereal reada_(char *, integer *, ftnlen);
static logical debug, fldon, first;
extern /* Subroutine */ int h1elec_(integer *, integer *, doublereal *,
doublereal *, doublereal *), addhcr_(doublereal *), addnuc_(
doublereal *);
static doublereal fldcon, hterme, cutoff;
extern /* Subroutine */ int rotate_(integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *), vecprt_(doublereal *, integer *);
static char tmpkey[241];
extern /* Subroutine */ int solrot_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *);
/* Fortran I/O blocks */
static cilist io___11 = { 0, 6, 0, "(/10X,'THE ELECTRIC FIELD IS',3F10.5)"
, 0 };
static cilist io___12 = { 0, 6, 0, "(10X,'IN 8*A.U. (8*27.21/0.529 VOLTS"
"/ANGSTROM)',/)", 0 };
static cilist io___44 = { 0, 6, 0, "(//10X,'ONE-ELECTRON MATRIX FROM HCO"
"RE')", 0 };
static cilist io___45 = { 0, 6, 0, "(//10X,'TWO-ELECTRON MATRIX IN HCORE"
"'/)", 0 };
static cilist io___46 = { 0, 6, 0, fmt_120, 0 };
static cilist io___47 = { 0, 6, 0, "(//10X,'TWO-ELECTRON J MATRIX IN HCO"
"RE'/)", 0 };
static cilist io___48 = { 0, 6, 0, fmt_120, 0 };
static cilist io___49 = { 0, 6, 0, "(//10X,'TWO-ELECTRON K MATRIX IN HCO"
"RE'/)", 0 };
static cilist io___50 = { 0, 6, 0, fmt_120, 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 */
/* COSMO change */
/* end of COSMO change */
/* *********************************************************************** */
/* HCORE GENERATES THE ONE-ELECTRON MATRIX AND TWO ELECTRON INTEGRALS */
/* FOR A GIVEN MOLECULE WHOSE GEOMETRY IS DEFINED IN CARTESIAN */
/* COORDINATES. */
/* ON INPUT COORD = COORDINATES OF THE MOLECULE. */
/* ON OUTPUT H = ONE-ELECTRON MATRIX. */
/* W = TWO-ELECTRON INTEGRALS. */
/* ENUCLR = NUCLEAR ENERGY */
/* *********************************************************************** */
/* Parameter adjustments */
--wk;
--wj;
--w;
--h__;
coord -= 4;
/* Function Body */
first = icalcn != numcal_1.numcal;
icalcn = numcal_1.numcal;
if (first) {
ione = 1;
cutoff = 1e10;
if (euler_1.id != 0) {
cutoff = 60.;
}
if (euler_1.id != 0) {
ione = 0;
}
debug = i_indx(keywrd_1.keywrd, "HCORE", (ftnlen)241, (ftnlen)5) != 0;
/* ****************************************************************** */
xf = 0.;
yf = 0.;
zf = 0.;
s_copy(tmpkey, keywrd_1.keywrd, (ftnlen)241, (ftnlen)241);
i__ = i_indx(tmpkey, " FIELD(", (ftnlen)241, (ftnlen)7);
if (i__ == 0) {
goto L6;
}
/* ERASE ALL TEXT FROM TMPKEY EXCEPT FIELD DATA */
s_copy(tmpkey, " ", i__, (ftnlen)1);
i__1 = i_indx(tmpkey, ")", (ftnlen)241, (ftnlen)1) - 1;
s_copy(tmpkey + i__1, " ", 241 - i__1, (ftnlen)1);
/* READ IN THE EFFECTIVE FIELD IN X,Y,Z COORDINATES */
xf = reada_(tmpkey, &i__, (ftnlen)241);
i__ = i_indx(tmpkey, ",", (ftnlen)241, (ftnlen)1);
if (i__ == 0) {
goto L5;
}
*(unsigned char *)&tmpkey[i__ - 1] = ' ';
yf = reada_(tmpkey, &i__, (ftnlen)241);
i__ = i_indx(tmpkey, ",", (ftnlen)241, (ftnlen)1);
if (i__ == 0) {
goto L5;
}
*(unsigned char *)&tmpkey[i__ - 1] = ' ';
zf = reada_(tmpkey, &i__, (ftnlen)241);
L5:
s_wsfe(&io___11);
do_fio(&c__1, (char *)&xf, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yf, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zf, (ftnlen)sizeof(doublereal));
e_wsfe();
s_wsfe(&io___12);
e_wsfe();
L6:
field_1.efield[0] = xf;
field_1.efield[1] = yf;
field_1.efield[2] = zf;
/* ********************************************************************** */
}
fldon = FALSE_;
if (field_1.efield[0] != 0. || field_1.efield[1] != 0. || field_1.efield[
2] != 0.) {
fldcon = 51.4257;
fldon = TRUE_;
}
i__1 = molkst_1.norbs * (molkst_1.norbs + 1) / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
h__[i__] = 0.;
}
*enuclr = 0.;
kr = 1;
i__1 = molkst_1.numat;
for (i__ = 1; i__ <= i__1; ++i__) {
ia = molkst_1.nfirst[i__ - 1];
ib = molkst_1.nlast[i__ - 1];
ic = molkst_1.nmidle[i__ - 1];
ni = molkst_1.nat[i__ - 1];
/* FIRST WE FILL THE DIAGONALS, AND OFF-DIAGONALS ON THE SAME ATOM */
i__2 = ib;
for (i1 = ia; i1 <= i__2; ++i1) {
i2 = i1 * (i1 - 1) / 2 + ia - 1;
i__3 = i1;
for (j1 = ia; j1 <= i__3; ++j1) {
++i2;
h__[i2] = 0.;
if (fldon) {
io1 = i1 - ia;
jo1 = j1 - ia;
if (jo1 == 0 && io1 == 1) {
hterme = multip_1.dd[ni - 1] * -.529177 *
field_1.efield[0] * fldcon;
h__[i2] = hterme;
}
if (jo1 == 0 && io1 == 2) {
hterme = multip_1.dd[ni - 1] * -.529177 *
field_1.efield[1] * fldcon;
h__[i2] = hterme;
}
if (jo1 == 0 && io1 == 3) {
hterme = multip_1.dd[ni - 1] * -.529177 *
field_1.efield[2] * fldcon;
h__[i2] = hterme;
}
}
/* L20: */
}
h__[i2] = molorb_1.uspd[i1 - 1];
if (fldon) {
fnuc = -(field_1.efield[0] * coord[i__ * 3 + 1] +
field_1.efield[1] * coord[i__ * 3 + 2] +
field_1.efield[2] * coord[i__ * 3 + 3]) * fldcon;
h__[i2] += fnuc;
}
/* L30: */
}
/* FILL THE ATOM-OTHER ATOM ONE-ELECTRON MATRIX<PSI(LAMBDA)|PSI(SIGMA)> */
im1 = i__ - ione;
i__2 = im1;
for (j = 1; j <= i__2; ++j) {
half = 1.;
if (i__ == j) {
half = .5;
}
ja = molkst_1.nfirst[j - 1];
jb = molkst_1.nlast[j - 1];
jc = molkst_1.nmidle[j - 1];
nj = molkst_1.nat[j - 1];
h1elec_(&ni, &nj, &coord[i__ * 3 + 1], &coord[j * 3 + 1], di);
i2 = 0;
i__3 = ib;
for (i1 = ia; i1 <= i__3; ++i1) {
ii = i1 * (i1 - 1) / 2 + ja - 1;
++i2;
j2 = 0;
jj = min(i1,jb);
i__4 = jj;
for (j1 = ja; j1 <= i__4; ++j1) {
++ii;
++j2;
/* L40: */
h__[ii] += di[i2 + j2 * 9 - 10];
}
}
/* CALCULATE THE TWO-ELECTRON INTEGRALS, W; THE ELECTRON NUCLEAR TERMS */
/* E1B AND E2A; AND THE NUCLEAR-NUCLEAR TERM ENUC. */
if (euler_1.id == 0) {
rotate_(&ni, &nj, &coord[i__ * 3 + 1], &coord[j * 3 + 1], &w[
kr], &kr, e1b, e2a, &enuc, &cutoff);
} else {
kro = kr;
solrot_(&ni, &nj, &coord[i__ * 3 + 1], &coord[j * 3 + 1], wjd,
wkd, &kr, e1b, e2a, &enuc, &cutoff);
jj = 0;
i__4 = kr - 1;
for (ii = kro; ii <= i__4; ++ii) {
++jj;
wj[ii] = wjd[jj - 1];
/* L50: */
wk[ii] = wkd[jj - 1];
}
}
*enuclr += enuc;
/* ADD ON THE ELECTRON-NUCLEAR ATTRACTION TERM FOR ATOM I. */
i2 = 0;
i__4 = ic;
for (i1 = ia; i1 <= i__4; ++i1) {
ii = i1 * (i1 - 1) / 2 + ia - 1;
i__3 = i1;
for (j1 = ia; j1 <= i__3; ++j1) {
++ii;
++i2;
/* L60: */
h__[ii] += e1b[i2 - 1] * half;
}
}
i__3 = ib;
for (i1 = ic + 1; i1 <= i__3; ++i1) {
ii = i1 * (i1 + 1) / 2;
/* L70: */
h__[ii] += e1b[0] * half;
}
/* ADD ON THE ELECTRON-NUCLEAR ATTRACTION TERM FOR ATOM J. */
i2 = 0;
i__3 = jc;
for (i1 = ja; i1 <= i__3; ++i1) {
ii = i1 * (i1 - 1) / 2 + ja - 1;
i__4 = i1;
for (j1 = ja; j1 <= i__4; ++j1) {
++ii;
++i2;
/* L80: */
h__[ii] += e2a[i2 - 1] * half;
}
}
i__4 = jb;
for (i1 = jc + 1; i1 <= i__4; ++i1) {
ii = i1 * (i1 + 1) / 2;
/* L90: */
h__[ii] += e2a[0] * half;
}
/* L100: */
}
/* L110: */
}
/* COSMO change */
/* A. KLAMT 16.7.91 */
if (iseps_1.useps) {
/* The following routine adds the dielectric correction for the electron-core */
/* interaction to the diagonal elements of H */
addhcr_(&h__[1]);
/* In the following routine the dielectric correction to the core-core- */
/* interaction is added to ENUCLR */
addnuc_(enuclr);
}
/* end of COSMO change */
if (! debug) {
return 0;
}
s_wsfe(&io___44);
e_wsfe();
vecprt_(&h__[1], &molkst_1.norbs);
j = min(400,kr);
if (euler_1.id == 0) {
s_wsfe(&io___45);
e_wsfe();
s_wsfe(&io___46);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&w[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
} else {
s_wsfe(&io___47);
e_wsfe();
s_wsfe(&io___48);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&wj[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
s_wsfe(&io___49);
e_wsfe();
s_wsfe(&io___50);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&wk[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
}
return 0;
} /* hcore_ */
