/* Cleanup the data structures associated with recursive retrieving
(the variables above). */
void
recursive_cleanup (void)
{
if (undesirable_urls)
{
string_set_free (undesirable_urls);
undesirable_urls = NULL;
}
if (dl_file_url_map)
{
free_keys_and_values (dl_file_url_map);
hash_table_destroy (dl_file_url_map);
dl_file_url_map = NULL;
}
if (dl_url_file_map)
{
free_keys_and_values (dl_url_file_map);
hash_table_destroy (dl_url_file_map);
dl_url_file_map = NULL;
}
undesirable_urls = NULL;
free_vec (forbidden);
forbidden = NULL;
slist_free (downloaded_html_files);
downloaded_html_files = NULL;
FREE_MAYBE (base_dir);
FREE_MAYBE (robots_host);
first_time = 1;
}
void dfnmin(double p[], int n, double gtol, int itmax, int maxback,
int *iter, double *fret,
double ***hesinv,
double(*func)(double []), void (*dfunc)(double [], double []),
void (*ddfunc)(double [], double **))
{
double *g, **A, **Ainv, *xi, *pnew;
double sum,fp,fnew,lam,x;
int loop,i,j,k;
g=new_vec(n); xi=new_vec(n); pnew=new_vec(n);
A=new_mat(n,n); Ainv=new_mat(n,n);
fp=(*func)(p); /* function */
for(loop=1;loop<=itmax;loop++) {
(*dfunc)(p,g); /* derivative */
(*ddfunc)(p,A); /* second derivative */
luinverse(A,Ainv,n);
x=sym_mat(Ainv,n);
sum=0.0;
for(i=0;i<n;i++) {
x=0.0; for(j=0;j<n;j++) x+=Ainv[i][j]*g[j];
sum+=g[i]*x; xi[i] = -x;
}
if(sum>=0.0) lam=1.0; else lam=-1.0;
for(k=0;k<maxback;k++) {
for(i=0;i<n;i++) pnew[i]=p[i]+lam*xi[i];
fnew=(*func)(pnew); /* function */
mydprintf(3,"\n### dfnmin: lam=%g fnew=%g fp=%g",lam,fnew,fp);
if(fnew < fp) break;
lam *= 0.1;
}
if(k==maxback) break;
fp=fnew;
for(i=0;i<n;i++) p[i]=pnew[i];
mydprintf(3,"\n### dfnmin: loop=%d sum=%g fp=%g",loop,sum,fp);
if(sum>=0 && sum<gtol) break;
}
*fret=fp; /* function */
*iter=loop;
*hesinv=Ainv;
free_mat(A); free_vec(g); free_vec(xi); free_vec(pnew);
}
double quantile (const VEC v, const double q){
assert(NULL!=v);
assert(q>=0. && q<=1.);
VEC vcopy = copy_vec(v);
qsort (vcopy->x,vlen(vcopy),sizeof(double),CmpDouble);
const double med = quantile_fromsorted(vcopy,q);
free_vec(vcopy);
return med;
}
ProgramInfoCache::~ProgramInfoCache()
{
QMutexLocker locker(&m_lock);
while (m_loads_in_progress)
m_load_wait.wait(&m_lock);
Clear();
free_vec(m_next_cache);
}
/* Some unnecessary vector copies when this function is combined with median */
double mad ( const VEC v){
assert(NULL!=v);
const double vmedian = median(v);
VEC vcopy = copy_vec (v);
const unsigned int len = vlen(vcopy);
for ( unsigned int i=0 ; i<len ; i++){
vset(vcopy,i,fabs(vget(vcopy,i)-vmedian));
}
const double devmedian = median(vcopy);
free_vec(vcopy);
return devmedian * MADSCALE;
}
/* Cleanup the data structures associated with recursive retrieving
(the variables above). */
void
recursive_cleanup (void)
{
free_slist (ulist);
ulist = NULL;
free_vec (forbidden);
forbidden = NULL;
free_slist (urls_html);
urls_html = NULL;
free_urlpos (urls_downloaded);
urls_downloaded = NULL;
FREE_MAYBE (base_dir);
FREE_MAYBE (robots_host);
first_time = 1;
}
VEC quantiles ( const VEC v, const VEC q){
assert(NULL!=q);
assert(NULL!=v);
VEC quant = create_vec(vlen(q));
assert(NULL!=quant);
VEC vcopy = copy_vec(v);
qsort (vcopy->x,vlen(vcopy),sizeof(double),CmpDouble);
for ( unsigned int i=0; i<vlen(q) ; i++){
assert(vget(q,i)>=0. && vget(q,i)<=1.);
vset(quant,i,quantile_fromsorted(vcopy,vget(q,i)));
}
free_vec(vcopy);
return quant;
}
int
main(int argc, char* argv[])
{
int i, n, status;
nlp_float *x;
function_object func_obj;
linesearch_parameter ls_parameter;
lbfgs_parameter parameter;
n = 10;
x = (nlp_float *)malloc_vec(n * sizeof(nlp_float));
for (i = 0; i < n; ++i)
x[i] = 1.;
func_obj.func = func;
func_obj.grad = grad;
default_lbfgs_parameter(¶meter);
default_linesearch_parameter(&ls_parameter);
status = lbfgs(
x,
n,
&func_obj,
&ls_parameter,
¶meter
);
if (LBFGS_SATISFIED == status)
{
printf("\n=== Optimal x =========================================\n");
for (i = 0; i < n; ++i)
printf(" x_%-8d = %12.6e\n", i + 1 , x[i]);
printf("=======================================================\n");
}
free_vec(x);
return 0;
}
void ProgramInfoCache::Load(const bool updateUI)
{
QMutexLocker locker(&m_lock);
m_load_is_queued = false;
locker.unlock();
/**/
// Get an unsorted list (sort = 0) from RemoteGetRecordedList
// we sort the list later anyway.
vector<ProgramInfo*> *tmp = RemoteGetRecordedList(0);
/**/
locker.relock();
free_vec(m_next_cache);
m_next_cache = tmp;
if (updateUI)
QCoreApplication::postEvent(
m_listener, new MythEvent("UPDATE_UI_LIST"));
m_loads_in_progress--;
m_load_wait.wakeAll();
}
int genrmt(char *infile, char *outfile)
{
int i,j;
FILE *fp;
double x,t0,t1;
char *cbuf,*fext;
/* open file */
switch(seqmode) {
case SEQ_MOLPHY: fext=fext_molphy; break;
case SEQ_PAML: fext=fext_paml; break;
case SEQ_PAUP: fext=fext_paup; break;
case SEQ_PUZZLE: fext=fext_puzzle; break;
case SEQ_PHYML: fext=fext_phyml; break;
case SEQ_MT:
default: fext=fext_mt; break;
}
if(infile) {
fp=openfp(infile,fext,"r",&cbuf);
printf("\n# reading %s",cbuf);
} else {
fp=STDIN;
printf("\n# reading from stdin");
}
/* read file */
mm=nn=0;
switch(seqmode) {
case SEQ_MOLPHY:
datmat = fread_mat_lls(fp, &mm, &nn); break;
case SEQ_PAML:
datmat = fread_mat_lfh(fp, &mm, &nn); break;
case SEQ_PAUP:
datmat = fread_mat_paup(fp, &mm, &nn); break;
case SEQ_PUZZLE:
datmat = fread_mat_puzzle(fp, &mm, &nn); break;
case SEQ_PHYML:
datmat = fread_mat_phyml(fp, &mm, &nn); break;
case SEQ_MT:
default:
datmat = fread_mat(fp, &mm, &nn); break;
}
if(infile) {fclose(fp); FREE(cbuf);}
printf("\n# M:%d N:%d",mm,nn);
/* allocating buffers */
datvec=new_vec(mm);
bn=new_ivec(kk); rr1=new_vec(kk);
/* calculate the log-likelihoods */
for(i=0;i<mm;i++) {
x=0; for(j=0;j<nn;j++) x+=datmat[i][j];
datvec[i]=x;
}
/* calculate scales */
for(i=0;i<kk;i++) {
bn[i]=(int)(rr[i]*nn); /* sample size for bootstrap */
rr1[i]=(double)bn[i]/nn; /* recalculate rr for integer adjustment */
}
/* open out file */
if(outfile) {
/* vt ascii write to file */
fp=openfp(outfile,fext_vt,"w",&cbuf);
printf("\n# writing %s",cbuf);
fwrite_vec(fp,datvec,mm);
fclose(fp); FREE(cbuf);
/* rmt binary write to file */
fp=openfp(outfile,fext_rmt,"wb",&cbuf);
printf("\n# writing %s",cbuf);
fwrite_bvec(fp,datvec,mm);
fwrite_bvec(fp,rr1,kk);
fwrite_bivec(fp,bb,kk);
fwrite_bi(fp,kk);
} else {
/* rmt ascii write to stdout */
printf("\n# writing to stdout");
printf("\n# OBS:\n"); write_vec(datvec,mm);
printf("\n# R:\n"); write_vec(rr1,kk);
printf("\n# B:\n"); write_ivec(bb,kk);
printf("\n# RMAT:\n");
printf("%d\n",kk);
}
/* generating the replicates by resampling*/
for(i=j=0;i<kk;i++) j+=bb[i];
printf("\n# start generating total %d replicates for %d items",j,mm);
fflush(STDOUT);
t0=get_time();
for(i=0;i<kk;i++) {
repmat=new_lmat(mm,bb[i]);
scaleboot(datmat,repmat,mm,nn,bn[i],bb[i]);
if(outfile) {
fwrite_bmat(fp,repmat,mm,bb[i]);
putdot();
} else {
printf("\n## RMAT[%d]:\n",i); write_mat(repmat,mm,bb[i]);
}
free_lmat(repmat,mm);
}
t1=get_time();
printf("\n# time elapsed for bootstrap t=%g sec",t1-t0);
if(outfile) {
fclose(fp); FREE(cbuf);
}
/* freeing buffers */
free_vec(bn); free_vec(rr1); free_vec(datvec); free_mat(datmat);
return 0;
}
void free_summary ( struct summary * s){
assert(NULL!=s);
free_vec(s->quantiles);
free_vec(s->data);
free(s);
}
int main(int argc, char** argv)
{
/* working variables */
int i,j,ifile,nfile,cm,w,w2;
FILE *fp;
char *cbuf;
double *alphavec=NULL;
double **cimat=NULL, **semat=NULL, **eimat=NULL;
double **ci0mat=NULL, **se0mat=NULL, **ei0mat=NULL;
int nalpha;
int *orderv; double *obsvec; /* auxiliary info */
char **fnamev;
fnamev=NEW_A(argc-1,char*);
nfile=0;
/* args */
for(i=1;i<argc;i++) {
if(argv[i][0] != '-') {
fnamev[nfile]=argv[i];
nfile++;
} else if(streq(argv[i],"-d")) {
if(i+1>=argc ||
sscanf(argv[i+1],"%d",&debugmode) != 1)
byebye();
i+=1;
} else if(streq(argv[i],"-v")) {
sw_verpose=1;
} else if(streq(argv[i],"--no_au")) {
sw_au=0;
} else if(streq(argv[i],"--no_np")) {
sw_bp=0;
} else byebye();
}
for(ifile=0;ifile<nfile;ifile++) {
fp=openfp(fnamev[ifile],fext_ci,"r",&cbuf);
printf("\n# reading %s",cbuf);
cm=nalpha=0;
orderv=fread_ivec(fp,&cm); obsvec=fread_vec(fp,&cm);
alphavec=fread_vec(fp,&nalpha);
cimat=fread_mat(fp,&cm,&nalpha);
semat=fread_mat(fp,&cm,&nalpha);
eimat=fread_mat(fp,&cm,&nalpha);
ci0mat=fread_mat(fp,&cm,&nalpha);
se0mat=fread_mat(fp,&cm,&nalpha);
ei0mat=fread_mat(fp,&cm,&nalpha);
fclose(fp);
printf("\n#"); repchar(' ',17);
w=nalpha*(sw_verpose?17:7);
w2=w/2-2;
if(sw_au) {
repchar('-',w2); printf(" au "); repchar('-',w-w2-4);
}
printf(" |");
if(sw_bp) {
repchar('-',w2); printf(" np "); repchar('-',w-w2-4);
}
printf("\n# %4s %4s","rank","item");
printf(" %6s","obs");
if(sw_au) {
for(j=0;j<nalpha;j++) {
printf(" %6.3f",alphavec[j]);
if(sw_verpose) printf(" %4s %4s","se","ei");
}
}
printf(" |");
if(sw_bp) {
for(j=0;j<nalpha;j++) {
printf(" %6.3f",alphavec[j]);
if(sw_verpose) printf(" %4s %4s","se","ei");
}
}
for(i=0;i<cm;i++) {
printf("\n# %4d %4d",i+1,orderv[i]+1);
printf(" %6.1f",obsvec[i]);
if(sw_au){
for(j=0;j<nalpha;j++) {
printf(" %6.1f",cimat[i][j]);
if(sw_verpose) printf(" %4.1f %4.1f",semat[i][j],eimat[i][j]);
}
}
printf(" |");
if(sw_bp){
for(j=0;j<nalpha;j++) {
printf(" %6.1f",ci0mat[i][j]);
if(sw_verpose) printf(" %4.1f %4.1f",se0mat[i][j],ei0mat[i][j]);
}
}
}
printf("\n");
free_vec(alphavec);
free_mat(cimat); free_mat(semat); free_mat(eimat);
free_mat(ci0mat); free_mat(se0mat); free_mat(ei0mat);
free_ivec(orderv); free_vec(obsvec);
}
return 0;
}
/* The core of recursive retrieving. Endless recursion is avoided by
having all URLs stored to a linked list of URLs, which is checked
before loading any URL. That way no URL can get loaded twice.
The function also supports specification of maximum recursion depth
and a number of other goodies. */
uerr_t
recursive_retrieve (const char *file, const char *this_url)
{
char *constr, *filename, *newloc;
char *canon_this_url = NULL;
int dt, inl, dash_p_leaf_HTML = FALSE;
int meta_disallow_follow;
int this_url_ftp; /* See below the explanation */
uerr_t err;
struct urlinfo *rurl;
urlpos *url_list, *cur_url;
char *rfile; /* For robots */
struct urlinfo *u;
assert (this_url != NULL);
assert (file != NULL);
/* If quota was exceeded earlier, bail out. */
if (downloaded_exceeds_quota ())
return QUOTEXC;
/* Cache the current URL in the list. */
if (first_time)
{
/* These three operations need to be done only once per Wget
run. They should probably be at a different location. */
if (!undesirable_urls)
undesirable_urls = make_string_hash_table (0);
hash_table_clear (undesirable_urls);
string_set_add (undesirable_urls, this_url);
/* Enter this_url to the hash table, in original and "enhanced" form. */
u = newurl ();
err = parseurl (this_url, u, 0);
if (err == URLOK)
{
string_set_add (undesirable_urls, u->url);
if (opt.no_parent)
base_dir = xstrdup (u->dir); /* Set the base dir. */
/* Set the canonical this_url to be sent as referer. This
problem exists only when running the first time. */
canon_this_url = xstrdup (u->url);
}
else
{
DEBUGP (("Double yuck! The *base* URL is broken.\n"));
base_dir = NULL;
}
freeurl (u, 1);
depth = 1;
robots_host = NULL;
forbidden = NULL;
first_time = 0;
}
else
++depth;
if (opt.reclevel != INFINITE_RECURSION && depth > opt.reclevel)
/* We've exceeded the maximum recursion depth specified by the user. */
{
if (opt.page_requisites && depth <= opt.reclevel + 1)
/* When -p is specified, we can do one more partial recursion from the
"leaf nodes" on the HTML document tree. The recursion is partial in
that we won't traverse any <A> or <AREA> tags, nor any <LINK> tags
except for <LINK REL="stylesheet">. */
dash_p_leaf_HTML = TRUE;
else
/* Either -p wasn't specified or it was and we've already gone the one
extra (pseudo-)level that it affords us, so we need to bail out. */
{
DEBUGP (("Recursion depth %d exceeded max. depth %d.\n",
depth, opt.reclevel));
--depth;
return RECLEVELEXC;
}
}
/* Determine whether this_url is an FTP URL. If it is, it means
that the retrieval is done through proxy. In that case, FTP
links will be followed by default and recursion will not be
turned off when following them. */
this_url_ftp = (urlproto (this_url) == URLFTP);
/* Get the URL-s from an HTML file: */
url_list = get_urls_html (file, canon_this_url ? canon_this_url : this_url,
dash_p_leaf_HTML, &meta_disallow_follow);
if (opt.use_robots && meta_disallow_follow)
{
/* The META tag says we are not to follow this file. Respect
that. */
free_urlpos (url_list);
url_list = NULL;
}
/* Decide what to do with each of the URLs. A URL will be loaded if
it meets several requirements, discussed later. */
for (cur_url = url_list; cur_url; cur_url = cur_url->next)
{
/* If quota was exceeded earlier, bail out. */
if (downloaded_exceeds_quota ())
break;
/* Parse the URL for convenient use in other functions, as well
as to get the optimized form. It also checks URL integrity. */
u = newurl ();
if (parseurl (cur_url->url, u, 0) != URLOK)
{
DEBUGP (("Yuck! A bad URL.\n"));
freeurl (u, 1);
continue;
}
if (u->proto == URLFILE)
{
DEBUGP (("Nothing to do with file:// around here.\n"));
freeurl (u, 1);
continue;
}
assert (u->url != NULL);
constr = xstrdup (u->url);
/* Several checkings whether a file is acceptable to load:
1. check if URL is ftp, and we don't load it
2. check for relative links (if relative_only is set)
3. check for domain
4. check for no-parent
5. check for excludes && includes
6. check for suffix
7. check for same host (if spanhost is unset), with possible
gethostbyname baggage
8. check for robots.txt
Addendum: If the URL is FTP, and it is to be loaded, only the
domain and suffix settings are "stronger".
Note that .html and (yuck) .htm will get loaded regardless of
suffix rules (but that is remedied later with unlink) unless
the depth equals the maximum depth.
More time- and memory- consuming tests should be put later on
the list. */
/* inl is set if the URL we are working on (constr) is stored in
undesirable_urls. Using it is crucial to avoid unnecessary
repeated continuous hits to the hash table. */
inl = string_set_contains (undesirable_urls, constr);
/* If it is FTP, and FTP is not followed, chuck it out. */
if (!inl)
if (u->proto == URLFTP && !opt.follow_ftp && !this_url_ftp)
{
DEBUGP (("Uh, it is FTP but i'm not in the mood to follow FTP.\n"));
string_set_add (undesirable_urls, constr);
inl = 1;
}
/* If it is absolute link and they are not followed, chuck it
out. */
if (!inl && u->proto != URLFTP)
if (opt.relative_only && !cur_url->link_relative_p)
{
DEBUGP (("It doesn't really look like a relative link.\n"));
string_set_add (undesirable_urls, constr);
inl = 1;
}
/* If its domain is not to be accepted/looked-up, chuck it out. */
if (!inl)
if (!accept_domain (u))
{
DEBUGP (("I don't like the smell of that domain.\n"));
string_set_add (undesirable_urls, constr);
inl = 1;
}
/* Check for parent directory. */
if (!inl && opt.no_parent
/* If the new URL is FTP and the old was not, ignore
opt.no_parent. */
&& !(!this_url_ftp && u->proto == URLFTP))
{
/* Check for base_dir first. */
if (!(base_dir && frontcmp (base_dir, u->dir)))
{
/* Failing that, check for parent dir. */
struct urlinfo *ut = newurl ();
if (parseurl (this_url, ut, 0) != URLOK)
DEBUGP (("Double yuck! The *base* URL is broken.\n"));
else if (!frontcmp (ut->dir, u->dir))
{
/* Failing that too, kill the URL. */
DEBUGP (("Trying to escape parental guidance with no_parent on.\n"));
string_set_add (undesirable_urls, constr);
inl = 1;
}
freeurl (ut, 1);
}
}
/* If the file does not match the acceptance list, or is on the
rejection list, chuck it out. The same goes for the
directory exclude- and include- lists. */
if (!inl && (opt.includes || opt.excludes))
{
if (!accdir (u->dir, ALLABS))
{
DEBUGP (("%s (%s) is excluded/not-included.\n", constr, u->dir));
string_set_add (undesirable_urls, constr);
inl = 1;
}
}
if (!inl)
{
char *suf = NULL;
/* We check for acceptance/rejection rules only for non-HTML
documents. Since we don't know whether they really are
HTML, it will be deduced from (an OR-ed list):
1) u->file is "" (meaning it is a directory)
2) suffix exists, AND:
a) it is "html", OR
b) it is "htm"
If the file *is* supposed to be HTML, it will *not* be
subject to acc/rej rules, unless a finite maximum depth has
been specified and the current depth is the maximum depth. */
if (!
(!*u->file
|| (((suf = suffix (constr)) != NULL)
&& ((!strcmp (suf, "html") || !strcmp (suf, "htm"))
&& ((opt.reclevel != INFINITE_RECURSION) &&
(depth != opt.reclevel))))))
{
if (!acceptable (u->file))
{
DEBUGP (("%s (%s) does not match acc/rej rules.\n",
constr, u->file));
string_set_add (undesirable_urls, constr);
inl = 1;
}
}
FREE_MAYBE (suf);
}
/* Optimize the URL (which includes possible DNS lookup) only
after all other possibilities have been exhausted. */
if (!inl)
{
if (!opt.simple_check)
opt_url (u);
else
{
char *p;
/* Just lowercase the hostname. */
for (p = u->host; *p; p++)
*p = TOLOWER (*p);
xfree (u->url);
u->url = str_url (u, 0);
}
xfree (constr);
constr = xstrdup (u->url);
string_set_add (undesirable_urls, constr);
if (!inl && !((u->proto == URLFTP) && !this_url_ftp))
if (!opt.spanhost && this_url && !same_host (this_url, constr))
{
DEBUGP (("This is not the same hostname as the parent's.\n"));
string_set_add (undesirable_urls, constr);
inl = 1;
}
}
/* What about robots.txt? */
if (!inl && opt.use_robots && u->proto == URLHTTP)
{
/* Since Wget knows about only one set of robot rules at a
time, /robots.txt must be reloaded whenever a new host is
accessed.
robots_host holds the host the current `forbid' variable
is assigned to. */
if (!robots_host || !same_host (robots_host, u->host))
{
FREE_MAYBE (robots_host);
/* Now make robots_host the new host, no matter what the
result will be. So if there is no /robots.txt on the
site, Wget will not retry getting robots all the
time. */
robots_host = xstrdup (u->host);
free_vec (forbidden);
forbidden = NULL;
err = retrieve_robots (constr, ROBOTS_FILENAME);
if (err == ROBOTSOK)
{
rurl = robots_url (constr, ROBOTS_FILENAME);
rfile = url_filename (rurl);
forbidden = parse_robots (rfile);
freeurl (rurl, 1);
xfree (rfile);
}
}
/* Now that we have (or don't have) robots, we can check for
them. */
if (!robots_match (u, forbidden))
{
DEBUGP (("Stuffing %s because %s forbids it.\n", this_url,
ROBOTS_FILENAME));
string_set_add (undesirable_urls, constr);
inl = 1;
}
}
filename = NULL;
/* If it wasn't chucked out, do something with it. */
if (!inl)
{
DEBUGP (("I've decided to load it -> "));
/* Add it to the list of already-loaded URL-s. */
string_set_add (undesirable_urls, constr);
/* Automatically followed FTPs will *not* be downloaded
recursively. */
if (u->proto == URLFTP)
{
/* Don't you adore side-effects? */
opt.recursive = 0;
}
/* Reset its type. */
dt = 0;
/* Retrieve it. */
retrieve_url (constr, &filename, &newloc,
canon_this_url ? canon_this_url : this_url, &dt);
if (u->proto == URLFTP)
{
/* Restore... */
opt.recursive = 1;
}
if (newloc)
{
xfree (constr);
constr = newloc;
}
/* If there was no error, and the type is text/html, parse
it recursively. */
if (dt & TEXTHTML)
{
if (dt & RETROKF)
recursive_retrieve (filename, constr);
}
else
DEBUGP (("%s is not text/html so we don't chase.\n",
filename ? filename: "(null)"));
if (opt.delete_after || (filename && !acceptable (filename)))
/* Either --delete-after was specified, or we loaded this otherwise
rejected (e.g. by -R) HTML file just so we could harvest its
hyperlinks -- in either case, delete the local file. */
{
DEBUGP (("Removing file due to %s in recursive_retrieve():\n",
opt.delete_after ? "--delete-after" :
"recursive rejection criteria"));
logprintf (LOG_VERBOSE,
(opt.delete_after ? _("Removing %s.\n")
: _("Removing %s since it should be rejected.\n")),
filename);
if (unlink (filename))
logprintf (LOG_NOTQUIET, "unlink: %s\n", strerror (errno));
dt &= ~RETROKF;
}
/* If everything was OK, and links are to be converted, let's
store the local filename. */
if (opt.convert_links && (dt & RETROKF) && (filename != NULL))
{
cur_url->convert = CO_CONVERT_TO_RELATIVE;
cur_url->local_name = xstrdup (filename);
}
}
else
DEBUGP (("%s already in list, so we don't load.\n", constr));
/* Free filename and constr. */
FREE_MAYBE (filename);
FREE_MAYBE (constr);
freeurl (u, 1);
/* Increment the pbuf for the appropriate size. */
}
if (opt.convert_links && !opt.delete_after)
/* This is merely the first pass: the links that have been
successfully downloaded are converted. In the second pass,
convert_all_links() will also convert those links that have NOT
been downloaded to their canonical form. */
convert_links (file, url_list);
/* Free the linked list of URL-s. */
free_urlpos (url_list);
/* Free the canonical this_url. */
FREE_MAYBE (canon_this_url);
/* Decrement the recursion depth. */
--depth;
if (downloaded_exceeds_quota ())
return QUOTEXC;
else
return RETROK;
}
static int eig_driver(char which[], char bmat[], int iparam[], int mode,
double sigma, double mu, double delta, double zeta, int nev, int ncv,
int info, double tol, double eta, int printproc, int numOwnedUnks,
int numUnks, int con_step_num, int jmax, int sort, MPI_Comm comm)
/* matShifted is temp matrix, nnz is # nonzeros in matrix */
{
int j, kk, ldv, lworkl;
int nloc, nloc_max, nloc2, ido, flag;
int count, nconv=0, ierr;
int ipntr[14];
int dummy1, dummy2, dummy3, dummy4;
double *rhs_orig;
double norm_M;
char string[4];
int az_fail_cnt=0;
double *v, *workl, *workd, *workev, *d, *resid, *vecx, *vecy, *rhs, *mxx;
int *select, rvec, *work;
extern void sort2_double(int, double *);
/* variables for ido=4 loop */
double *trans=NULL; /* space for eigenvalues transformed to real system */
double *workpol=NULL; /*space for eigenvales transformed in poleze*/
double new_sigma=0.0, new_mu = 0.0, solve_tol;
int temp_ncv=0, temp_nconv=0, info_p=0, nrows=nev;
/******************************************************
* A standard eigenvalue problem is solved (BMAT = 'I').
* NEV is the number of eigenvalues to be approximated.
* NCV is the number of Krylov vectors kept. WHICH
* determine what part of the spectrum is obtained.
* The following conditions must be satisfied:
* N <= MAXN,
* NEV <= MAXNEV,
* NEV + 2 <= NCV <= MAXNCV
*
******************************************************/
nloc = numOwnedUnks;
ldv = nloc;
/******************************************************
* The work array WORKL is used in P??AUPD as
* workspace. Its dimension LWORKL is set as
* illustrated below. The parameter TOL determines
* the stopping criterion. If TOL<=0, machine
* precision is used. The variable IDO is used for
* reverse communication and is initially set to 0.
* Setting INFO=0 indicates that a random vector is
* generated in PNAUPD to start the Arnoldi iteration.
******************************************************/
lworkl = 3*ncv*(ncv+2);
ido = 0;
/******************************************************
* Use exact shifts with respect to the current Hessenberg
* matrix (iparam[SHIFTS] = 1) where IPARAM[MAX_ITRS] is
* the maximum number of Arnoldi iterations allowed.
* Mode 1 of P??AUPD is used (IPARAM[MODE] = 1). For
* details, see the documentation in P??AUPD.
******************************************************/
nloc2 = numUnks;
nloc_max = gmax_int_conwrap(nloc2);
select = (int *) malloc(ncv*sizeof(int));
work = (int *) malloc(ncv*sizeof(int));
vecx = (double *) malloc(nloc2*sizeof(double));
vecy = (double *) malloc(nloc2*sizeof(double));
rhs = (double *) malloc(nloc2*sizeof(double));
rhs_orig = rhs;
mxx = (double *) malloc(nloc2*sizeof(double));
d = (double *) malloc(3*ncv*sizeof(double) );
resid = (double *) malloc(nloc_max*sizeof(double) );
workd = (double *) malloc(3*nloc2*sizeof(double));
workev = (double *) malloc(3*ncv*sizeof(double));
workl = (double *) calloc(lworkl,sizeof(double));
v = (double *) malloc(ncv*ldv*sizeof(double)) ;
if (v == NULL) {
fprintf(stderr,"Not enough space to allocate workl\n");
exit(1);
}
/* Generate smart initial guess in resid vector by applying */
/* resid = Inv(J)Mx for random x (called vecx) */
info = 1;
if (printproc > 4) printf("\n\t Eigensolver Initial Guess Generation\n");
random_vector_conwrap(vecx, nloc);
/* Mx = rhs */
for (kk = 0 ; kk < nloc2 ; kk++) rhs[kk] = 0.0;
mass_matvec_mult_conwrap(vecx,rhs);
/* Inv(J)Mx = resid */
norm_M = sqrt(dp(rhs,rhs));
solve_tol = eta * norm_M / 100.0;
if (printproc > 4)
printf("\t Requiring 2 extra orders resid reduction: %g\n", solve_tol);
/* Use shifted matrix space and solver to solve usual Jacobian so that
* the Jacobian matrix doesn't get scaled
*/
shifted_matrix_fill_conwrap(0.0);
shifted_linear_solver_conwrap(rhs, vecx, NEW_JACOBIAN, solve_tol);
for (kk = 0 ; kk < nloc2 ; kk++) resid[kk] = vecx[kk];
/* main loop */
for (j = 0; j < 3*ncv ; j++ ) d[j] = 0.0; /* zero d[:] */
flag = 1;
count = 0;
while ( flag == 1 ) {
/*****************************************************
* Repeatedly call P??AUPD and take actions indicated
* by parameter IDO until either convergence is indicated
* or the maximum iterations have been exceeded.
*****************************************************/
cpdnaupc_( &comm,
&ido, bmat, &nloc, which, &nev, &tol, resid,
&ncv, v, &ldv, iparam, ipntr, workd, workl,
&lworkl, &info );
/* CGS vs. MGS tests used this
* if (printproc > 4) printf("sigma,mu = 10,50, stopping after 3\n");
* sigma = 10.0;
* mu = 50.0;
* if (count==3) exit(-1);
*/
if ( (ido == -1) || (ido == 1) ) {
count++;
if (printproc > 7) printf("\n\t Eigensolver iteration: %d",count);
/***********************************************
* matrix vector multiplication (using inverse)
* workd[ipntr[1]-1] <-- OP * workd[ipntr[0]-1]
***********************************************/
if (mode==CAYLEY) {
/* OP = inv(J-sM)(J-mM) */
/* We do the solve below, at this line rhs := (J-mM)*vecx as above */
/* for (kk = 0 ; kk < nloc ; kk++) vecx[kk] = workd[ipntr[0]+kk-1];
*/
/* rhs = Mx, norm_M = ||rhs|| */
mass_matvec_mult_conwrap(&workd[ipntr[0]-1], rhs);
norm_M = sqrt(dp(rhs,rhs));
/* rhs = -mMx */
for (kk = 0 ; kk < nloc ; kk++) rhs[kk] *= -mu;
/* vecx = Jx */
matvec_mult_conwrap(&workd[ipntr[0]-1], vecx);
/* rhs = (J-mM)x */
for (kk = 0 ; kk < nloc ; kk++) rhs[kk] += vecx[kk];
}
else if (mode==SHIFTI) {
/* OP = inv(J-sM)M */
/* rhs = Mx, norm_M = ||rhs|| */
mass_matvec_mult_conwrap(&workd[ipntr[0]-1], rhs);
norm_M = sqrt(dp(rhs,rhs));
}
else {
if (printproc > 1)
printf("eig_driver ERROR: bad value of mode! %d\n", mode);
exit(-1);
}
/* (J-sM) vecx = rhs */
for (kk = 0 ; kk < nloc ; kk++) vecx[kk] = 0.0;
if (mode == CAYLEY || mode == SHIFTI) {
/* set linear solver tolerance based on norm_M */
solve_tol = eta * norm_M;
if (printproc > 7) printf("\tLinear Solve Tol = %g\n",solve_tol);
/* After first iter, reuse preconditioner */
if (count%ncv == 1) {
shifted_matrix_fill_conwrap(sigma);
shifted_linear_solver_conwrap(rhs, vecx, NEW_JACOBIAN, solve_tol);
}
else {
shifted_linear_solver_conwrap(rhs, vecx, OLD_JACOBIAN, solve_tol);
}
}
for (kk = 0 ; kk < nloc ; kk++) workd[ipntr[1]+kk-1] = vecx[kk];
}
else if ( ido == 2) {
/* Need to fix this if this routine is called */
if (mode != -1){
if (printproc > 1)
fprintf(stderr,"\nError:dnaupd:ido=2 & mode=ord\n");
exit(-1);
}
/* rhs := workd */
for (kk = 0 ; kk < nloc ; kk++) vecx[kk] = workd[ipntr[0]+kk-1];
mass_matvec_mult_conwrap(vecx, rhs);
vec_copy(rhs, &(workd[ipntr[1]-1]));
}
else if ( ido == 3) {
/* set shifts */
for (kk = 0 ; kk < iparam[7] ; kk++) {
workl[ipntr[13] -1 + kk] = 0.0;
workl[ipntr[13] -1 + iparam[7] + kk] = 0.0;
}
workl[ipntr[13] -1 + iparam[7] - 1] = 1.0;
if (iparam[7] == ncv) {
sigma = new_sigma;
mu = new_mu ;
}
else {
if (printproc > 1)
printf("\n\tDeflation in ARPACK occured, so sigma and mu reused"
" (%g %g)\n", sigma, mu);
}
}
else if ( ido == 4) {
if (printproc > 4) {
printf("\n\tBefore poleze: sigma and mu = %g %g\n", sigma, mu);
}
temp_nconv = nev; /* How many we want converged */
new_sigma = sigma;
new_mu = mu ;
/* set aside storage space */
if (trans == NULL)
trans = (double *) malloc(3*ncv*sizeof(double));
if (workpol == NULL)
workpol = (double *) malloc(3*ncv*sizeof(double));
/*
* if sigma is less than mu, do the cayley invert and shift. if
* sigma is greater than mu, do the cayley transform
*/
if (mode==SHIFTI) {
polez3_(&ncv, &new_sigma, &new_mu, &delta, &zeta, &workl[ipntr[5] -1],
&workl[ipntr[6] -1], &workl[ipntr[7] -1], trans, trans+ncv,
trans+2*ncv, &temp_ncv, &temp_nconv, &tol, &info_p);
}
/* Cayley */
else if (sigma < mu){
poleze_(&ncv, &new_sigma, &new_mu, &workl[ipntr[5] -1],
&workl[ipntr[6] -1], &workl[ipntr[7] -1], trans, trans+ncv,
trans+2*ncv, &temp_ncv, &temp_nconv, &tol, &info_p,
workpol, workpol+ncv, workpol+2*ncv);
}
else if (sigma > mu){
polez2_(&ncv, &new_sigma, &new_mu, &delta, &workl[ipntr[5] -1],
&workl[ipntr[6] -1], &workl[ipntr[7] -1], trans, trans+ncv,
trans+2*ncv, &temp_ncv, &temp_nconv, &tol, &info_p);
}
iparam[4] = temp_nconv;
if (printproc > 4) {
printf("\tAfter poleze: sigma and mu = %g %g \n\n",
new_sigma, new_mu);
printf("\t%d converged of %d candidate eigenvalues found\n",
temp_nconv, temp_ncv);
}
if (printproc > 7) {
printf("\t Eigenvalues and error estimates in the lambda plane\n");
for (kk = 0 ; kk < temp_ncv ; kk++) {
printf("\t %2d. %g %g %g\n",kk, trans[kk],
trans[kk+ncv],trans[kk+2*ncv]);
}
if (info_p && printproc > 1) {
printf("ERROR - poleze returned info = %d\n", info_p);
if (info_p==-1) {
printf("\tEigenvalue suspected to the right of sigma\n");
printf("\tTry increasing sigma and/or improving accuracy\n");
}
else if (info_p==-2) {
printf("\tIncrease Arnoldi space size or move shift closer\n");
}
}
}
}
else flag = 0;
}
/* Either convergence or an error */
if ( info < 0 ) {
if ( printproc > 1 ) {
fprintf(stderr,"\nError with _naupd, info = %d\n",info);
fprintf(stderr,"Check documentation in _naupd.\n\n");
nconv = 0;
if ( info == -9999 ) {
fprintf(stderr,"Size of Arnoldi factorization:%d\n",iparam[4]);
fprintf(stderr,"Decrease ncv=%d to %d & rerun\n",ncv, iparam[4]);
}
}
}
else {
/***********************************************
* No fatal errors occurred.
* Post-Process using PSNEUPD.
*
* Extract computed eigenvalues. Eigenvectors
* may also be computed by setting rvec = 1.
**********************************************/
/* Form select array, telling which eigenvalues are converged */
if (mode==SHIFTI) {
stslc3_( &ncv, &iparam[4], &tol, &sigma, &mu, &delta, &zeta,
&trans[temp_ncv-iparam[4]],
&workl[lworkl-3*ncv], &workl[lworkl-2*ncv], &workl[lworkl-ncv],
select );
}
else if (sigma < mu){
stslct_( &ncv, &iparam[4], &tol, &sigma, &mu, &trans[temp_ncv-iparam[4]],
&workl[lworkl-3*ncv], &workl[lworkl-2*ncv], &workl[lworkl-ncv],
select );
}
else{
stslc2_( &ncv, &iparam[4], &tol, &sigma, &mu,&delta,
&trans[temp_ncv-iparam[4]],
&workl[lworkl-3*ncv], &workl[lworkl-2*ncv], &workl[lworkl-ncv],
select );
}
rvec = 1;
ierr = 0;
sprintf(string,"A");
cpdneupc_ (&comm, &rvec, string, select, d, v, &ldv, &sigma,
&mu, &delta, workev, bmat, &nloc, &nloc2, which, &nev,
&tol, resid, &ncv, iparam, ipntr, workd, workl,
&lworkl, &ierr, work);
/*----------------------------------------------
| The real part of the eigenvalue is returned |
| in the first column of the two dimensional |
| array D, and the imaginary part is returned |
| in the second column of D. The corresponding |
| eigenvectors are returned in the first NEV |
| columns of the two dimensional array V if |
| requested. Otherwise, an orthogonal basis |
| for the invariant subspace corresponding to |
| the eigenvalues in D is returned in V. |
-----------------------------------------------*/
if ( ierr != 0) {
/*-----------------------------------
| Error condition: |
| Check the documentation of PDNEUPC.|
------------------------------------*/
if ( printproc > 1) {
fprintf(stderr,"\nError with _neupc, info = %d", ierr);
fprintf(stderr,"\nCheck the documentation of _neupc.\n\n");
/* exit(1); */
}
}
/* if poleze also worked, go ahead and print output */
else if (!info_p) {
nconv = iparam[4];
/* Do not print more rows than requested number of eigenvalues */
if (nconv > 0 && nconv < nev) nrows = nconv;
/* Call sort_by_real if requested, otherwise use existing order */
if(sort) {
sort_by_real(nconv, ncv, ldv, d, v);
}
for (j = 0; j < nconv ; j++ ) {
/*--------------------------
| Compute the residual norm |
| |
| || J*x - lambda*x || |
| |
| for the NCONV accurately |
| computed eigenvalues and |
| eigenvectors. (iparam(5) |
| indicates how many are |
| accurate to the requested |
| tolerance) |
---------------------------*/
if (d[j+ncv] == 0.0){
/*-------------------
| Ritz value is real |
--------------------*/
/*
* d[j] : j-th eigenvalue
*
* v[j*ldv] : j-th eigenvector
*/
/* Print out eigenvectors, if requested */
if (j < jmax) {
if (printproc > 1)
printf("Printing real eigenvector with value %g\n", d[j]);
eigenvector_output_conwrap(j, 1, &v[(j)*ldv], d[j],
NULL, 0, con_step_num);
}
/* now calculate Rayleigh quotient */
d[j+2*ncv] = null_vector_resid(d[j], 0.0, &v[j*ldv], NULL, TRUE);
}
else{
/*----------------------
| Ritz value is complex |
-----------------------*/
/*
* d[j] : real part j-th eigenvalue
* d[j+ncv] : imag part j-th eigenvalue
*
* v[j*ldv] : real part j-th eigenvector
* v[(j+1)*ldv] : imag part j-th eigenvector
*/
/* If requested, print out eigenvectors */
if (j < jmax) {
if (printproc > 1) printf
("Printing eigenvector pair for complex eigenvalues: %g +- %g i\n",
d[j], fabs(d[j+ncv]));
eigenvector_output_conwrap(j, 2, &v[(j)*ldv], d[j], &v[(j+1)*ldv],
fabs(d[j+ncv]), con_step_num);
}
d[j+2*ncv] = null_vector_resid
(d[j], d[j+ncv], &v[(j)*ldv], &v[(j+1)*ldv], TRUE);
d[j+2*ncv+1] = d[j+2*ncv];
/* end of Rayleigh quotient stuff */
/*-----------------------
| Ritz value is complex. |
| Residual of one Ritz |
| value of the conjugate |
| pair is computed. |
------------------------*/
if( j+1 < nconv ){
d[j+1] = d[j];
d[j+1+ncv] = -d[j+ncv];
j = j + 1;
}
}
}
/* Display computed residuals */
dummy1 = 6; dummy2 = 3; dummy3 = ncv; dummy4 = -6;
cpdmout_(&comm, &dummy1, &nrows, &dummy2, d, &dummy3, &dummy4);
}
/* Print additional convergence information */
if (printproc > 4) {
if ( info == 1 ){
printf("\nMaximum number of iterations reached.\n");
}
else if ( info == 3 ){
printf("\nNo shifts could be applied during implicit\n");
printf("Arnoldi update, try increasing NCV.\n\n");
}
printf("\nEigenvalue Calculation Summary\n\n");
printf("The number of Ritz values requested is %d\n", nev);
printf("The number of Arnoldi vectors generated (NCV) is %d\n",ncv);
printf("What portion of the spectrum: %s\n", which);
printf("The number of converged Ritz values is %d\n",nconv);
printf("Number of Implicit Arnoldi update iterations taken is %d\n",
iparam[2]-1);
printf("The number of OP*x is %d\n",iparam[8]);
printf("The convergence criterion is %e\n", tol);
}
}
free_vec ((double **) &select);
free_vec ((double **) &work);
free_vec (&vecx);
free_vec (&vecy);
rhs = rhs_orig;
free_vec (&rhs);
free_vec (&mxx);
free_vec (&d);
free_vec (&resid);
free_vec (&workd);
free_vec (&workev);
free_vec (&workl);
free_vec (&v);
if (trans != NULL) free_vec (&trans);
if (workpol != NULL) free_vec (&workpol);
return (az_fail_cnt);
} /* end eig_driver */
void calc_eigenvalues_loca(struct con_struct *con)
{
#if defined (EIGEN_SERIAL) || defined (EIGEN_PARALLEL)
/* shorthand for long con sub-structure */
struct general_info_struct *cgi = &(con->general_info);
struct eigen_info_struct *cei = &(con->eigen_info);
double *x = cgi->x, *rhs;
/* Eigenvalue definitions */
int iparam[11];
int nev, ncv, info, mode, az_fail_cnt;
int jmax;
double tol, sigma, eta, mu, delta, zeta;
char bmat[2], which[3];
MPI_Comm comm; /* MPI communicator */
/* --------- Execution begins ---------------- */
if (cgi->printproc > 1) {
printf("\n");
printf("\tStarting Eigenvalue Calculation");
printf(" (2 matrix fills and an ARPACK call):\n");
}
/* Initialize some communications stuff for eig_driver */
comm = MPI_COMM_WORLD;
/* space needed for residual vector even for matrix-only fills */
rhs = alloc_vec();
/* Calculate Jacobian and mass matrices */
matrix_residual_fill_conwrap(x, rhs, MATRIX_ONLY);
mass_matrix_fill_conwrap(x, rhs);
create_shifted_matrix_conwrap();
free_vec (&rhs);
/* Set parameters for ARPACK: (1)first those that come from the input file */
iparam[MAX_ITRS] = cei->Max_Iter;
nev = cei->Num_Eigenvalues;
jmax = cei->Num_Eigenvectors;
sigma = cei->Shift_Point[0];
mu = cei->Shift_Point[1];
delta = cei->Shift_Point[2];
zeta = cei->Shift_Point[3];
if (delta != 1.0) {
if (cgi->printproc > 7)
printf("In eigensolver, delta set to one from %g\n",delta);
delta = 1.0;
}
ncv = cei->Arnoldi;
tol = cei->Residual_Tol[0];
eta = cei->Residual_Tol[1];
/*
* shift and invert implemented on top of Cayley, by setting flag
* value of mu = sigma. This capability was added after the Cayley
* version was mature, so it just piggybacks off of the Cayley
* version. This may explain some inefficiencies, such as passing
* the mu parameter to polez3_ where it is never used.
* AGS 1/29/02
*/
if (cgi->printproc > 4) {
if (sigma==mu)
printf("\tSHIFT-n-INVERT: sigma,ncv = %g %d\n",sigma, ncv);
else
printf("\tCAYLEY: sigma, mu, ncv = %g %g %d\n",sigma, mu, ncv);
}
/* Set parameters for ARPACK: (2)then those that are fixed for MPSalsa */
if (sigma==mu) {
mode = SHIFTI;
mu = 0;
}
else
mode = CAYLEY;
which[0] = 'L';
which[1] = 'R';
/* which[1] = 'M'; */
which[2] = '\0';
bmat[0] = 'I';
bmat[1] = '\0';
iparam[3] = 1;
iparam[4] = 0;
iparam[5] = 1; /* We will check for convergence ourselves */
iparam[7] = 0;
iparam[8] = 0;
iparam[9] = 0;
iparam[10] = 0;
iparam[SHIFTS] = 0;
iparam[MODE] = mode;
info = 0;
/* Have Aztec/ARPACK Calculate Eigenvlaues */
az_fail_cnt = eig_driver(which, bmat, iparam, mode, sigma, mu, delta, zeta,
nev, ncv, info, tol, eta, cgi->printproc,
cgi->numOwnedUnks, cgi->numUnks,
con->private_info.step_num, jmax, cei->sort, comm);
if( info != 0){
if (cgi->printproc > 1) printf(" Error %d in eigensolver\n",info);
exit(-1);
}
/* Before leaving back to MPSalsa, turn off time dependent terms */
destroy_shifted_matrix_conwrap();
if (cgi->printproc > 1) {
if (az_fail_cnt) {
printf("\tWARNING: Aztec failed to reach it convergence criterion\n");
printf("\t\t %d times during eigenvalue computation!\n",az_fail_cnt);
}
}
} /* end calc_eigenvalues */
int main(int argc, char *argv[])
{
vec_ptr vector;
data_t result;
long vector_size;
clock_t time_start, time_end;
if( argc != 3)
{
printf("Program usage: %s <algorithm-num> <vector-size>\n", argv[0]);
return 1;
}
vector_size=atol(argv[2]);
printf("Processing vector:\n");
printf(" * Elements: %ld\n", vector_size);
printf(" * Data type: %s\n", DATA_NAME);
printf(" * Operation: %s\n", OP_NAME);
// Allocate vector in memory
vector = new_vec(vector_size);
if(vector == NULL)
{
printf("Error: Unable to allocate vector\n");
return 1;
}
// Initialize vector with values
init_vec(vector);
// Process the vector with different algorithms
// (that all produce the same result)
// based on user input
time_start = clock();
if(strcmp(argv[1], "1") == 0)
combine1(vector, &result);
else if(strcmp(argv[1], "2") == 0)
combine2(vector, &result);
else if(strcmp(argv[1], "3") == 0)
combine3(vector, &result);
else if(strcmp(argv[1], "4") == 0)
combine4(vector, &result);
else if(strcmp(argv[1], "5x2") == 0)
combine5x2(vector, &result);
else if(strcmp(argv[1], "5x3") == 0)
combine5x3(vector, &result);
else if(strcmp(argv[1], "6") == 0)
combine6(vector, &result);
else
{
printf("ERROR: Invalid combine algorithm. Must specifiy 1,2,3,4,5x2,5x3, or 6\n");
free_vec(vector);
return 1;
}
time_end = clock();
printf("Finished running combine() operation\n");
// Don't care about the actual results. The array
// is so big that surely the calculation has
// overflowed by now...
printf("Time for combineN(): %.03f seconds\n", ((double)(time_end - time_start))/CLOCKS_PER_SEC);
// Clean up memory when finished
free_vec(vector);
return 0;
}
int con_lib(struct con_struct *con)
/*****************************************************************************
*
* Input Variables:
*
******************************************************************************/
{
/* Local Variables */
int n; /* Loop index */
int order; /* Continuation order flag:
0 - zero-order continuation
1 - first-order continuation
2 - arc-length continuation
This flag is always 0 on the first
solve, and 0 for turning point or any
other special continuation */
int i;
int num_newt_conv = 0; /* Number of newton iterations to reach
convergence for last nonlinear solve
-- used to pick next step size
ALSO error flag, when < 0 */
const char *yo = "con_lib";
int sn_old = 0 , sn_new = 0; /* Sign of cpi->dp_ds, to check for a
turning point */
int tan_flag; /* Set to zero when tang_factor is smaller
than step limit specified: step will be
halved and repeated even though converged */
/* These quantities are used
for arc length step control: */
double delta_s, end_passed, max_step, temp_step;
double *x_tang_old, *x2_old, *y_vec_old, *z_vec_old, bif_param_old = 0.0;
double ds_ratio = 1.0, first_arc_step =0.0, arc_step_adj =0.0;
double tang_factor = 1.0;
double step; /* step size of continuation parameter */
double step_old; /* old step size of continuation parameter */
double omega_old = 0.0; /* old Hopf tracking frequency */
struct arc_scale_struct arc_scale; /* allocate scaling params in struct */
struct arc_scale_struct *arc=&(arc_scale); /* pointer to arc_scale struct */
/* shorthand to some commonly used structures */
struct general_info_struct *cgi = &(con->general_info);
struct stepping_info_struct *csi = &(con->stepping_info);
struct arclength_info_struct *cai = &(con->arclength_info);
struct private_info_struct *cpi = &(con->private_info);
double *x = cgi->x;
memset((void **)arc, 0, sizeof(struct arc_scale_struct));
/******************************* First Executable Statment *****************/
if (cgi->printproc > 1)
printf("\tLOCA v1.0, Copyright 2001 Sandia Corporation\n\n");
/* Send vector length information to utilities file, so routines such
* as vector allocs and dot products won't need length information */
initialize_util_routines(cgi->numOwnedUnks, cgi->numUnks);
/*
* Initialize arrays to store predicted and old solutions. Save the current
* solution, x, into cpi->x_old
*/
cpi->x_old = alloc_vec();
cpi->scale_vec = alloc_vec();
cpi->param_old = cgi->param;
step = 0.0;
step_old = 0.0;
vec_copy(x, cpi->x_old);
switch (cgi->method) {
case ZERO_ORDER_CONTINUATION:
case FIRST_ORDER_CONTINUATION:
cpi->x_tang = alloc_vec();
break;
case ARC_LENGTH_CONTINUATION:
cpi->arc_step = 0.0;
cpi->x_tang = alloc_vec();
x_tang_old = alloc_vec();
break;
case TURNING_POINT_CONTINUATION:
case PITCHFORK_CONTINUATION:
cpi->x_tang = alloc_vec();
x_tang_old = alloc_vec();
break;
case HOPF_CONTINUATION:
omega_old = con->hopf_info.omega;
y_vec_old = alloc_vec();
z_vec_old = alloc_vec();
break;
case PHASE_TRANSITION_CONTINUATION:
x2_old = alloc_vec();
break;
}
/*
* Initialize variables used in arc length step control
*/
if (cgi->method == ARC_LENGTH_CONTINUATION) {
arc->dx_fac = 1.0;
if ((cai->dp_ds2_goal) < 1.0e-6) {
arc->dx_fac = 100.0;
}
arc->dx0 = arc->dx_fac;
arc->dx_fac_max = 1e+8;
arc->dp_ds_goal = sqrt(cai->dp_ds2_goal);
arc->dp_ds_limit = arc->dx_fac_max * arc->dp_ds_goal /
sqrt(1.0 + cai->dp_ds2_goal *
(arc->dx_fac_max * arc->dx_fac_max - 1.0));
if (cai->dp_ds_max < arc->dp_ds_goal) cai->dp_ds_max = arc->dp_ds_goal;
}
/* Adjust the BCs/Properties/whatever that the con param really represents */
assign_parameter_conwrap(cgi->param);
if (cgi->method == TURNING_POINT_CONTINUATION)
assign_bif_parameter_conwrap(con->turning_point_info.bif_param);
else if (cgi->method == PITCHFORK_CONTINUATION)
assign_bif_parameter_conwrap(con->pitchfork_info.bif_param);
else if (cgi->method == HOPF_CONTINUATION)
assign_bif_parameter_conwrap(con->hopf_info.bif_param);
else if (cgi->method == PHASE_TRANSITION_CONTINUATION)
assign_bif_parameter_conwrap(con->phase_transition_info.bif_param);
/* In tp_continuation, perturb initial guess off of potential singularity*/
if (cgi->method == TURNING_POINT_CONTINUATION ||
cgi->method == PITCHFORK_CONTINUATION) {
if (cgi->printproc > 4) printf("\tcon_lib: Adding random"
" perturbation for continuation\n");
perturb_solution_conwrap(x, cpi->x_old,
cpi->scale_vec, cgi->numOwnedUnks);
}
/*
* Print out general time integration information
*/
if (cgi->printproc > 1) {
printf("\n"); print_line("~", 80); print_line("~", 80);
printf("%s: Start Continuation\n", yo);
printf("\tInitial step size = %e \n",csi->first_step);
printf("\tMax number of continuation steps = %d\n",
csi->max_steps);
printf("\tMax parameter value = %g\n", csi->max_param);
print_line("~", 80); print_line("~", 80); printf("\n");
}
/***************************** CONTINUATION LOOP **************************/
/*
* Initialize the time step counter to 0. Set order flag to zero-order
* continuation through first solution.
*/
cpi->step_num = order = 0;
cpi->nstep = csi->base_step;
csi->last_step = FALSE;
/*
* Loop through a number of continuation steps - note the loop index may not
* represent the actual step counter, due to failed steps. The convention
* here is that solution 0 is not a step, so there will be
* csi->max_steps+1 solutions, numbered 0 through
* con->stepping_info.max_steps.
*/
for (n = 0; n <= csi->max_steps; n++) {
/*
* Print out an initial statement about the step.
*/
if (cgi->printproc > 1) print_cont_step1(order, step, step_old, con);
/*
* Set flag for new solve to detect first Newton iter
*/
cpi->first_iter = TRUE;
/*
* Solve the system of equations at the current step.
* Note - x is considered to be updated, on return from this
* solution.
*/
num_newt_conv = nonlinear_solver_conwrap(x,(void *)con,cpi->step_num,
cgi->param,step);
/*
* If tan_factor changes too much, tan_flag tells to halve step & reset.
*/
tan_flag = TRUE;
/*
* Check for convergence
*/
if (num_newt_conv < 0) {
/*
* Convergence Failure!
*
* If initial guess did not converge, abort entire continuation run
*/
if (cpi->step_num == 0) {
n = csi->max_steps; /* Force IO and exit */
cpi->step_num = -1; /* Set failure flag */
if (cgi->printproc > 1) {
printf("\n\t %s: INITIAL GUESS DID NOT CONVERGE:", yo);
printf("\n\t\t\t ABORTING CONTINUATION RUN\n");
}
}
/*
* If this convergence failure wasn't the first or last step, cut step
* size in half and calculate a new initial guess. New guess is
* the old solution plus the tangent to the previous prediction
* times the halved step size.
*/
else {
if (n < csi->max_steps) {
step *= 0.5;
/* Check for step size too small, abort if below min_delta_p */
if (fabs(step) < csi->min_delta_p)
{
n = csi->max_steps;
cpi->step_num = -1;
if (cgi->printproc > 1) {
printf("\n\t %s: CONTINUATION STEP SIZE TOO SMALL:", yo);
printf("\n\t\t\t ABORTING CONTINUATION RUN\n");
}
}
cgi->param = cpi->param_old + step;
assign_parameter_conwrap(cgi->param);
switch (order) {
case 0:
vec_copy(cpi->x_old, x);
switch (cgi->method) {
case TURNING_POINT_CONTINUATION:
vec_copy(x_tang_old, cpi->x_tang);
assign_bif_parameter_conwrap(bif_param_old);
con->turning_point_info.bif_param = bif_param_old;
break;
case PITCHFORK_CONTINUATION:
vec_copy(x_tang_old, cpi->x_tang);
assign_bif_parameter_conwrap(bif_param_old);
con->pitchfork_info.bif_param = bif_param_old;
break;
case PHASE_TRANSITION_CONTINUATION:
vec_copy(x2_old, con->phase_transition_info.x2);
assign_bif_parameter_conwrap(bif_param_old);
con->phase_transition_info.bif_param = bif_param_old;
break;
case HOPF_CONTINUATION:
vec_copy(y_vec_old, con->hopf_info.y_vec);
vec_copy(z_vec_old, con->hopf_info.z_vec);
assign_bif_parameter_conwrap(bif_param_old);
con->hopf_info.bif_param = bif_param_old;
con->hopf_info.omega = omega_old;
break;
}
break;
case 1:
for (i = 0; i < cgi->numUnks; i++)
x[i] = cpi->x_old[i] - step * cpi->x_tang[i];
break;
case 2:
cpi->arc_step *= 0.5;
for (i = 0; i < cgi->numUnks; i++)
x[i] = cpi->x_old[i] + cpi->arc_step * cpi->x_tang[i];
break;
}
/*
* Also, reset last_step flag to continue to final parameter value.
*/
csi->last_step = FALSE;
}
/*
* If it was the last step, however, reset to previous solution.
*/
else {
cgi->param = cpi->param_old;
assign_parameter_conwrap(cgi->param);
step = 0.0;
vec_copy(x, cpi->x_old);
csi->last_step = TRUE;
}
/*
* Print out failure message
*/
if (cgi->printproc > 1) print_cont_step_fail(order, step, con);
}
}
else {
/*
* Solver did Converge!!
*/
/*
* Check to see if parameter value passed end value (either direction)
*/
end_passed = (cgi->param - csi->max_param)
* (cpi->param_old - csi->max_param);
if ((cpi->step_num != 0 && end_passed <= 0.0) ||
n == csi->max_steps) csi->last_step = TRUE;
/*
* For arc-length continuation using the tangent factor,
* calculate cpi->x_tang and new tang_factor in advance,
* then compare to value for previous step. If this
* difference exceeds macpi->x_tang_step, treat this as a failed
* step and halve arc_step as above.
*/
if (!csi->last_step && cgi->method == ARC_LENGTH_CONTINUATION) {
if (cgi->printproc > 4) {
printf("\n\tDoing Pseudo Arc-length continuation --");
printf("\n\tCalculating tangent vector by one linear " "solve\n");
}
if (cpi->step_num == 0) step = csi->first_step;
calc_rhs_continuation(CONT_TANGENT, x, cpi->x_tang, NULL, NULL,
NULL, cgi->param, cgi->perturb, NULL,
cgi->numUnks, cgi->numOwnedUnks);
i = linear_solver_conwrap(cpi->x_tang, NEW_JACOBIAN, NULL);
if (cpi->step_num > 0)
tang_factor = fabs(scaled_dot_prod(x_tang_old, cpi->x_tang,
cpi->scale_vec, cgi->numOwnedUnks)) /
sqrt(scaled_dot_prod(x_tang_old, x_tang_old,
cpi->scale_vec, cgi->numOwnedUnks)
* scaled_dot_prod(cpi->x_tang, cpi->x_tang,
cpi->scale_vec, cgi->numOwnedUnks));
tang_factor = exp(cai->tang_exp * log(tang_factor));
if (cgi->printproc > 7) printf(" Tangent factor is %9g\n",tang_factor);
/* Repeat step if tang_factor is too small */
if (cpi->step_num > 1
&& tang_factor < cai->tang_step_limit) {
if (cgi->printproc > 7) printf(" Step limit exceeded: Retrying ...");
tan_flag = FALSE;
step *= 0.5;
cgi->param = cpi->param_old + step;
assign_parameter_conwrap(cgi->param);
cpi->arc_step *= 0.5;
for (i = 0; i < cgi->numUnks; i++)
x[i] = cpi->x_old[i] + cpi->arc_step * x_tang_old[i];
vec_copy(x_tang_old, cpi->x_tang);
}
}
/*
* If tan_flag has not been set to zero, proceed with continuation
*/
if (tan_flag == TRUE) {
/*
* Print out final results of a successful time step
*/
if (order == 2) step = cgi->param - cpi->param_old;
if (cgi->printproc > 4) print_cont_step2(order, step, con);
/*
* If first continuation step, set to value from input file. If
* controlled steps, use # of Newton iters to pick next step size
* For arc-length continuation, impose maximum step size as
* approximated by arc_step and dp_ds.
* Note: without time step control, step size can never increase.
*/
step_old = step;
if (cpi->step_num == 0) step = csi->first_step;
else {
/* normal step control */
if (!csi->last_step && csi->step_ctrl > 0.0) {
if (order == 2) cpi->arc_step *= simple_step_control(num_newt_conv,
csi->max_newton_its, csi->step_ctrl);
else {
step *= simple_step_control(num_newt_conv,
csi->max_newton_its, csi->step_ctrl);
if(fabs(step) > csi->max_delta_p)
step = ( (step > 0) ? csi->max_delta_p
: - csi->max_delta_p);
}
}
/* for constant step runs where the step has been cut, let it
* increase again with step control of 0.5
*/
else if (order < 2 && fabs(step) < fabs(csi->first_step)) {
step *= simple_step_control(num_newt_conv,
csi->max_newton_its, 0.5);
}
else if (order == 2 && fabs(cpi->arc_step) < arc_step_adj) {
cpi->arc_step *= simple_step_control(num_newt_conv,
csi->max_newton_its, 0.5);
if (cpi->arc_step > arc_step_adj) cpi->arc_step = arc_step_adj;
}
}
delta_s = ( (cgi->method == ARC_LENGTH_CONTINUATION)
? cpi->arc_step : step);
/*
* Output information at the end of every successful time step
* Depending on the solution method, there can be up to three
* solution vectors and parameter values to write out at a solution
*/
switch (cgi->method) {
case ZERO_ORDER_CONTINUATION:
case FIRST_ORDER_CONTINUATION:
case ARC_LENGTH_CONTINUATION:
solution_output_conwrap(1, x, cgi->param, NULL, 0.0, NULL, 0.0,
cpi->step_num, num_newt_conv, con);
break;
case TURNING_POINT_CONTINUATION:
solution_output_conwrap(2, x, cgi->param, cpi->x_tang,
con->turning_point_info.bif_param, NULL,
0.0, cpi->step_num, num_newt_conv, con);
break;
case PITCHFORK_CONTINUATION:
solution_output_conwrap(2, x, cgi->param, cpi->x_tang,
con->pitchfork_info.bif_param, NULL,
0.0, cpi->step_num, num_newt_conv, con);
break;
case HOPF_CONTINUATION:
solution_output_conwrap(3, x, cgi->param, con->hopf_info.y_vec,
con->hopf_info.bif_param,
con->hopf_info.z_vec, con->hopf_info.omega,
cpi->step_num, num_newt_conv, con);
break;
case PHASE_TRANSITION_CONTINUATION:
solution_output_conwrap(2, x, cgi->param,
con->phase_transition_info.x2,
con->phase_transition_info.bif_param, NULL,
0.0, cpi->step_num, num_newt_conv, con);
break;
}
/*
* Check current parameter value against the maximum.
*/
if (csi->last_step) {
n = csi->max_steps; /* Force IO and exit */
if (cgi->printproc > 1) {
printf("Simulation completed continuation in %d steps\n",
cpi->nstep);
printf("Final Parameter Value: %e\n\n", cgi->param);
if( end_passed <= 0.) {
printf("\n\n\t I will continue no more!\n\t No more continuation for you!\n");
}
}
}
if (n < csi->max_steps) {
/*
* Finally, its time to do some continuation, since the previous step
* converged and it wasn't the last step.
*/
if (cgi->printproc > 4) {
printf("\n"); print_line("~", 80);
printf("\nCalculating initial guess for next continuation "
"step\n");
}
/*
* Set the continuation order 0, 1 (Euler-Newton), or 2 (Arc-length)
* Always do only zero order continuation of a turning point
* or any other special continuation.
*/
switch (cgi->method) {
case FIRST_ORDER_CONTINUATION: order = 1; break;
case ARC_LENGTH_CONTINUATION: order = 2; break;
default: order = 0;
}
/*
* Possibly adjust the step value for this step so it hits maximum
* value exactly (zero or first order continuation).
* For arc length continuation, this is done after solution scaling.
*/
if (order != 2 && cpi->step_num != 0) {
temp_step = delta_s;
end_passed = ( (cgi->param + temp_step - csi->max_param)
* (cgi->param - csi->max_param) ) ;
/*
* If end_passed <= 0, next step would take param past end value
*/
if (end_passed <= 0) {
step = csi->max_param - cgi->param;
csi->last_step = TRUE;
if (cgi->printproc > 7)
fprintf(stderr,"\n\t ******** LAST PATH STEP!\n");
}
}
/*
* Calculate the tangent to the solution, cpi->x_tang, for the
* current step. This is trivial for 0-order continuation, requires
* 1 linear solve for 1st order continuation and for arc-length
* continuation. Use tangent to predict new solution in x.
*/
switch (order) {
case 0:
if (cgi->printproc > 4) {
printf("\n Doing Zeroth-order continuation --");
printf("\n previous solution used as initial guess\n");
}
/*
* NO definition of cpi->x_tang needed for zero order.
* Don't set it to zero because that will mess up the
* turning point and phase transition tracking algorithms,
* which use that space for other purposes.
*/
/*
* Save the old solution, before overwriting with the new solution
* for use in restarting after failed steps
*/
vec_copy(x, cpi->x_old);
switch (cgi->method) {
case TURNING_POINT_CONTINUATION:
vec_copy(cpi->x_tang, x_tang_old);
bif_param_old = con->turning_point_info.bif_param;
break;
case PITCHFORK_CONTINUATION:
vec_copy(cpi->x_tang, x_tang_old);
bif_param_old = con->pitchfork_info.bif_param;
break;
case PHASE_TRANSITION_CONTINUATION:
vec_copy(con->phase_transition_info.x2, x2_old);
bif_param_old = con->phase_transition_info.bif_param;
break;
case HOPF_CONTINUATION:
vec_copy(con->hopf_info.y_vec, y_vec_old);
vec_copy(con->hopf_info.z_vec, z_vec_old);
bif_param_old = con->hopf_info.bif_param;
omega_old = con->hopf_info.omega;
break;
}
/* perturb guess off of singularity in tp_continuation */
if (cgi->method == TURNING_POINT_CONTINUATION ||
cgi->method == PITCHFORK_CONTINUATION) {
if (cgi->printproc > 4) printf("\tcon_lib: Adding random"
" perturbation for continuation\n");
perturb_solution_conwrap(x, cpi->x_old,
cpi->scale_vec, cgi->numOwnedUnks);
}
break;
case 1:
if (cgi->printproc > 4) {
printf("\n Doing First-order continuation --");
printf("\n calculating tangent vector by one linear "
"solve\n");
}
/*
* Choose perturbation for numerical derivative of Residuals w.r.t
* continuation parameter, and solve for the tangent vector as in
* eq. 7.13 in John's thesis. The continuation parameter and
* perturbation, cgi->param and delta_param, are passed to the
* linear solver in the spots for the time and CJ, which aren't'
* needed for steady problems.
*/
calc_rhs_continuation(CONT_TANGENT, x, cpi->x_tang, NULL, NULL,
NULL, cgi->param, cgi->perturb, NULL,
cgi->numUnks, cgi->numOwnedUnks);
linear_solver_conwrap(cpi->x_tang, NEW_JACOBIAN, NULL);
/*
* Save the old solution, before overwriting with the new solution
*/
vec_copy(x, cpi->x_old);
/*
* Multiply the tangent vector, cpi->x_tang initially, by the step
* length, and add to x, to obtain an initial guess at
* the next parameter value.
*/
for (i = 0; i < cgi->numUnks; i++) {
x[i] -= cpi->x_tang[i] * step;
}
break;
case 2: /* Arclength ccontinuation predictor and step control */
/* cpi->x_tang vector found above. */
/* Function "solution_scale" rescales solution as necessary. */
ds_ratio = solution_scale(con, arc);
if (cgi->printproc > 7) {
printf(" Solution scale factor is %9g\n", arc->dx_fac);
}
/* Adjust arc_step for current scale factor. */
cpi->arc_step /= ds_ratio;
arc_step_adj = fabs(first_arc_step * arc->ds_fac);
/* Adjust arc_step for current tangent factor. */
cpi->arc_step *= tang_factor;
/* Also reduce arc_step if too large. */
max_step = fabs(csi->max_delta_p / cpi->dp_ds);
if (cpi->arc_step > max_step) cpi->arc_step = max_step;
/*
* Readjust the step value for this step so it hits maximum
* or end value (approximately) for arc length continuation.
*/
if (cpi->step_num != 0) {
temp_step = delta_s * cpi->dp_ds;
if (step < 0) temp_step *= -1.0;
end_passed = ( (cgi->param + temp_step - csi->max_param)
* (cgi->param - csi->max_param) ) ;
/* If end_passed < 0, next step would take param past end value */
if (end_passed < 0) {
temp_step = (csi->max_param - cgi->param);
if (step < 0) temp_step *= -1.0;
cpi->arc_step = fabs(temp_step / cpi->dp_ds);
csi->last_step = TRUE;
if (cgi->printproc > 7)
fprintf(stderr,"\n\t ******** LAST PATH STEP!\n");
}
}
/*
* If this is the first step, pick cpi->arc_step so that this step
* will progress the parameter by approximately csi->step
*/
if (cpi->step_num == 0) {
if (step < 0) {
cpi->dp_ds *= -1.0;
sn_old = -1;
}
else
sn_old = 1;
cpi->arc_step = step / cpi->dp_ds;
first_arc_step = cpi->arc_step;
}
else {
/*
* Pick sign of cpi->dp_ds according to eq. 7.14b in JNS thesis
* NOTE: -1.0 factor multiplying solution terms is because
* cpi->x_tang is currently the negative of the tangent vector.
*
* and check if a turning point was passed --
*/
if (-1.0 * (scaled_dot_prod(cpi->x_tang, x,
cpi->scale_vec, cgi->numOwnedUnks) -
scaled_dot_prod(cpi->x_tang, cpi->x_old,
cpi->scale_vec, cgi->numOwnedUnks)) +
cgi->param - cpi->param_old < 0.0) {
cpi->dp_ds *= -1.0;
sn_new = -1;
}
else
sn_new = 1;
if ((cgi->printproc > 1) && sn_old != sn_new)
printf("\n\n\tA turning point was passed !!!!!!!\n");
sn_old = sn_new;
}
/*
* Save the old solution, before overwriting with the new solution
*/
vec_copy(x, cpi->x_old);
/*
* Calculate prediction for next step from Eqs. 7.15&7.16 in JNS
* thesis (leaving cpi->x_tang = u_dot).
*/
for (i = 0; i < cgi->numUnks; i++) {
cpi->x_tang[i] *= -cpi->dp_ds;
x[i] += cpi->x_tang[i] * cpi->arc_step;
}
step = cpi->dp_ds * cpi->arc_step;
vec_copy(cpi->x_tang, x_tang_old);
break;
}
/*
* Increment the continuation parameter. Update the
* BCs/Properties/whatever that the continuation parameter really
* represents.
*/
cpi->param_old = cgi->param;
cgi->param += step;
assign_parameter_conwrap(cgi->param);
/*
* Increment the step counter. Print final message.
*/
cpi->step_num++;
cpi->nstep++;
} /* END of: if (n < csi->max_steps) */
} /* END of: if (tan_flag == TRUE) */
} /* END of else section for converged solves */
} /* END of loop over continuation step attempts --- for (n = 0; ... --- */
/*********************CLEAN-UP AREA*****************************************/
/*
* Free auxillary vectors no matter what happened
*/
free_vec (&cpi->x_old);
free_vec (&cpi->scale_vec);
switch (cgi->method) {
case ZERO_ORDER_CONTINUATION:
case FIRST_ORDER_CONTINUATION:
free_vec (&cpi->x_tang);
break;
case ARC_LENGTH_CONTINUATION:
case TURNING_POINT_CONTINUATION:
case PITCHFORK_CONTINUATION:
if (!cgi->nv_save) free_vec (&cpi->x_tang);
free_vec (&x_tang_old);
break;
case PHASE_TRANSITION_CONTINUATION:
free_vec (&x2_old);
break;
case HOPF_CONTINUATION:
free_vec (&y_vec_old);
free_vec (&z_vec_old);
break;
}
/*
* Send back the overall result of the time step
*/
return cpi->step_num;
} /**************** END of solve_continuation () *****************************/
/* The core of recursive retrieving. Endless recursion is avoided by
having all URL-s stored to a linked list of URL-s, which is checked
before loading any URL. That way no URL can get loaded twice.
The function also supports specification of maximum recursion depth
and a number of other goodies. */
uerr_t
recursive_retrieve (const char *file, const char *this_url)
{
char *constr, *filename, *newloc;
char *canon_this_url = NULL;
int dt, inl;
int this_url_ftp; /* See below the explanation */
uerr_t err;
struct urlinfo *rurl;
urlpos *url_list, *cur_url;
char *rfile; /* For robots */
struct urlinfo *u;
assert (this_url != NULL);
assert (file != NULL);
/* If quota was exceeded earlier, bail out. */
if (opt.quota && (opt.downloaded > opt.quota))
return QUOTEXC;
/* Cache the current URL in the list. */
if (first_time)
{
ulist = add_slist (ulist, this_url, 0);
urls_downloaded = NULL;
urls_html = NULL;
/* Enter this_url to the slist, in original and "enhanced" form. */
u = newurl ();
err = parseurl (this_url, u, 0);
if (err == URLOK)
{
ulist = add_slist (ulist, u->url, 0);
urls_downloaded = add_url (urls_downloaded, u->url, file);
urls_html = add_slist (urls_html, file, NOSORT);
if (opt.no_parent)
base_dir = xstrdup (u->dir); /* Set the base dir. */
/* Set the canonical this_url to be sent as referer. This
problem exists only when running the first time. */
canon_this_url = xstrdup (u->url);
}
else
{
DEBUGP (("Double yuck! The *base* URL is broken.\n"));
base_dir = NULL;
}
freeurl (u, 1);
depth = 1;
robots_host = NULL;
forbidden = NULL;
first_time = 0;
}
else
++depth;
/* Bail out if opt.reclevel is exceeded. */
if ((opt.reclevel != 0) && (depth > opt.reclevel))
{
DEBUGP (("Recursion depth %d exceeded max. depth %d.\n",
depth, opt.reclevel));
--depth;
return RECLEVELEXC;
}
/* Determine whether this_url is an FTP URL. If it is, it means
that the retrieval is done through proxy. In that case, FTP
links will be followed by default and recursion will not be
turned off when following them. */
this_url_ftp = (urlproto (this_url) == URLFTP);
/* Get the URL-s from an HTML file: */
url_list = get_urls_html (file,
canon_this_url ? canon_this_url : this_url, 0);
/* Decide what to do with each of the URLs. A URL will be loaded if
it meets several requirements, discussed later. */
for (cur_url = url_list; cur_url; cur_url = cur_url->next)
{
/* If quota was exceeded earlier, bail out. */
if (opt.quota && (opt.downloaded > opt.quota))
break;
/* Parse the URL for convenient use in other functions, as well
as to get the optimized form. It also checks URL integrity. */
u = newurl ();
if (parseurl (cur_url->url, u, 0) != URLOK)
{
DEBUGP (("Yuck! A bad URL.\n"));
freeurl (u, 1);
continue;
}
if (u->proto == URLFILE)
{
DEBUGP (("Nothing to do with file:// around here.\n"));
freeurl (u, 1);
continue;
}
assert (u->url != NULL);
constr = xstrdup (u->url);
/* Several checkings whether a file is acceptable to load:
1. check if URL is ftp, and we don't load it
2. check for relative links (if relative_only is set)
3. check for domain
4. check for no-parent
5. check for excludes && includes
6. check for suffix
7. check for same host (if spanhost is unset), with possible
gethostbyname baggage
8. check for robots.txt
Addendum: If the URL is FTP, and it is to be loaded, only the
domain and suffix settings are "stronger".
Note that .html and (yuck) .htm will get loaded
regardless of suffix rules (but that is remedied later with
unlink).
More time- and memory- consuming tests should be put later on
the list. */
/* inl is set if the URL we are working on (constr) is stored in
ulist. Using it is crucial to avoid the incessant calls to
in_slist, which is quite slow. */
inl = in_slist (ulist, constr);
/* If it is FTP, and FTP is not followed, chuck it out. */
if (!inl)
if (u->proto == URLFTP && !opt.follow_ftp && !this_url_ftp)
{
DEBUGP (("Uh, it is FTP but i'm not in the mood to follow FTP.\n"));
ulist = add_slist (ulist, constr, 0);
inl = 1;
}
/* If it is absolute link and they are not followed, chuck it
out. */
if (!inl && u->proto != URLFTP)
if (opt.relative_only && !(cur_url->flags & URELATIVE))
{
DEBUGP (("It doesn't really look like a relative link.\n"));
ulist = add_slist (ulist, constr, 0);
inl = 1;
}
/* If its domain is not to be accepted/looked-up, chuck it out. */
if (!inl)
if (!accept_domain (u))
{
DEBUGP (("I don't like the smell of that domain.\n"));
ulist = add_slist (ulist, constr, 0);
inl = 1;
}
/* Check for parent directory. */
if (!inl && opt.no_parent
/* If the new URL is FTP and the old was not, ignore
opt.no_parent. */
&& !(!this_url_ftp && u->proto == URLFTP))
{
/* Check for base_dir first. */
if (!(base_dir && frontcmp (base_dir, u->dir)))
{
/* Failing that, check for parent dir. */
struct urlinfo *ut = newurl ();
if (parseurl (this_url, ut, 0) != URLOK)
DEBUGP (("Double yuck! The *base* URL is broken.\n"));
else if (!frontcmp (ut->dir, u->dir))
{
/* Failing that too, kill the URL. */
DEBUGP (("Trying to escape parental guidance with no_parent on.\n"));
ulist = add_slist (ulist, constr, 0);
inl = 1;
}
freeurl (ut, 1);
}
}
/* If the file does not match the acceptance list, or is on the
rejection list, chuck it out. The same goes for the
directory exclude- and include- lists. */
if (!inl && (opt.includes || opt.excludes))
{
if (!accdir (u->dir, ALLABS))
{
DEBUGP (("%s (%s) is excluded/not-included.\n", constr, u->dir));
ulist = add_slist (ulist, constr, 0);
inl = 1;
}
}
if (!inl)
{
char *suf = NULL;
/* We check for acceptance/rejection rules only for non-HTML
documents. Since we don't know whether they really are
HTML, it will be deduced from (an OR-ed list):
1) u->file is "" (meaning it is a directory)
2) suffix exists, AND:
a) it is "html", OR
b) it is "htm"
If the file *is* supposed to be HTML, it will *not* be
subject to acc/rej rules. That's why the `!'. */
if (!
(!*u->file
|| (((suf = suffix (constr)) != NULL)
&& (!strcmp (suf, "html") || !strcmp (suf, "htm")))))
{
if (!acceptable (u->file))
{
DEBUGP (("%s (%s) does not match acc/rej rules.\n",
constr, u->file));
ulist = add_slist (ulist, constr, 0);
inl = 1;
}
}
FREE_MAYBE (suf);
}
/* Optimize the URL (which includes possible DNS lookup) only
after all other possibilities have been exhausted. */
if (!inl)
{
if (!opt.simple_check)
opt_url (u);
else
{
char *p;
/* Just lowercase the hostname. */
for (p = u->host; *p; p++)
*p = tolower (*p);
free (u->url);
u->url = str_url (u, 0);
}
free (constr);
constr = xstrdup (u->url);
inl = in_slist (ulist, constr);
if (!inl && !((u->proto == URLFTP) && !this_url_ftp))
if (!opt.spanhost && this_url && !same_host (this_url, constr))
{
DEBUGP (("This is not the same hostname as the parent's.\n"));
ulist = add_slist (ulist, constr, 0);
inl = 1;
}
}
/* What about robots.txt? */
if (!inl && opt.use_robots && u->proto == URLHTTP)
{
/* Since Wget knows about only one set of robot rules at a
time, /robots.txt must be reloaded whenever a new host is
accessed.
robots_host holds the host the current `forbid' variable
is assigned to. */
if (!robots_host || !same_host (robots_host, u->host))
{
FREE_MAYBE (robots_host);
/* Now make robots_host the new host, no matter what the
result will be. So if there is no /robots.txt on the
site, Wget will not retry getting robots all the
time. */
robots_host = xstrdup (u->host);
free_vec (forbidden);
forbidden = NULL;
err = retrieve_robots (constr, ROBOTS_FILENAME);
if (err == ROBOTSOK)
{
rurl = robots_url (constr, ROBOTS_FILENAME);
rfile = url_filename (rurl);
forbidden = parse_robots (rfile);
freeurl (rurl, 1);
free (rfile);
}
}
/* Now that we have (or don't have) robots, we can check for
them. */
if (!robots_match (u, forbidden))
{
DEBUGP (("Stuffing %s because %s forbids it.\n", this_url,
ROBOTS_FILENAME));
ulist = add_slist (ulist, constr, 0);
inl = 1;
}
}
filename = NULL;
/* If it wasn't chucked out, do something with it. */
if (!inl)
{
DEBUGP (("I've decided to load it -> "));
/* Add it to the list of already-loaded URL-s. */
ulist = add_slist (ulist, constr, 0);
/* Automatically followed FTPs will *not* be downloaded
recursively. */
if (u->proto == URLFTP)
{
/* Don't you adore side-effects? */
opt.recursive = 0;
}
/* Reset its type. */
dt = 0;
/* Retrieve it. */
retrieve_url (constr, &filename, &newloc,
canon_this_url ? canon_this_url : this_url, &dt);
if (u->proto == URLFTP)
{
/* Restore... */
opt.recursive = 1;
}
if (newloc)
{
free (constr);
constr = newloc;
}
/* In case of convert_links: If there was no error, add it to
the list of downloaded URLs. We might need it for
conversion. */
if (opt.convert_links && filename)
{
if (dt & RETROKF)
{
urls_downloaded = add_url (urls_downloaded, constr, filename);
/* If the URL is HTML, note it. */
if (dt & TEXTHTML)
urls_html = add_slist (urls_html, filename, NOSORT);
}
}
/* If there was no error, and the type is text/html, parse
it recursively. */
if (dt & TEXTHTML)
{
if (dt & RETROKF)
recursive_retrieve (filename, constr);
}
else
DEBUGP (("%s is not text/html so we don't chase.\n",
filename ? filename: "(null)"));
/* If an suffix-rejected file was loaded only because it was HTML,
undo the error now */
if (opt.delete_after || (filename && !acceptable (filename)))
{
logprintf (LOG_VERBOSE,
(opt.delete_after ? _("Removing %s.\n")
: _("Removing %s since it should be rejected.\n")),
filename);
if (unlink (filename))
logprintf (LOG_NOTQUIET, "unlink: %s\n", strerror (errno));
dt &= ~RETROKF;
}
/* If everything was OK, and links are to be converted, let's
store the local filename. */
if (opt.convert_links && (dt & RETROKF) && (filename != NULL))
{
cur_url->flags |= UABS2REL;
cur_url->local_name = xstrdup (filename);
}
}
DEBUGP (("%s already in list, so we don't load.\n", constr));
/* Free filename and constr. */
FREE_MAYBE (filename);
FREE_MAYBE (constr);
freeurl (u, 1);
/* Increment the pbuf for the appropriate size. */
}
if (opt.convert_links)
convert_links (file, url_list);
/* Free the linked list of URL-s. */
free_urlpos (url_list);
/* Free the canonical this_url. */
FREE_MAYBE (canon_this_url);
/* Decrement the recursion depth. */
--depth;
if (opt.quota && (opt.downloaded > opt.quota))
return QUOTEXC;
else
return RETROK;
}
