/* 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_ */
/* Subroutine */ int denrot_()
{
/* Initialized data */
static char atorbs[7*9+1] = "S-SIGMAP-SIGMA P-PI P-PI D-SIGMA D-PI \
D-PI D-DELL D-DELL";
static integer irot[175] /* was [5][35] */ = { 1,1,1,3,3,2,2,2,4,3,3,2,
2,2,3,4,2,2,3,3,2,3,2,4,2,3,3,2,2,2,4,3,2,3,2,2,4,2,4,4,3,4,2,2,4,
4,4,2,3,4,5,5,3,1,5,6,5,3,4,3,7,5,3,3,3,8,5,3,2,3,9,5,3,5,3,5,6,3,
1,2,6,6,3,4,2,7,7,3,3,2,8,6,3,2,2,9,6,3,5,2,5,7,3,1,4,6,7,3,4,4,7,
7,3,3,4,8,7,3,2,4,9,7,3,5,4,5,8,3,1,1,6,8,3,4,1,7,8,3,3,1,8,8,3,2,
1,9,8,3,5,1,5,9,3,1,5,6,9,3,4,5,7,9,3,3,5,8,9,3,2,5,9,9,3,5,5 };
static integer isp[9] = { 1,2,3,3,4,5,5,6,6 };
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy();
integer s_wsfe(), do_fio(), e_wsfe();
/* Local variables */
static char line[6*21];
static doublereal vect[81] /* was [9][9] */, arot[81] /* was [9][9]
*/;
static integer iprt;
static doublereal c__[75] /* was [3][5][5] */;
static integer i__, j, k, l, m, n;
static doublereal r__;
static integer natom[300], limit, i1, j1;
static char itext[7*300], jtext[2*300];
static integer l1, l2, ma, if__, jf, ii, il, jl, jj, kk, ll, ij, na,
linear;
extern /* Subroutine */ int gmetry_();
static doublereal pab[81] /* was [9][9] */;
extern /* Subroutine */ int coe_();
static integer ipq, jpq;
static doublereal sum, xyz[360] /* was [3][120] */;
/* Fortran I/O blocks */
static cilist io___40 = { 0, 6, 0, "(/16X,10(1X,A7,3X))", 0 };
static cilist io___41 = { 0, 6, 0, "(15X,10(2X,A2,I3,4X))", 0 };
static cilist io___42 = { 0, 6, 0, "(20A6)", 0 };
static cilist io___43 = { 0, 6, 0, "('1')", 0 };
static cilist io___44 = { 0, 6, 0, "(/17X,10(1X,A7,3X))", 0 };
static cilist io___46 = { 0, 6, 0, "( 17X,10(2X,A2,I3,4X))", 0 };
static cilist io___47 = { 0, 6, 0, "(20A6)", 0 };
static cilist io___48 = { 0, 6, 0, "(1X,A7,1X,A2,I3,10F11.6)", 0 };
static cilist io___49 = { 0, 6, 0, "('1')", 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 */
/* *********************************************************************** */
/* DENROT PRINTS THE DENSITY MATRIX AS (S-SIGMA, P-SIGMA, P-PI) RATHER */
/* THAN (S, PX, PY, PZ). */
/* *********************************************************************** */
/* ********************************************************************** */
/* IROT IS A MAPPING LIST. FOR EACH ELEMENT OF AROT 5 NUMBERS ARE */
/* NEEDED. THESE ARE, IN ORDER, FIRST AND SECOND SUBSCRIPTS OF AROT, */
/* AND FIRST,SECOND, AND THIRD SUBSCRIPTS OF C, THUS THE FIRST */
/* LINE OF IROT DEFINES AROT(1,1)=C(1,3,3) */
/* ********************************************************************** */
gmetry_(geom_1.geo, xyz);
iprt = 0;
i__1 = molkst_1.numat;
for (i__ = 1; i__ <= i__1; ++i__) {
if__ = molkst_1.nfirst[i__ - 1];
il = molkst_1.nlast[i__ - 1];
ipq = il - if__ - 1;
ii = ipq + 2;
if (ii == 0) {
goto L120;
}
i__2 = ii;
for (i1 = 1; i1 <= i__2; ++i1) {
j1 = iprt + isp[i1 - 1];
s_copy(itext + (j1 - 1) * 7, atorbs + (i1 - 1) * 7, (ftnlen)7, (
ftnlen)7);
s_copy(jtext + (j1 - 1 << 1), elemts_1.elemnt + (molkst_1.nat[i__
- 1] - 1 << 1), (ftnlen)2, (ftnlen)2);
natom[j1 - 1] = i__;
/* L10: */
}
iprt = j1;
if (ipq != 2) {
/* Computing MIN */
i__2 = max(ipq,1);
ipq = min(i__2,3);
}
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
jf = molkst_1.nfirst[j - 1];
jl = molkst_1.nlast[j - 1];
jpq = jl - jf - 1;
jj = jpq + 2;
if (jj == 0) {
goto L110;
}
if (jpq != 2) {
/* Computing MIN */
i__3 = max(jpq,1);
jpq = min(i__3,3);
}
for (i1 = 1; i1 <= 9; ++i1) {
for (j1 = 1; j1 <= 9; ++j1) {
/* L20: */
pab[i1 + j1 * 9 - 10] = 0.;
}
}
kk = 0;
i__3 = il;
for (k = if__; k <= i__3; ++k) {
++kk;
ll = 0;
i__4 = jl;
for (l = jf; l <= i__4; ++l) {
++ll;
/* L30: */
pab[kk + ll * 9 - 10] = densty_1.p[l + k * (k - 1) / 2 -
1];
}
}
coe_(&xyz[i__ * 3 - 3], &xyz[i__ * 3 - 2], &xyz[i__ * 3 - 1], &
xyz[j * 3 - 3], &xyz[j * 3 - 2], &xyz[j * 3 - 1], &ipq, &
jpq, c__, &r__);
for (i1 = 1; i1 <= 9; ++i1) {
for (j1 = 1; j1 <= 9; ++j1) {
/* L40: */
arot[i1 + j1 * 9 - 10] = 0.;
}
}
for (i1 = 1; i1 <= 35; ++i1) {
/* L50: */
arot[irot[i1 * 5 - 5] + irot[i1 * 5 - 4] * 9 - 10] = c__[irot[
i1 * 5 - 3] + (irot[i1 * 5 - 2] + irot[i1 * 5 - 1] *
5) * 3 - 19];
}
l1 = isp[ii - 1];
l2 = isp[jj - 1];
for (i1 = 1; i1 <= 9; ++i1) {
for (j1 = 1; j1 <= 9; ++j1) {
/* L60: */
vect[i1 + j1 * 9 - 10] = -1.;
}
}
i__4 = l1;
for (i1 = 1; i1 <= i__4; ++i1) {
i__3 = l2;
for (j1 = 1; j1 <= i__3; ++j1) {
/* L70: */
vect[i1 + j1 * 9 - 10] = 0.;
}
}
if (i__ != j) {
ij = max(ii,jj);
i__3 = ii;
for (i1 = 1; i1 <= i__3; ++i1) {
i__4 = jj;
for (j1 = 1; j1 <= i__4; ++j1) {
sum = 0.;
i__5 = ij;
for (l1 = 1; l1 <= i__5; ++l1) {
i__6 = ij;
for (l2 = 1; l2 <= i__6; ++l2) {
/* L80: */
sum += arot[l1 + i1 * 9 - 10] * pab[l1 + l2 *
9 - 10] * arot[l2 + j1 * 9 - 10];
}
}
/* L90: */
/* Computing 2nd power */
d__1 = sum;
vect[isp[i1 - 1] + isp[j1 - 1] * 9 - 10] += d__1 *
d__1;
}
}
}
k = 0;
i__4 = il;
for (i1 = if__; i1 <= i__4; ++i1) {
++k;
l = 0;
i__3 = jl;
for (j1 = jf; j1 <= i__3; ++j1) {
++l;
/* L100: */
if (j1 <= i1) {
scrach_1.b[j1 + i1 * (i1 - 1) / 2 - 1] = vect[k + l *
9 - 10];
}
}
}
L110:
;
}
L120:
;
}
/* NOW TO REMOVE ALL THE DEAD SPACE IN P, CHARACTERIZED BY -1.0 */
linear = molkst_1.norbs * (molkst_1.norbs + 1) / 2;
l = 0;
i__1 = linear;
for (i__ = 1; i__ <= i__1; ++i__) {
if (scrach_1.b[i__ - 1] > (float)-.1) {
++l;
scrach_1.b[l - 1] = scrach_1.b[i__ - 1];
}
/* L130: */
}
/* PUT ATOMIC ORBITAL VALENCIES ONTO THE DIAGONAL */
i__1 = iprt;
for (i__ = 1; i__ <= i__1; ++i__) {
sum = 0.;
ii = i__ * (i__ - 1) / 2;
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
/* L140: */
sum += scrach_1.b[j + ii - 1];
}
i__2 = iprt;
for (j = i__ + 1; j <= i__2; ++j) {
/* L150: */
sum += scrach_1.b[j * (j - 1) / 2 + i__ - 1];
}
/* L160: */
scrach_1.b[i__ * (i__ + 1) / 2 - 1] = sum;
}
for (i__ = 1; i__ <= 21; ++i__) {
/* L170: */
s_copy(line + (i__ - 1) * 6, "------", (ftnlen)6, (ftnlen)6);
}
limit = iprt * (iprt + 1) / 2;
kk = 8;
na = 1;
L180:
ll = 0;
/* Computing MIN */
i__1 = iprt + 1 - na;
m = min(i__1,6);
ma = (m << 1) + 1;
m = na + m - 1;
s_wsfe(&io___40);
i__1 = m;
for (i__ = na; i__ <= i__1; ++i__) {
do_fio(&c__1, itext + (i__ - 1) * 7, (ftnlen)7);
}
e_wsfe();
s_wsfe(&io___41);
i__1 = m;
for (i__ = na; i__ <= i__1; ++i__) {
do_fio(&c__1, jtext + (i__ - 1 << 1), (ftnlen)2);
do_fio(&c__1, (char *)&natom[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
s_wsfe(&io___42);
i__1 = ma;
for (k = 1; k <= i__1; ++k) {
do_fio(&c__1, line + (k - 1) * 6, (ftnlen)6);
}
e_wsfe();
i__1 = iprt;
for (i__ = na; i__ <= i__1; ++i__) {
++ll;
k = i__ * (i__ - 1) / 2;
/* Computing MIN */
i__2 = k + m, i__3 = k + i__;
l = min(i__2,i__3);
k += na;
if (kk + ll <= 50) {
goto L190;
}
s_wsfe(&io___43);
e_wsfe();
s_wsfe(&io___44);
i__2 = m;
for (n = na; n <= i__2; ++n) {
do_fio(&c__1, itext + (n - 1) * 7, (ftnlen)7);
}
e_wsfe();
s_wsfe(&io___46);
i__2 = m;
for (n = na; n <= i__2; ++n) {
do_fio(&c__1, jtext + (n - 1 << 1), (ftnlen)2);
do_fio(&c__1, (char *)&natom[n - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
s_wsfe(&io___47);
i__2 = ma;
for (n = 1; n <= i__2; ++n) {
do_fio(&c__1, line + (n - 1) * 6, (ftnlen)6);
}
e_wsfe();
kk = 4;
ll = 0;
L190:
s_wsfe(&io___48);
do_fio(&c__1, itext + (i__ - 1) * 7, (ftnlen)7);
do_fio(&c__1, jtext + (i__ - 1 << 1), (ftnlen)2);
do_fio(&c__1, (char *)&natom[i__ - 1], (ftnlen)sizeof(integer));
i__2 = l;
for (n = k; n <= i__2; ++n) {
do_fio(&c__1, (char *)&scrach_1.b[n - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L200: */
}
if (l >= limit) {
goto L210;
}
kk = kk + ll + 4;
na = m + 1;
if (kk + iprt + 1 - na <= 50) {
goto L180;
}
kk = 4;
s_wsfe(&io___49);
e_wsfe();
goto L180;
L210:
return 0;
} /* denrot_ */
/* 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 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 deritr_(doublereal *errfn, doublereal *geo)
{
/* Initialized data */
static integer icalcn = 0;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
double pow_di(doublereal *, integer *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static integer i__, j, k, l;
#define w ((doublereal *)&wmatrx_1)
static doublereal aa, ee;
static integer ij, ii, il, jl, kl, ll;
extern /* Subroutine */ int iter_(doublereal *, doublereal *, doublereal *
, doublereal *, doublereal *, logical *, logical *);
static doublereal xjuc[3];
static logical debug;
extern /* Subroutine */ int hcore_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *, doublereal *);
static doublereal coord[360] /* was [3][120] */, change[3];
static integer idelta, linear;
static doublereal xparam[360], xderiv[3];
extern /* Subroutine */ int gmetry_(doublereal *, doublereal *);
static doublereal xstore;
extern /* Subroutine */ int symtry_(void);
/* Fortran I/O blocks */
static cilist io___24 = { 0, 6, 0, "(' ERROR FUNCTION')", 0 };
static cilist io___25 = { 0, 6, 0, "(10F8.3)", 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 */
/* *********************************************************************** */
/* DERITR CALCULATES THE DERIVATIVES OF THE ENERGY WITH RESPECT TO THE */
/* INTERNAL COORDINATES. THIS IS DONE BY FINITE DIFFERENCES */
/* USING FULL SCF CALCULATIONS. */
/* THIS IS VERY TIME-CONSUMING, AND SHOULD ONLY BE USED WHEN */
/* NO OTHER DERIVATIVE CALCULATION WILL DO. */
/* 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. */
/* *********************************************************************** */
/* Parameter adjustments */
geo -= 4;
--errfn;
/* Function Body */
if (icalcn != numcal_1.numcal) {
debug = i_indx(keywrd_1.keywrd, "DERITR", (ftnlen)241, (ftnlen)6) !=
0;
icalcn = numcal_1.numcal;
/* IDELTA IS A MACHINE-PRECISION DEPENDANT INTEGER */
idelta = -3;
change[0] = pow_di(&c_b3, &idelta);
change[1] = pow_di(&c_b3, &idelta);
change[2] = pow_di(&c_b3, &idelta);
/* CHANGE(I) IS THE STEP SIZE USED IN CALCULATING THE DERIVATIVES. */
/* BECAUSE FULL SCF CALCULATIONS ARE BEING DONE QUITE LARGE STEPS */
/* ARE NEEDED. ON THE OTHER HAND, 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. */
xderiv[0] = .5 / change[0];
xderiv[1] = .5 / change[1];
xderiv[2] = .5 / change[2];
}
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
xparam[i__ - 1] = geo[geovar_1.loc[(i__ << 1) - 1] + geovar_1.loc[(
i__ << 1) - 2] * 3];
}
if (geosym_1.ndep != 0) {
symtry_();
}
gmetry_(&geo[4], coord);
/* ESTABLISH THE ENERGY AT THE CURRENT POINT */
hcore_(coord, hmatrx_1.h__, w, wmatrx_1.wj, wmatrx_1.wk, &enuclr_1.enuclr)
;
if (molkst_1.norbs * molkst_1.nelecs > 0) {
iter_(hmatrx_1.h__, w, wmatrx_1.wj, wmatrx_1.wk, &aa, &c_true, &
c_false);
} else {
aa = 0.;
}
linear = molkst_1.norbs * (molkst_1.norbs + 1) / 2;
/* RESTORE THE DENSITY MATRIX (WHY?) */
i__1 = linear;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
densty_1.p[i__ - 1] = densty_1.pa[i__ - 1] * 2.;
}
aa += enuclr_1.enuclr;
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) {
for (ll = 1; ll <= 3; ++ll) {
/* L30: */
xjuc[ll - 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;
/* L50: */
}
}
}
/* L60: */
}
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
k = geovar_1.loc[(i__ << 1) - 2];
l = geovar_1.loc[(i__ << 1) - 1];
xstore = xparam[i__ - 1];
i__4 = geovar_1.nvar;
for (j = 1; j <= i__4; ++j) {
/* L70: */
geo[geovar_1.loc[(j << 1) - 1] + geovar_1.loc[(j << 1) - 2] * 3] =
xparam[j - 1];
}
geo[l + k * 3] = xstore - change[l - 1];
if (geosym_1.ndep != 0) {
symtry_();
}
gmetry_(&geo[4], coord);
/* IF NEEDED, CALCULATE "EXACT" DERIVITIVES. */
hcore_(coord, hmatrx_1.h__, w, wmatrx_1.wj, wmatrx_1.wk, &
enuclr_1.enuclr);
if (molkst_1.norbs * molkst_1.nelecs > 0) {
iter_(hmatrx_1.h__, w, wmatrx_1.wj, wmatrx_1.wk, &ee, &c_true, &
c_false);
} else {
ee = 0.;
}
i__4 = linear;
for (ii = 1; ii <= i__4; ++ii) {
/* L80: */
densty_1.p[ii - 1] = densty_1.pa[ii - 1] * 2.;
}
ee += enuclr_1.enuclr;
errfn[i__] = (aa - ee) * 23.061 * xderiv[l - 1] * 2.;
/* L90: */
}
if (debug) {
s_wsfe(&io___24);
e_wsfe();
s_wsfe(&io___25);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&errfn[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
}
return 0;
} /* deritr_ */
