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