/* 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_ */
/* ------------------------------------------------------------------ */
/* Main program */ int MAIN__(void)
{
/* Format strings */
static char fmt_6000[] = "(3x,1p5e13.5)";
static char fmt_6110[] = "(1x,\002!!! WARNING: NEGATIVE \002,a,\002XS WA"
"S DETECTED IN GROUP\002,i3)";
static char fmt_6120[] = "(1x,\002!!! WARNING: NEGATIVE \002,a,\002XS WA"
"S DETECTED : \002,\002FROM GROUP \002,i3,\002 TO GROUP \002,i3)";
static char fmt_6130[] = "(1x,\002!!! WARNING: NEGATIVE SCATTERIG XS ("
"=\002,1pe12.5,\002) WAS SET TO ZERO.\002,/,\002 IT WAS ADDED"
" TO TOTAL(TRANSPORT) XS OF GROUP \002,i3)";
static char fmt_6200[] = "(1x,\002IGG=\002,i3,2x,1p220e12.5:/(10x,1p220e"
"12.5:))";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1;
static real equiv_0[1000000];
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_wsfe(cilist *), e_wsfe(void), s_rsle(cilist *), e_rsle(void),
s_cmp(char *, char *, ftnlen, ftnlen), s_wsue(cilist *), do_uio(
integer *, char *, ftnlen), e_wsue(void);
/* Local variables */
static integer i__, k, l, m, ig;
static real en[108];
static integer ng;
static real wt[108];
static integer igg, idm[50], irc;
static real scm[1144900] /* was [107][107][2][50] */;
static integer nin, ldw, lgv, npl, iht, lup, lss;
static real sum, xsm[32100] /* was [107][3][2][50] */;
static integer nds1, npl1, imac;
static char etag[1];
static integer leng, nbin, isgg;
static real scat[16692] /* was [107][156] */;
static char ptag[1*6*2];
static real xkai[5350] /* was [107][50] */;
static integer itbl, idum, nmat;
static real xsec[1070] /* was [107][10] */;
static integer note, lsct, iprn, itmp, ipos, iout;
#define work (equiv_0)
static integer nout1, nout2;
static real delay[4815] /* was [15][107][3] */;
static integer msave;
extern /* Subroutine */ int pdsin_(char *, char *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer minsg, maxsg;
static char title[48];
static integer mcopt;
#define iwork ((integer *)equiv_0)
static integer mxdws, mxups;
extern /* Subroutine */ int macedt_(char *, integer *, integer *, char *,
integer *, real *, integer *, integer *, real *, real *, ftnlen,
ftnlen);
static integer idebug;
extern /* Subroutine */ int engedt_(char *, integer *, integer *, char *,
integer *, real *, real *, ftnlen, ftnlen);
static char member[8*50], dirnam[72], memnam[8];
extern /* Subroutine */ int uioset_(void);
/* Fortran I/O blocks */
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___16 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___18 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___20 = { 0, 0, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___24 = { 0, 0, 1, "(A72)", 0 };
static cilist io___31 = { 0, 0, 0, 0, 0 };
static cilist io___35 = { 0, 0, 0, 0, 0 };
static cilist io___36 = { 0, 0, 0, 0, 0 };
static cilist io___37 = { 0, 0, 0, 0, 0 };
static cilist io___38 = { 0, 0, 0, 0, 0 };
static cilist io___39 = { 0, 0, 0, fmt_6000, 0 };
static cilist io___41 = { 0, 0, 0, 0, 0 };
static cilist io___42 = { 0, 0, 0, 0, 0 };
static cilist io___47 = { 0, 0, 0, 0, 0 };
static cilist io___48 = { 0, 0, 0, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___50 = { 0, 0, 0, 0, 0 };
static cilist io___51 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, 0, 0 };
static cilist io___55 = { 0, 0, 1, "(A8,I10)", 0 };
static cilist io___57 = { 0, 0, 0, 0, 0 };
static cilist io___64 = { 0, 0, 0, 0, 0 };
static cilist io___70 = { 0, 0, 0, 0, 0 };
static cilist io___71 = { 0, 0, 0, 0, 0 };
static cilist io___72 = { 0, 0, 0, 0, 0 };
static cilist io___78 = { 0, 0, 0, 0, 0 };
static cilist io___79 = { 0, 0, 0, 0, 0 };
static cilist io___80 = { 0, 0, 0, 0, 0 };
static cilist io___81 = { 0, 0, 0, 0, 0 };
static cilist io___82 = { 0, 0, 0, 0, 0 };
static cilist io___83 = { 0, 0, 0, 0, 0 };
static cilist io___84 = { 0, 0, 0, 0, 0 };
static cilist io___85 = { 0, 0, 0, 0, 0 };
static cilist io___86 = { 0, 0, 0, 0, 0 };
static cilist io___87 = { 0, 0, 0, 0, 0 };
static cilist io___88 = { 0, 0, 0, 0, 0 };
static cilist io___89 = { 0, 0, 0, 0, 0 };
static cilist io___95 = { 0, 0, 0, 0, 0 };
static cilist io___96 = { 0, 0, 0, 0, 0 };
static cilist io___97 = { 0, 0, 0, 0, 0 };
static cilist io___98 = { 0, 0, 0, 0, 0 };
static cilist io___100 = { 0, 0, 0, 0, 0 };
static cilist io___101 = { 0, 0, 0, fmt_6000, 0 };
static cilist io___102 = { 0, 0, 0, 0, 0 };
static cilist io___104 = { 0, 0, 0, fmt_6110, 0 };
static cilist io___105 = { 0, 0, 0, fmt_6110, 0 };
static cilist io___106 = { 0, 0, 0, fmt_6110, 0 };
static cilist io___110 = { 0, 0, 0, fmt_6120, 0 };
static cilist io___111 = { 0, 0, 0, fmt_6130, 0 };
static cilist io___114 = { 0, 0, 0, fmt_6200, 0 };
static cilist io___116 = { 0, 0, 0, 0, 0 };
static cilist io___117 = { 0, 0, 0, 0, 0 };
static cilist io___118 = { 0, 0, 0, 0, 0 };
static cilist io___119 = { 0, 0, 0, 0, 0 };
static cilist io___120 = { 0, 0, 0, 0, 0 };
static cilist io___121 = { 0, 0, 0, 0, 0 };
/* ------------------------------------------------------------------ */
/* *********************************************************************** */
/* XSM(g,1,L,m) : absorption XS of m-th material (L-1 order) */
/* XSM(g,2,L,m) : production */
/* XSM(g,3,L,m) : total/transport */
/* SCM(g,g',L,m) : scattering matrix (g->g') of m-th material */
/* XKAI(g,m) : fission spectrum */
/* ----------------------------------------------------------------------- */
/* *********************************************************************** */
/* If you change I/O device number, */
/* Change subroutine (uiount) at the last. */
nin = 5;
nout1 = 6;
nout2 = 99;
nbin = 1;
iout = nout1;
iprn = 1;
note = 0;
uioset_();
/* *********************************************************************** */
/* LOGO PRINT (99) */
/* *********************************************************************** */
io___10.ciunit = nout1;
s_wsle(&io___10);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___11.ciunit = nout1;
s_wsle(&io___11);
do_lio(&c__9, &c__1, " SRAC UTILITY TO CONVERT MACROSCOPIC XS DATA", (
ftnlen)44);
e_wsle();
io___12.ciunit = nout1;
s_wsle(&io___12);
do_lio(&c__9, &c__1, " OF PDS TO ANISN TYPE BINARY LIBRARY DATA", (ftnlen)
41);
e_wsle();
io___13.ciunit = nout1;
s_wsle(&io___13);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___14.ciunit = nout2;
s_wsle(&io___14);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___15.ciunit = nout2;
s_wsle(&io___15);
do_lio(&c__9, &c__1, " SRAC UTILITY TO CONVERT MACROSCOPIC XS DATA", (
ftnlen)44);
e_wsle();
io___16.ciunit = nout2;
s_wsle(&io___16);
do_lio(&c__9, &c__1, " OF PDS TO ANISN TYPE BINARY LIBRARY DATA", (ftnlen)
41);
e_wsle();
io___17.ciunit = nout2;
s_wsle(&io___17);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___18.ciunit = nout2;
s_wsle(&io___18);
do_lio(&c__9, &c__1, " THE BINARY DATA IS AVAILABLE IN ANISN, TWOTRAN", (
ftnlen)47);
do_lio(&c__9, &c__1, " GMVP, MORSE, ETC.", (ftnlen)18);
e_wsle();
io___19.ciunit = nout2;
s_wsle(&io___19);
do_lio(&c__9, &c__1, " NOTE: ANISN FORMAT DOSE NOT INCLUDE MATERIAL-", (
ftnlen)46);
do_lio(&c__9, &c__1, " DEPENDENT FISSION SPECTRA.", (ftnlen)27);
e_wsle();
io___20.ciunit = nout2;
s_wsle(&io___20);
do_lio(&c__9, &c__1, " USE THE PRINTED FISSION SPECTRA IF NECESSARY.", (
ftnlen)46);
e_wsle();
io___21.ciunit = nout2;
s_wsle(&io___21);
e_wsle();
/* *********************************************************************** */
/* SET PL-TAG OF SRAC MEMBERS IN MACRO(1) OR MACROWRK(2) */
/* (SET INITIAL CHARACTER DATA) */
/* *********************************************************************** */
s_copy(title, " ", (ftnlen)
48, (ftnlen)48);
*(unsigned char *)&ptag[0] = '0';
*(unsigned char *)&ptag[1] = '1';
*(unsigned char *)&ptag[2] = 'X';
*(unsigned char *)&ptag[3] = 'X';
*(unsigned char *)&ptag[4] = 'X';
*(unsigned char *)&ptag[5] = 'X';
*(unsigned char *)&ptag[6] = '4';
*(unsigned char *)&ptag[7] = '3';
*(unsigned char *)&ptag[8] = '5';
*(unsigned char *)&ptag[9] = '6';
*(unsigned char *)&ptag[10] = '7';
*(unsigned char *)&ptag[11] = '8';
/* *********************************************************************** */
/* READ DIRECTORY NAME OF MACRO/MACROWRK */
/* Check MACRO or MACROWRK */
/* READ ENERGY GROUP STRUCTURE FROM CONTA00[0,2] */
/* *********************************************************************** */
/* IMAC=1 : MACRO */
/* =2 : MACROWRK */
io___24.ciunit = nin;
i__1 = s_rsfe(&io___24);
if (i__1 != 0) {
goto L9999;
}
i__1 = do_fio(&c__1, dirnam, (ftnlen)72);
if (i__1 != 0) {
goto L9999;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L9999;
}
s_copy(memnam, "CONTA000", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 1;
*(unsigned char *)etag = 'A';
goto L100;
}
s_copy(memnam, "CONTA002", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 2;
*(unsigned char *)etag = 'A';
goto L100;
}
s_copy(memnam, "CONTF000", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 1;
*(unsigned char *)etag = 'F';
goto L100;
}
s_copy(memnam, "CONTF002", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 2;
*(unsigned char *)etag = 'F';
goto L100;
}
io___31.ciunit = nout1;
s_wsle(&io___31);
do_lio(&c__9, &c__1, " ERROR : PDSIN FAILED, IRC=", (ftnlen)27);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
s_stop("999", (ftnlen)3);
L100:
engedt_(dirnam, &iout, &iprn, memnam, &ng, wt, en, (ftnlen)72, (ftnlen)8);
io___35.ciunit = nout2;
s_wsle(&io___35);
do_lio(&c__9, &c__1, " NUMBER OF ENERGY GROUPS = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&ng, (ftnlen)sizeof(integer));
e_wsle();
io___36.ciunit = nout2;
s_wsle(&io___36);
e_wsle();
io___37.ciunit = nout2;
s_wsle(&io___37);
do_lio(&c__9, &c__1, " << ENERGY BOUNDARY OF MACROSCOPIC XS >>", (ftnlen)
40);
e_wsle();
io___38.ciunit = nout2;
s_wsle(&io___38);
e_wsle();
io___39.ciunit = nout2;
s_wsfe(&io___39);
i__1 = ng + 1;
for (ig = 1; ig <= i__1; ++ig) {
do_fio(&c__1, (char *)&en[ig - 1], (ftnlen)sizeof(real));
}
e_wsfe();
io___41.ciunit = nout2;
s_wsle(&io___41);
e_wsle();
/* *********************************************************************** */
/* READ PL ORDER AND Monte Carlo Option */
/* MCOPT = 0 : accept negative XS (caused by transport correction) */
/* = 1 : not accept negative scattering XS */
/* SIGT = SIGT + ABS(SIGS) and SIGS=0 */
/* MSAVE = 0 : down-scattering size is forced to be NG-1 (suggested) */
/* = 1 : down-scattering size is searched (additional input NDS1 */
/* is necessary in GMVP (output library may be not available */
/* in some codes (ex. MORSE) */
/* *********************************************************************** */
io___42.ciunit = nin;
s_rsle(&io___42);
do_lio(&c__3, &c__1, (char *)&npl, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&mcopt, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&idebug, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&msave, (ftnlen)sizeof(integer));
e_rsle();
io___47.ciunit = nout2;
s_wsle(&io___47);
do_lio(&c__9, &c__1, " INPUT PL ORDER (NPL) = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&npl, (ftnlen)sizeof(integer));
e_wsle();
io___48.ciunit = nout2;
s_wsle(&io___48);
do_lio(&c__9, &c__1, " OPTION FOR NEGATIVE XS = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&mcopt, (ftnlen)sizeof(integer));
e_wsle();
io___49.ciunit = nout2;
s_wsle(&io___49);
do_lio(&c__9, &c__1, " OPTION FOR DEBUG PRINT = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&idebug, (ftnlen)sizeof(integer));
e_wsle();
io___50.ciunit = nout2;
s_wsle(&io___50);
do_lio(&c__9, &c__1, " OPTION FOR MEMORY SAVVING = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&msave, (ftnlen)sizeof(integer));
e_wsle();
if (npl < 0) {
io___51.ciunit = nout1;
s_wsle(&io___51);
do_lio(&c__9, &c__1, " ERROR: INPUT PL-OREDER(=", (ftnlen)25);
do_lio(&c__3, &c__1, (char *)&npl, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS INVALID", (ftnlen)12);
e_wsle();
}
if (mcopt != 0) {
mcopt = 1;
}
if (npl > 1) {
io___52.ciunit = nout1;
s_wsle(&io___52);
do_lio(&c__9, &c__1, " ERROR: INPUT PL-OREDER IS GREATER THAN", (
ftnlen)39);
do_lio(&c__9, &c__1, " PROGRAM ARRAY SIZE (=", (ftnlen)22);
do_lio(&c__3, &c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
s_stop("777", (ftnlen)3);
}
if (npl == 0 && imac == 2) {
*(unsigned char *)&ptag[6] = '2';
}
npl1 = npl + 1;
/* *********************************************************************** */
/* READ MEMBERS (MATERIALS) */
/* *********************************************************************** */
nmat = 0;
L200:
io___55.ciunit = nin;
i__1 = s_rsfe(&io___55);
if (i__1 != 0) {
goto L210;
}
i__1 = do_fio(&c__1, memnam, (ftnlen)8);
if (i__1 != 0) {
goto L210;
}
i__1 = do_fio(&c__1, (char *)&idum, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L210;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L210;
}
if (s_cmp(memnam, " ", (ftnlen)8, (ftnlen)8) == 0) {
goto L210;
}
++nmat;
if (nmat > 50) {
io___57.ciunit = nout1;
s_wsle(&io___57);
do_lio(&c__9, &c__1, " ERROR: NUMBER OF INPUT MEMBERS IS ", (ftnlen)
35);
do_lio(&c__9, &c__1, " GREATER THAN PROGRAM ARRAY SIZE (=", (ftnlen)
35);
do_lio(&c__3, &c__1, (char *)&c__50, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
s_stop("777", (ftnlen)3);
}
s_copy(member + (nmat - 1 << 3), memnam, (ftnlen)8, (ftnlen)8);
idm[nmat - 1] = idum;
goto L200;
L210:
/* *********************************************************************** */
/* SEARCH MAX UP-SCATTERING AND MAX DOWN-SCATTERIG SIZES */
/* AMONG MEMBERS */
/* *********************************************************************** */
mxups = 0;
mxdws = 0;
i__1 = nmat;
for (m = 1; m <= i__1; ++m) {
i__2 = npl1;
for (l = 1; l <= i__2; ++l) {
s_copy(memnam, member + (m - 1 << 3), (ftnlen)8, (ftnlen)8);
*(unsigned char *)&memnam[4] = *(unsigned char *)etag;
*(unsigned char *)&memnam[7] = *(unsigned char *)&ptag[l + imac *
6 - 7];
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (
ftnlen)8);
if (irc != 0) {
io___64.ciunit = nout1;
s_wsle(&io___64);
do_lio(&c__9, &c__1, " ERROR : PDSIN FAILED, IRC=", (ftnlen)
27);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
s_stop("999", (ftnlen)3);
}
ipos = 0;
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
lss = iwork[ipos];
lgv = iwork[ipos + 1];
lup = lss - 1;
ldw = lgv - lss;
mxups = max(lup,mxups);
mxdws = max(ldw,mxdws);
ipos = ipos + 10 + lgv;
/* L320: */
}
/* L310: */
}
/* L300: */
}
if (msave == 0) {
io___70.ciunit = nout2;
s_wsle(&io___70);
do_lio(&c__9, &c__1, " REAL MAX. SIZE OF DOWN-SCATTERING (", (ftnlen)
36);
do_lio(&c__3, &c__1, (char *)&mxdws, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") WAS REPLACED BY ", (ftnlen)18);
i__1 = ng - 1;
do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsle();
mxdws = ng - 1;
}
io___71.ciunit = nout2;
s_wsle(&io___71);
do_lio(&c__9, &c__1, " MAX. SIZE OF UP-SCATTERING = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&mxups, (ftnlen)sizeof(integer));
e_wsle();
io___72.ciunit = nout2;
s_wsle(&io___72);
do_lio(&c__9, &c__1, " MAX. SIZE OF DOWN-SCATTERING = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&mxdws, (ftnlen)sizeof(integer));
e_wsle();
/* *********************************************************************** */
/* READ MEMBER XS AND SET IT IN ANISN FORMAT */
/* *********************************************************************** */
/* IHT : position of total cross section in a group XS data */
/* ISGG: position of self-scattering in a group XS data */
/* ITBL: length of a group XS data */
/* LSCT: length of a scattering data in a group */
/* LENG: record length of all group XS data */
/* NDS1: size of down-scattering + 1(self-scattering) */
iht = 3;
isgg = iht + mxups + 1;
itbl = isgg + mxdws;
lsct = mxups + 1 + mxdws;
leng = ng * itbl;
nds1 = mxdws + 1;
io___78.ciunit = nout2;
s_wsle(&io___78);
do_lio(&c__9, &c__1, " SIZE OF SCATTERING VECTOR = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&lsct, (ftnlen)sizeof(integer));
e_wsle();
io___79.ciunit = nout2;
s_wsle(&io___79);
do_lio(&c__9, &c__1, " IHT : POSITION OF TOTAL XS = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&iht, (ftnlen)sizeof(integer));
e_wsle();
io___80.ciunit = nout2;
s_wsle(&io___80);
do_lio(&c__9, &c__1, " ISGG: POSITION OF SELF-SCATTERNG = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&isgg, (ftnlen)sizeof(integer));
e_wsle();
io___81.ciunit = nout2;
s_wsle(&io___81);
do_lio(&c__9, &c__1, " ITBL: LENGTH OF A GROUP XS DATA = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&itbl, (ftnlen)sizeof(integer));
e_wsle();
io___82.ciunit = nout2;
s_wsle(&io___82);
do_lio(&c__9, &c__1, " NDS1: LENGTH OF DOWN+SELF SCAT. = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&nds1, (ftnlen)sizeof(integer));
e_wsle();
/* ----- MACEDT ARRANGEMENT ------------------------------ */
/* XSEX(g,1): production */
/* XSEX(g,2): fission */
/* XSEX(g,3): capture defined as (absorption - fission) */
/* XSEX(g,4): absorption */
/* XSEX(g,5): fission spectrum */
/* XSEX(g,6): diffusion coefficient (D1) */
/* XSEX(g,7): diffusion coefficient (D2) */
/* XSEX(g,8): total or transport */
/* XSEX(g,9): velocity cross section */
/* SCAT(g,g'): full size of scattering matrix (g=>g') */
/* ----- FOR ANISN FORMAT */
/* XSM(g,1,L,m) : absorption XS of m-th material (L-1 order) */
/* XSM(g,2,L,m) : production */
/* XSM(g,3,L,m) : total/transport */
/* SCM(g,g',L,m) : scattering matrix (g->g') of m-th material */
/* ----- Sample when NG=9 -------------------------------------- */
/* 1 2 IHT, [MXUPS] ISGG [MXDWS] ITBL */
/* g=1 Ag, Pg, Tg, 0 .....3->1 2->1 1->1 0 0 0 ....... 0 */
/* g=2 Ag, Pg, Tg, 0 0 ...4->2 3->2 2->2 1->2 ....... 0 */
/* g=3 Ag, Pg, Tg, 0 0 0 0 ....4->3 3->3 2->3 1->3 .. 0 */
/* : : : : : : : : : : */
/* : : : : : : : : : : */
/* g=9 Ag, Pg, Tg, 0 0 0 0 ......0 9->9 8->9 7->9 .... */
/* ------------------------------------------------------------- */
io___83.ciunit = nout2;
s_wsle(&io___83);
e_wsle();
i__1 = nmat;
for (m = 1; m <= i__1; ++m) {
io___84.ciunit = nout2;
s_wsle(&io___84);
e_wsle();
io___85.ciunit = nout2;
s_wsle(&io___85);
do_lio(&c__9, &c__1, " ******************************", (ftnlen)31);
e_wsle();
io___86.ciunit = nout2;
s_wsle(&io___86);
do_lio(&c__9, &c__1, " INPUT MEMBER NAME = ", (ftnlen)22);
do_lio(&c__9, &c__1, member + (m - 1 << 3), (ftnlen)8);
e_wsle();
io___87.ciunit = nout2;
s_wsle(&io___87);
do_lio(&c__9, &c__1, " INPUT MATERIAL ID = ", (ftnlen)22);
do_lio(&c__3, &c__1, (char *)&idm[m - 1], (ftnlen)sizeof(integer));
e_wsle();
io___88.ciunit = nout2;
s_wsle(&io___88);
do_lio(&c__9, &c__1, " ******************************", (ftnlen)31);
e_wsle();
io___89.ciunit = nout2;
s_wsle(&io___89);
e_wsle();
i__2 = npl1;
for (l = 1; l <= i__2; ++l) {
s_copy(memnam, member + (m - 1 << 3), (ftnlen)8, (ftnlen)8);
*(unsigned char *)&memnam[4] = *(unsigned char *)etag;
*(unsigned char *)&memnam[7] = *(unsigned char *)&ptag[l + imac *
6 - 7];
macedt_(dirnam, &iout, &iprn, memnam, &ng, xsec, &minsg, &maxsg,
scat, delay, (ftnlen)72, (ftnlen)8);
if (idebug == 1) {
io___95.ciunit = nout2;
s_wsle(&io___95);
e_wsle();
io___96.ciunit = nout2;
s_wsle(&io___96);
do_lio(&c__9, &c__1, " << MEMBER NAME OF THE PL(=", (ftnlen)
27);
i__3 = l - 1;
do_lio(&c__3, &c__1, (char *)&i__3, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") COMPONENT : ", (ftnlen)14);
do_lio(&c__9, &c__1, memnam, (ftnlen)8);
do_lio(&c__9, &c__1, " >>", (ftnlen)3);
e_wsle();
io___97.ciunit = nout2;
s_wsle(&io___97);
e_wsle();
}
s_copy(title, memnam, (ftnlen)8, (ftnlen)8);
io___98.ciunit = nbin;
s_wsue(&io___98);
do_uio(&c__1, (char *)&ng, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&itbl, (ftnlen)sizeof(integer));
i__3 = l - 1;
do_uio(&c__1, (char *)&i__3, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&idm[m - 1], (ftnlen)sizeof(integer));
do_uio(&c__1, title, (ftnlen)48);
e_wsue();
if (l == 1) {
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
xkai[ig + m * 107 - 108] = xsec[ig + 427];
/* L400: */
}
io___100.ciunit = nout2;
s_wsle(&io___100);
do_lio(&c__9, &c__1, " << MATERIAL DEPENDENT FISSION SPECTRU"
"M >>", (ftnlen)42);
e_wsle();
io___101.ciunit = nout2;
s_wsfe(&io___101);
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
do_fio(&c__1, (char *)&xkai[ig + m * 107 - 108], (ftnlen)
sizeof(real));
}
e_wsfe();
io___102.ciunit = nout2;
s_wsle(&io___102);
e_wsle();
}
/* *********************************************************************** */
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
xsm[ig + ((l + (m << 1)) * 3 + 1) * 107 - 1071] = xsec[ig +
320];
xsm[ig + ((l + (m << 1)) * 3 + 2) * 107 - 1071] = xsec[ig - 1]
;
xsm[ig + ((l + (m << 1)) * 3 + 3) * 107 - 1071] = xsec[ig +
748];
/* -----------Check Negative XS */
if (l == 1) {
if (xsm[ig + ((l + (m << 1)) * 3 + 1) * 107 - 1071] < 0.f)
{
io___104.ciunit = nout2;
s_wsfe(&io___104);
do_fio(&c__1, "ABSORPTION", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
if (xsm[ig + ((l + (m << 1)) * 3 + 2) * 107 - 1071] < 0.f)
{
io___105.ciunit = nout2;
s_wsfe(&io___105);
do_fio(&c__1, "PRODUCTION", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
if (xsm[ig + ((l + (m << 1)) * 3 + 3) * 107 - 1071] < 0.f)
{
io___106.ciunit = nout2;
s_wsfe(&io___106);
do_fio(&c__1, "TOTAL(TRA)", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
}
sum = 0.f;
i__4 = ng;
for (igg = 1; igg <= i__4; ++igg) {
scm[ig + (igg + (l + (m << 1)) * 107) * 107 - 34455] =
scat[ig + igg * 107 + 5135];
/* -----------Check Negative Scattering XS */
if (l == 1) {
if (scm[ig + (igg + (l + (m << 1)) * 107) * 107 -
34455] < 0.f) {
io___110.ciunit = nout2;
s_wsfe(&io___110);
do_fio(&c__1, "SCATTERING", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&igg, (ftnlen)sizeof(
integer));
e_wsfe();
++note;
if (mcopt != 0) {
sum += (r__1 = scm[ig + (igg + (l + (m << 1))
* 107) * 107 - 34455], dabs(r__1));
scm[ig + (igg + (l + (m << 1)) * 107) * 107 -
34455] = 0.f;
}
}
}
/* L420: */
}
if (l == 1 && sum != 0.f) {
xsm[ig + ((l + (m << 1)) * 3 + 3) * 107 - 1071] += sum;
io___111.ciunit = nout2;
s_wsfe(&io___111);
do_fio(&c__1, (char *)&sum, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
/* L410: */
}
/* --------- set one group XS data(one record) in WORK dimension */
/* (Note : loop on sink group) */
ipos = 0;
i__3 = ng;
for (igg = 1; igg <= i__3; ++igg) {
work[ipos] = xsm[igg + ((l + (m << 1)) * 3 + 1) * 107 - 1071];
work[ipos + 1] = xsm[igg + ((l + (m << 1)) * 3 + 2) * 107 -
1071];
work[ipos + 2] = xsm[igg + ((l + (m << 1)) * 3 + 3) * 107 -
1071];
ipos += 3;
/* -----------SET SCATTERIG XS (LSCT=MXUPS+1+MXDWS) */
i__4 = lsct;
for (k = 1; k <= i__4; ++k) {
ig = igg + mxups + 1 - k;
if (ig <= ng && ig >= 1) {
work[ipos + k - 1] = scm[ig + (igg + (l + (m << 1)) *
107) * 107 - 34455];
} else {
work[ipos + k - 1] = 0.f;
}
/* L440: */
}
ipos += lsct;
if (idebug == 1) {
itmp = ipos - (lsct + 3) + 1;
io___114.ciunit = nout2;
s_wsfe(&io___114);
do_fio(&c__1, (char *)&igg, (ftnlen)sizeof(integer));
i__4 = ipos;
for (i__ = itmp; i__ <= i__4; ++i__) {
do_fio(&c__1, (char *)&work[i__ - 1], (ftnlen)sizeof(
real));
}
e_wsfe();
}
/* L430: */
}
io___116.ciunit = nbin;
s_wsue(&io___116);
i__3 = ipos;
for (i__ = 1; i__ <= i__3; ++i__) {
do_uio(&c__1, (char *)&work[i__ - 1], (ftnlen)sizeof(real));
}
e_wsue();
/* L1100: */
}
/* L1000: */
}
if (note != 0) {
io___117.ciunit = nout2;
s_wsle(&io___117);
e_wsle();
io___118.ciunit = nout2;
s_wsle(&io___118);
do_lio(&c__9, &c__1, " THERE ARE ", (ftnlen)11);
do_lio(&c__3, &c__1, (char *)¬e, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " WARNING MESSAGES MARKED ", (ftnlen)25);
do_lio(&c__9, &c__1, "BY (!!! WARNING:) ", (ftnlen)18);
e_wsle();
io___119.ciunit = nout2;
s_wsle(&io___119);
e_wsle();
}
io___120.ciunit = nout2;
s_wsle(&io___120);
e_wsle();
io___121.ciunit = nout2;
s_wsle(&io___121);
do_lio(&c__9, &c__1, " ================ NORMAL END ===================", (
ftnlen)48);
e_wsle();
/* *********************************************************************** */
L9999:
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* Subroutine */ int forsav_(doublereal *time, doublereal *deldip, integer *
ipt, doublereal *fmatrx, doublereal *coord, integer *nvar, doublereal
*refh, doublereal *evecs, integer *jstart, doublereal *fconst)
{
/* System generated locals */
integer i__1, i__2;
char ch__1[80];
olist o__1;
cllist cl__1;
alist al__1;
/* Builtin functions */
integer f_open(olist *), f_rew(alist *), s_rsue(cilist *), do_uio(integer
*, char *, ftnlen), e_rsue(void), s_wsue(cilist *), e_wsue(void),
f_clos(cllist *), s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static integer i__, j, n33, ir, iw;
extern /* Character */ VOID getnam_(char *, ftnlen, char *, ftnlen);
static integer linear;
/* Fortran I/O blocks */
static cilist io___3 = { 1, 0, 1, 0, 0 };
static cilist io___5 = { 0, 0, 0, 0, 0 };
static cilist io___7 = { 1, 0, 1, 0, 0 };
static cilist io___8 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___16 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___18 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 10, 0, 0, 0 };
static cilist io___20 = { 0, 10, 0, 0, 0 };
static cilist io___21 = { 0, 6, 0, "(10X,'INSUFFICIENT DATA ON DISK FILE"
"S FOR A FORCE ', 'CALCULATION',/10X,'RESTART. PERHAPS THIS STA"
"RTED OF AS A ', 'FORCE CALCULATION ')", 0 };
static cilist io___22 = { 0, 6, 0, "(10X,'BUT THE GEOMETRY HAD TO BE OPT"
"IMIZED FIRST, ', 'IN WHICH CASE ',/10X,'REMOVE THE KEY-WORD \""
"FORCE\".')", 0 };
static cilist io___23 = { 0, 6, 0, "(//10X,'NO RESTART FILE EXISTS!')", 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 */
/* *********************************************************************** */
/* FORSAV SAVES AND RESTORES DATA USED IN THE FORCE CALCULATION. */
/* ON INPUT TIME = TOTAL TIME ELAPSED SINCE THE START OF THE CALCULATION. */
/* IPT = LINE OF FORCE MATRIX REACHED, IF IN WRITE MODE, */
/* = 0 IF IN READ MODE. */
/* FMATRX = FORCE MATRIX */
/* *********************************************************************** */
/* Parameter adjustments */
--fconst;
--evecs;
--coord;
--fmatrx;
deldip -= 4;
/* Function Body */
o__1.oerr = 0;
o__1.ounit = 9;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, "FOR009", (ftnlen)6);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = "UNFORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 9;
f_rew(&al__1);
o__1.oerr = 0;
o__1.ounit = 10;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, "FOR010", (ftnlen)6);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = "UNFORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 10;
f_rew(&al__1);
ir = 9;
iw = 9;
if (*ipt == 0) {
/* READ IN FORCE DATA */
io___3.ciunit = ir;
i__1 = s_rsue(&io___3);
if (i__1 != 0) {
goto L20;
}
i__1 = do_uio(&c__1, (char *)&(*time), (ftnlen)sizeof(doublereal));
if (i__1 != 0) {
goto L20;
}
i__1 = do_uio(&c__1, (char *)&(*ipt), (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L20;
}
i__1 = do_uio(&c__1, (char *)&(*refh), (ftnlen)sizeof(doublereal));
if (i__1 != 0) {
goto L20;
}
i__1 = e_rsue();
if (i__1 != 0) {
goto L20;
}
linear = *nvar * (*nvar + 1) / 2;
io___5.ciunit = ir;
s_rsue(&io___5);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&coord[i__], (ftnlen)sizeof(doublereal));
}
e_rsue();
io___7.ciunit = ir;
i__1 = s_rsue(&io___7);
if (i__1 != 0) {
goto L10;
}
i__2 = linear;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = do_uio(&c__1, (char *)&fmatrx[i__], (ftnlen)sizeof(
doublereal));
if (i__1 != 0) {
goto L10;
}
}
i__1 = e_rsue();
if (i__1 != 0) {
goto L10;
}
io___8.ciunit = ir;
s_rsue(&io___8);
i__1 = *ipt;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
do_uio(&c__1, (char *)&deldip[j + i__ * 3], (ftnlen)sizeof(
doublereal));
}
}
e_rsue();
n33 = *nvar * *nvar;
io___11.ciunit = ir;
s_rsue(&io___11);
i__1 = n33;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&evecs[i__], (ftnlen)sizeof(doublereal));
}
e_rsue();
io___12.ciunit = ir;
s_rsue(&io___12);
do_uio(&c__1, (char *)&(*jstart), (ftnlen)sizeof(integer));
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&fconst[i__], (ftnlen)sizeof(doublereal));
}
e_rsue();
return 0;
} else {
/* WRITE FORCE DATA */
al__1.aerr = 0;
al__1.aunit = iw;
f_rew(&al__1);
if (*time > 1e6) {
*time += -1e6;
}
io___13.ciunit = iw;
s_wsue(&io___13);
do_uio(&c__1, (char *)&(*time), (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&(*ipt), (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&(*refh), (ftnlen)sizeof(doublereal));
e_wsue();
linear = *nvar * (*nvar + 1) / 2;
io___14.ciunit = iw;
s_wsue(&io___14);
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&coord[i__], (ftnlen)sizeof(doublereal));
}
e_wsue();
io___15.ciunit = iw;
s_wsue(&io___15);
i__1 = linear;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&fmatrx[i__], (ftnlen)sizeof(doublereal));
}
e_wsue();
io___16.ciunit = iw;
s_wsue(&io___16);
i__1 = *ipt;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
do_uio(&c__1, (char *)&deldip[j + i__ * 3], (ftnlen)sizeof(
doublereal));
}
}
e_wsue();
n33 = *nvar * *nvar;
io___17.ciunit = ir;
s_wsue(&io___17);
i__1 = n33;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&evecs[i__], (ftnlen)sizeof(doublereal));
}
e_wsue();
io___18.ciunit = ir;
s_wsue(&io___18);
do_uio(&c__1, (char *)&(*jstart), (ftnlen)sizeof(integer));
i__1 = *nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&fconst[i__], (ftnlen)sizeof(doublereal));
}
e_wsue();
linear = molkst_1.norbs * (molkst_1.norbs + 1) / 2;
s_wsue(&io___19);
i__1 = linear;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&densty_1.pa[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsue();
if (molkst_1.nalpha != 0) {
s_wsue(&io___20);
i__1 = linear;
for (i__ = 1; i__ <= i__1; ++i__) {
do_uio(&c__1, (char *)&densty_1.pb[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsue();
}
cl__1.cerr = 0;
cl__1.cunit = 9;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = 10;
cl__1.csta = 0;
f_clos(&cl__1);
}
return 0;
L10:
s_wsfe(&io___21);
e_wsfe();
s_wsfe(&io___22);
e_wsfe();
s_stop("", (ftnlen)0);
L20:
s_wsfe(&io___23);
e_wsfe();
s_stop("", (ftnlen)0);
return 0;
} /* forsav_ */
