void
rka (void)
{
bool gdval = true; /* good value to print ? */
int overtime = 1;
double prevstep = 0.0;
double t;
for (it = 0, t = tstart; T_LT_TSTOP || overtime--; )
{
symtab->sy_value = symtab->sy_val[0] = t;
field();
for (fsp = dqueue; fsp != NULL; fsp = fsp->sy_link)
{
fsp->sy_val[0] = fsp->sy_value;
fsp->sy_pri[0] = fsp->sy_prime;
}
if (gdval)
printq(); /* output */
if (tstep * (t+tstep-tstop) > 0)
tstep = tstop - t;
for (fsp = dqueue; fsp != NULL; fsp = fsp->sy_link)
{
fsp->sy_k[0] = tstep * fsp->sy_prime;
fsp->sy_value = fsp->sy_val[0]
+ C20 * fsp->sy_k[0];
}
symtab->sy_value = t + C2t * tstep;
field();
for (fsp = dqueue; fsp != NULL; fsp = fsp->sy_link)
{
fsp->sy_k[1] = tstep * fsp->sy_prime;
fsp->sy_value = fsp->sy_val[0]
+ (C30 * fsp->sy_k[0]
+ C31 * fsp->sy_k[1]);
}
symtab->sy_value = t + C3t * tstep;
field();
for (fsp = dqueue; fsp != NULL; fsp = fsp->sy_link)
{
fsp->sy_k[2] = tstep * fsp->sy_prime;
fsp->sy_value = fsp->sy_val[0]
+ (C40 * fsp->sy_k[0]
+ C41 * fsp->sy_k[1]
+ C42 * fsp->sy_k[2]);
}
symtab->sy_value = t + C4t * tstep;
field();
for (fsp = dqueue; fsp != NULL; fsp = fsp->sy_link)
{
fsp->sy_k[3] = tstep * fsp->sy_prime;
fsp->sy_value = fsp->sy_val[0]
+ (C50 * fsp->sy_k[0]
+ C51 * fsp->sy_k[1]
+ C52 * fsp->sy_k[2]
+ C53 * fsp->sy_k[3]);
}
symtab->sy_value = t + tstep;
field();
for (fsp = dqueue; fsp != NULL; fsp = fsp->sy_link)
{
fsp->sy_k[4] = tstep * fsp->sy_prime;
fsp->sy_value = fsp->sy_val[0]
+ (C60 * fsp->sy_k[0]
+ C61 * fsp->sy_k[1]
+ C62 * fsp->sy_k[2]
+ C63 * fsp->sy_k[3]
+ C64 * fsp->sy_k[4]);
}
symtab->sy_value = t + C6t * tstep;
field();
for (fsp = dqueue; fsp != NULL; fsp = fsp->sy_link)
fsp->sy_k[5] = tstep * fsp->sy_prime;
for (fsp = dqueue; fsp != NULL; fsp = fsp->sy_link)
{
fsp->sy_predi = fsp->sy_val[0]
+ (A0 * fsp->sy_k[0]
+ A2 * fsp->sy_k[2]
+ A3 * fsp->sy_k[3]
+ A4 * fsp->sy_k[4]);
fsp->sy_value = fsp->sy_val[0]
+ (B0 * fsp->sy_k[0]
+ B2 * fsp->sy_k[2]
+ B3 * fsp->sy_k[3]
+ B4 * fsp->sy_k[4]
+ B5 * fsp->sy_k[5]);
if (fsp->sy_value != 0.0)
fsp->sy_sserr = fabs(1.0 - fsp->sy_predi / fsp->sy_value);
fsp->sy_aberr = fabs(fsp->sy_value - fsp->sy_predi);
}
if (!conflag && T_LT_TSTOP)
{
maxerr();
if (hierror())
{
tstep *= HALF;
for (fsp = dqueue; fsp != NULL; fsp = fsp->sy_link)
fsp->sy_value = fsp->sy_val[0];
gdval = false;
continue;
}
else
if (lowerror() && prevstep != tstep)
{
prevstep = tstep; /* prevent infinite loops */
tstep *= TWO;
for (fsp = dqueue; fsp != NULL; fsp = fsp->sy_link)
fsp->sy_value = fsp->sy_val[0];
gdval = false;
continue;
}
}
gdval = true;
prevstep = 0.0;
++it;
t += tstep; /* the roundoff error is gross */
}
}
void rk_auto(
/* integers */
int fsal, int neq, int stage,
int isDll, int isForcing, int verbose,
int nknots, int interpolate, int densetype, int maxsteps, int nt,
/* int pointers */
int* _iknots, int* _it, int* _it_ext, int* _it_tot, int* _it_rej,
int* istate, int* ipar,
/* double */
double t, double tmax, double hmin, double hmax,
double alpha, double beta,
/* double pointers */
double* _dt, double* _errold,
/* arrays */
double* tt, double* y0, double* y1, double* y2, double* dy1, double* dy2,
double* f, double* y, double* Fj, double* tmp,
double* FF, double* rr, double* A, double* out,
double* bb1, double* bb2, double* cc, double* dd,
double* atol, double* rtol, double* yknots, double* yout,
/* SEXPs */
SEXP Func, SEXP Parms, SEXP Rho
)
{
int i = 0, j = 0, j1 = 0, k = 0, accept = FALSE, nreject = *_it_rej, one = 1;
int iknots = *_iknots, it = *_it, it_ext = *_it_ext, it_tot = *_it_tot;
double err, dtnew, t_ext;
double dt = *_dt, errold = *_errold;
/* todo: make this user adjustable */
static const double minscale = 0.2, maxscale = 10.0, safe = 0.9;
/*------------------------------------------------------------------------*/
/* Main Loop */
/*------------------------------------------------------------------------*/
do {
if (accept) timesteps[0] = timesteps[1];
timesteps[1] = dt;
/* save former results of last step if the method allows this
(first same as last) */
/* Karline: improve by saving "accepted" FF, use this when rejected */
if (fsal && accept){
j1 = 1;
for (i = 0; i < neq; i++) FF[i] = FF[i + neq * (stage - 1)];
} else {
j1 = 0;
}
/****** Prepare Coefficients from Butcher table ******/
for (j = j1; j < stage; j++) {
for(i = 0; i < neq; i++) Fj[i] = 0;
k = 0;
while(k < j) {
for(i = 0; i < neq; i++)
Fj[i] = Fj[i] + A[j + stage * k] * FF[i + neq * k] * dt;
k++;
}
for (int i = 0; i < neq; i++) {
tmp[i] = Fj[i] + y0[i];
}
/****** Compute Derivatives ******/
/* pass option to avoid unnecessary copying in derivs */
derivs(Func, t + dt * cc[j], tmp, Parms, Rho, FF, out, j, neq,
ipar, isDll, isForcing);
}
/*====================================================================*/
/* Estimation of new values */
/*====================================================================*/
/* use BLAS wrapper with reduced error checking */
blas_matprod1(FF, neq, stage, bb1, stage, one, dy1);
blas_matprod1(FF, neq, stage, bb2, stage, one, dy2);
it_tot++; /* count total number of time steps */
for (i = 0; i < neq; i++) {
y1[i] = y0[i] + dt * dy1[i];
y2[i] = y0[i] + dt * dy2[i];
}
/*====================================================================*/
/* stepsize adjustment */
/*====================================================================*/
err = maxerr(y0, y1, y2, atol, rtol, neq);
dtnew = dt;
if (err == 0) { /* use max scale if all tolerances are zero */
dtnew = fmin(dt * 10, hmax);
errold = fmax(err, 1e-4); /* 1e-4 taken from Press et al. */
accept = TRUE;
} else if (err < 1.0) {
/* increase step size only if last one was accepted */
if (accept)
dtnew = fmin(hmax, dt *
fmin(safe * pow(err, -alpha) * pow(errold, beta), maxscale));
errold = fmax(err, 1e-4); /* 1e-4 taken from Press et al. */
accept = TRUE;
} else if (err > 1.0) {
nreject++; /* count total number of rejected steps */
accept = FALSE;
dtnew = dt * fmax(safe * pow(err, -alpha), minscale);
}
if (dtnew < hmin) {
accept = TRUE;
if (verbose) Rprintf("warning, h < Hmin\n");
istate[0] = -2;
dtnew = hmin;
}
/*====================================================================*/
/* Interpolation and Data Storage */
/*====================================================================*/
if (accept) {
if (interpolate) {
/*--------------------------------------------------------------------*/
/* case A1) "dense output type 1": built-in polynomial interpolation */
/* available for certain rk formulae, e.g. for rk45dp7 */
/*--------------------------------------------------------------------*/
if (densetype == 1) {
denspar(FF, y0, y2, dt, dd, neq, stage, rr);
t_ext = tt[it_ext];
while (t_ext <= t + dt) {
densout(rr, t, t_ext, dt, tmp, neq);
/* store outputs */
if (it_ext < nt) {
yout[it_ext] = t_ext;
for (i = 0; i < neq; i++)
yout[it_ext + nt * (1 + i)] = tmp[i];
}
if(it_ext < nt-1) t_ext = tt[++it_ext]; else break;
}
/*--------------------------------------------------------------------*/
/* case A2) dense output type 2: the Cash-Karp method */
/*--------------------------------------------------------------------*/
} else if (densetype == 2) { /* dense output method 2 = Cash-Karp */
derivs(Func, t + dt, y2, Parms, Rho, dy2, out, 0, neq,
ipar, isDll, isForcing);
t_ext = tt[it_ext];
while (t_ext <= t + dt) {
densoutck(t, t_ext, dt, y0, FF, dy2, tmp, neq);
/* store outputs */
if (it_ext < nt) {
yout[it_ext] = t_ext;
for (i = 0; i < neq; i++)
yout[it_ext + nt * (1 + i)] = tmp[i];
}
if(it_ext < nt-1) t_ext = tt[++it_ext]; else break;
}
/* FSAL (first same as last) for Cash-Karp */
for (i = 0; i < neq; i++) FF[i + neq * (stage - 1)] = dy2[i] ;
/*--------------------------------------------------------------------*/
/* case B) Neville-Aitken-Interpolation for integrators */
/* without dense output */
/*--------------------------------------------------------------------*/
} else {
/* (1) collect number "nknots" of knots in advance */
yknots[iknots] = t + dt; /* time is first column */
for (i = 0; i < neq; i++) yknots[iknots + nknots * (1 + i)] = y2[i];
if (iknots < (nknots - 1)) {
iknots++;
} else {
/* (2) do polynomial interpolation */
t_ext = tt[it_ext];
while (t_ext <= t + dt) {
neville(yknots, &yknots[nknots], t_ext, tmp, nknots, neq);
/* (3) store outputs */
if (it_ext < nt) {
yout[it_ext] = t_ext;
for (i = 0; i < neq; i++)
yout[it_ext + nt * (1 + i)] = tmp[i];
}
if(it_ext < nt-1) t_ext = tt[++it_ext]; else break;
}
shiftBuffer(yknots, nknots, neq + 1);
}
}
} else {
/*--------------------------------------------------------------------*/
/* Case C) no interpolation at all (for step to step integration); */
/* results are stored after the call */
/*--------------------------------------------------------------------*/
}
/*--------------------------------------------------------------------*/
/* next time step */
/*--------------------------------------------------------------------*/
t = t + dt;
it++;
for (i=0; i < neq; i++) y0[i] = y2[i];
} /* else rejected time step */
dt = fmin(dtnew, tmax - t);
if (it_ext > nt) {
Rprintf("error in RK solver rk_auto.c: output buffer overflow\n");
break;
}
if (it_tot > maxsteps) {
istate[0] = -1;
warning("Number of time steps %i exceeded maxsteps at t = %g\n", it, t);
break;
}
/* tolerance to avoid rounding errors */
} while (t < (tmax - 100.0 * DBL_EPSILON * dt)); /* end of rk main loop */
/* return reference values */
*_iknots = iknots; *_it = it; *_it_ext = it_ext; *_it_rej = nreject;
*_it_tot = it_tot; *_dt = dtnew; *_errold = errold;
}
void rhf_loop(Molecule_t *molecule, BasisFunc_t *bfns, int M)
{
int i, n, Nelecs;
double t0;
double hfe, olde, deltap;
double diiserror;
double *H; // core Hamiltonian
double *S; // overlap
double *X; // transformation to orthonormal basis, stored by rows
double *F; // Fock matrix
double *P; // density
double *P0; // stored density from previous step
double *C; // AO coefficients in MO
double *E; // orbital energies
double *ErrM;// error matrix, e=FDS-SDF
int nbytes; // bytes in matrix to allocate
int maxiter; // max # scf iterations
int direct; // enable direct scf (1/0)
int do_diis; // is diis enabled (0/1)
int diisbas; // diis subspace dimension
int molden_out; // print vectors to molden format or not
double Enuc; // nuclei repulsion energy
DIISList_t *diislist; // list with stored Fock and error matrices
// read parameters from the rtdb
rtdb_get("scf:maxiter", &maxiter);
rtdb_get("scf:direct", &direct );
rtdb_get("scf:diis", &do_diis);
rtdb_get("scf:diisbas", &diisbas);
rtdb_get("visual:molden", &molden_out);
n = 1; // iteration number 1
t0 = MPI_Wtime();
nbytes = M * M * sizeof(double);
diislist = NULL;
Enuc = enuc(molecule);
Nelecs = nelec(molecule);
H = (double *) qalloc(nbytes);
S = (double *) qalloc(nbytes);
X = (double *) qalloc(nbytes);
F = (double *) qalloc(nbytes);
P = (double *) qalloc(nbytes);
P0= (double *) qalloc(nbytes);
C = (double *) qalloc(nbytes);
E = (double *) qalloc(M*sizeof(double));
// compute core Hamiltonian and overlap matrices
read_1e_integrals(H, S, bfns, M);
// basis orthogonalization
orthobasis(S, X, M);
// guess
rhf_guess(F, H, P, S, X, C, E, molecule, bfns, M);
olde = rhf_energy(P, F, H, M) + Enuc;
printf(" iter. Energy Delta E RMS-Dens DIIS-Err time\n");
printf("----------------------------------------------------------------------------\n");
while (1) {
if (n > maxiter) {
printf("----------------------------------------------------------------------------\n");
printf(" not converged!\n");
errquit("no convergence of SCF equations! Try to increase scf:maxiter\n");
}
memcpy(P0, P, nbytes); // store actual P
if (direct) {
// integral-direct
rhf_makefock_direct(F, H, P, bfns, M);
}
else {
// conventional scf (2e int-s from disk)
rhf_makefock(F, H, P, M);
}
// in fact, now we have Fi and Di, used to contruct this Fi
ErrM = (double *) qalloc(nbytes);
make_error_matrix(ErrM, F, P, S, M);
diiserror = maxerr(ErrM, M);
// if DIIS is enabled
if (do_diis && diisbas != 0) {
if (!diislist)
diislist = newDIISList(ErrM, F, M);
else
diis_store(diislist, ErrM, F, M, diisbas);
// extrapolate new F:
diis_extrapolate(F, diislist, diisbas);
}
diag_fock(F, X, C, E, M);
rhf_makedensity(P, C, Nelecs, M);
deltap = rmsdens(P, P0, M);
hfe = rhf_energy(P, F, H, M) + Enuc;
printf("%4d%17.8f%15.8f%15.8f%15.8f%8.2f\n", n, hfe, hfe-olde, deltap, diiserror, MPI_Wtime()-t0);
if (deltap < 1e-6)
break;
olde = hfe;
n++;
}
printf("----------------------------------------------------------------------------\n");
printf(" Total SCF energy =%15.8f\n", hfe);
printf(" Nuclear repulsion energy =%15.8f\n", Enuc);
printf("\n\n");
/* save results to rtdb */
rtdb_set("scf:etot", "%d", hfe);
rtdb_set("scf:enuc", "%d", Enuc);
// Освобождение ресурсов, которые были заняты DIIS
if (do_diis && diislist)
removeDIISList(diislist);
// Вывод результатов
// Энергии орбиталей
printf("\n");
printf(" Molecular Orbitals Summary\n");
printf(" +-----+-----+----------------+----------+\n");
printf(" | No | Occ | Energy | Symmetry |\n");
printf(" +-----+-----+----------------+----------+\n");
for (i = 0; i < M; i++)
printf(" | %-3d | %1d | %14.8f | ? |\n", i+1, (i < Nelecs/2) ? 2 : 0, E[i]);
printf(" +-----+-----+----------------+----------+\n");
// Вывод векторов в файл в формате Molden
if (molden_out) {
int i;
int *occ = (int *) qalloc(sizeof(int) * M);
memset(occ, 0, sizeof(int) * M);
for (i = 0; i < Nelecs/2; i++)
occ[i] = 2;
vectors_molden(molecule, C, E, occ, M);
qfree(occ, sizeof(int) * M);
}
// population analysis
mulliken(molecule, bfns, P, S, M);
loewdin (molecule, bfns, P, S, M);
// properties
scf_properties_rhf(molecule, P, M);
qfree(H, nbytes);
qfree(S, nbytes);
qfree(X, nbytes);
qfree(F, nbytes);
qfree(P, nbytes);
qfree(P0,nbytes);
qfree(C, nbytes);
qfree(E, M*sizeof(double));
}
