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)); }