/*
* Sets the prompt
*/
void ReadLinePromptSet (const char *prompt)
{
rl_prompt_time = time (NULL);
s_init (&rl_prompt, COLSERVER, 0);
s_cat (&rl_prompt, ConvTo (prompt, ENC(enc_loc))->txt);
s_cat (&rl_prompt, COLNONE);
s_catc (&rl_prompt, ' ');
if (rl_prompt_stat != 0)
rl_prompt_stat = 2;
}
const char *
msg_proj_finder(const char * file)
{
static char * r = NULL;
static int r_len = 0;
s_zero(&r);
s_cat(&r, &r_len, pth_cfg_files);
s_cat(&r, &r_len, "/proj/");
s_cat(&r, &r_len, file);
return r;
}
char* ccl_binname(char* bit) {
char* ret=q("");
char* _uname_m=uname_m();
char* _uname=uname_s();
if(strcmp(_uname,"linux")==0) {
if(strcmp(_uname_m,"armhf")!=0)
ret=s_cat(ret,q("l"),NULL);
}else if(strcmp(_uname,"windows")==0) {
ret=s_cat(ret,q("w"),NULL);
}else if(strcmp(_uname,"darwin")==0) {
ret=s_cat(ret,q("d"),NULL);
}else if(strcmp(_uname,"freebsd")==0) {
ret=s_cat(ret,q("f"),NULL);
}
if(strcmp(_uname_m,"x86-64")==0 ||
strcmp(_uname_m,"x86")==0) {
ret=s_cat(ret,q("x86"),NULL);
}else if(strcmp(_uname_m,"armhf")==0)
ret=s_cat(ret,q("arm"),NULL);
ret=s_cat(ret,q("cl"),NULL);
if((strcmp(_uname_m,"x86-64")==0 &&
strcmp(bit,"32")!=0) ||
(strcmp(_uname_m,"x86")==0 &&
strcmp(bit,"64")==0))
ret=s_cat(ret,q("64"),NULL);
return ret;
}
integer
G77_chmod_0 ( /* const */ char *name, /* const */ char *mode,
const ftnlen Lname, const ftnlen Lmode)
{
char *buff;
int i;
ftnlen l, l2;
ftnlen six = 6;
address a[6];
ftnlen ii[6];
char chmod_path[] = CHMOD_PATH;
l = strlen (chmod_path);
buff = malloc (Lname + Lmode + l + 3 + 13 + 1);
if (!buff)
return -1;
ii[0] = l;
a[0] = chmod_path;
ii[1] = 1;
a[1] = " ";
ii[2] = Lmode;
a[2] = mode;
ii[3] = 2;
a[3] = " '";
for (l2 = Lname; (l2 > 1) && (name[l2 - 1] == ' ');)
l2--;
ii[4] = l2;
a[4] = name;
ii[5] = 13;
a[5] = "' 2>/dev/null";
s_cat (buff, a, ii, &six, Lname + Lmode + l + 3 + 13);
buff[Lname + Lmode + l + 3 + 13] = '\0';
i = system (buff);
free (buff);
return i;
}
/*
* Insert a character by unicode codepoint, display string in local encoding
* and its length, and its width in columns
*/
static void rl_insert_basic (wchar_tt ucs, const char *display, UDWORD len, UDWORD collen)
{
int i;
if (((rl_prompt_len + rl_colpos) % rl_columns) + collen > rl_columns)
{
for (i = (rl_columns - ((rl_prompt_len + rl_colpos) % rl_columns)); i > 0; i--)
{
wint_tt weof = WEOF;
s_insn (&rl_ucs, sizeof (wint_tt) * rl_ucspos, (const char *)&weof, sizeof (wint_tt));
s_insc (&rl_ucscol, rl_ucspos, 1);
s_insc (&rl_ucsbytes, rl_ucspos++, 1);
s_insc (&rl_display, rl_bytepos++, ' ');
s_catc (&rl_operate, ' ');
rl_colpos++;
}
}
s_insn (&rl_ucs, sizeof (wint_tt) * rl_ucspos, (const char *)&ucs, sizeof (wint_tt));
s_insc (&rl_ucscol, rl_ucspos, collen);
s_insc (&rl_ucsbytes, rl_ucspos++, len);
s_insn (&rl_display, rl_bytepos, display, len);
rl_colpos += collen;
rl_bytepos += len;
s_cat (&rl_operate, display);
}
/* Subroutine */ int G77_date_y2kbug_0 (char *buf, ftnlen buf_len)
{
/* System generated locals */
address a__1[5];
longint i__1;
integer i__2[5];
char ch__1[24];
/* Builtin functions */
/* Subroutine */ int s_copy(), s_cat();
/* Local variables */
static char cbuf[24];
extern longint G77_time_0 ();
extern /* Character */ VOID G77_ctime_0 ();
i__1 = G77_time_0 ();
G77_ctime_0 (ch__1, 24L, &i__1);
s_copy(cbuf, ch__1, 24L, 24L);
/* Writing concatenation */
i__2[0] = 2, a__1[0] = cbuf + 8;
i__2[1] = 1, a__1[1] = "-";
i__2[2] = 3, a__1[2] = cbuf + 4;
i__2[3] = 1, a__1[3] = "-";
i__2[4] = 2, a__1[4] = cbuf + 22;
s_cat(buf, a__1, i__2, &c__5, buf_len);
return 0;
} /* date_ */
/*
* Export options into a string.
*/
const char *OptString (const Opt *opts)
{
static str_s str;
int i, flag;
val_t val = 0;
s_init (&str, "", 100);
for (i = 0; OptList[i].name; i++)
if (OptGetVal (opts, flag = OptList[i].flag, &val))
{
if (flag & COF_BOOL)
{
if (!*str.txt)
s_cat (&str, "options");
s_catf (&str, " %s %s", OptList[i].name, val ? "on" : "off");
}
else
{
if (*str.txt)
s_catc (&str, '\n');
if (flag & COF_NUMERIC)
s_catf (&str, "options %s %lu", OptList[i].name, UD2UL (val));
else if (flag & COF_COLOR)
s_catf (&str, "options %s %s", OptList[i].name, s_quote (OptS2C (strtable[val])));
else
s_catf (&str, "options %s %s", OptList[i].name, s_quote (strtable[val]));
}
}
if (*str.txt)
s_catc (&str, '\n');
return str.txt;
}
/*
* Re-check remaining line for multicolumn line break problems
*/
static void rl_recheck (BOOL clear)
{
int gpos, i;
gpos = rl_colpos;
while (rl_ucspos < rl_ucscol.len)
{
if (rl_ucs_at (&rl_ucs, rl_ucspos) == WEOF)
{
s_deln (&rl_ucs, sizeof (wint_tt) * rl_ucspos, sizeof (wint_tt));
s_delc (&rl_ucsbytes, rl_ucspos);
s_delc (&rl_ucscol, rl_ucspos);
s_delc (&rl_display, rl_bytepos);
}
else if (((rl_prompt_len + rl_colpos) % rl_columns)
+ (UBYTE)rl_ucscol.txt[rl_ucspos] > rl_columns)
{
for (i = (rl_columns - ((rl_prompt_len + rl_colpos) % rl_columns)); i > 0; i--)
{
wint_tt weof = WEOF;
s_insn (&rl_ucs, sizeof (wint_tt) * rl_ucspos, (const char *)&weof, sizeof (wint_tt));
s_insc (&rl_ucscol, rl_ucspos, 1);
s_insc (&rl_ucsbytes, rl_ucspos++, 1);
s_insc (&rl_display, rl_bytepos++, ' ');
s_catc (&rl_operate, ' ');
rl_colpos++;
}
}
else
{
s_catn (&rl_operate, rl_display.txt + rl_bytepos, rl_ucsbytes.txt[rl_ucspos]);
rl_bytepos += rl_ucsbytes.txt[rl_ucspos];
rl_colpos += rl_ucscol.txt[rl_ucspos];
rl_ucspos++;
}
}
#ifdef ANSI_TERM
s_cat (&rl_operate, " \b");
if (clear)
s_cat (&rl_operate, ANSI_CLEAR);
#else
s_cat (&rl_operate, " \b\b\b\b\b");
#endif
rl_goto (gpos);
}
char* determin_impl(char* impl) {
char* version=NULL;
int pos;
cond_printf(1,"determin_impl:%s\n",impl);
if(impl && (pos=position_char("/",impl))!=-1) {
version=subseq(impl,pos+1,0);
impl=subseq(impl,0,pos);
}else {
if(!impl)
impl=get_opt("default.lisp",1);
if(impl) {
char* opt=s_cat(q(impl),q("."),q("version"),NULL);
version=get_opt(opt,1);
s(opt);
}
if(!impl)
impl=DEFAULT_IMPL;
impl=q(impl);
if(version)
version=q(version);
}
if(!version&&strcmp(impl,DEFAULT_IMPL)!=0) {
cond_printf(1,"once!%s,%s\n",impl,version);
if(!version)
s(version);
version=q("system");
}
if(!(impl && version)) {
char* cmd=cat(which(argv_orig[0]),verbose>0?(verbose>1?" -v -v":" -v"):""," setup",NULL);
char* ret;
if(impl) s(impl);
impl=q(DEFAULT_IMPL);
cond_printf(1,"cmd:%s\n",cmd);
ret=system_(cmd);
cond_printf(1,"ret:%s\n",ret);
s(ret);
char* path=s_cat(configdir(),q("config"),NULL);
global_opt=load_opts(path),s(path);;
version=get_opt(DEFAULT_IMPL".version",0);
}
return s_cat(impl,q("/"),version,NULL);
}
const void do_out(HandlerInfo *state, const char *str)
{
s_cat(state->out_buf, (char*) str);
if (strlen(str, MAX_STR_OUT_LEN*2) > MAX_STR_OUT_LEN) {
fprintf(ERRFILE, "ERROR: bad str\n");
fprintf(ERRFILE, "%s", str);
return;
}
}
int rename_file(char* file,char* new_name) {
#ifndef HAVE_WINDOWS_H
char* cmd;
int ret;
cmd=s_cat(q("mv "),q(file),q(" "),q(new_name),NULL);
ret=System(cmd);
s(cmd);
return ret==0;
#else
return MoveFileEx(file,new_name,MOVEFILE_REPLACE_EXISTING);
#endif
}
void app_init_home( t_app *app)
{
int size = 16;
char name[size];
int size_home = _PATH_;
char path_home[size_home];
sys_get( "whoami", name, size);
s_cp( path_home, "/home/", size_home);
s_cat( path_home, name, size);
s_cat( path_home, "/.minuit/", size_home);
if( !sys_file_exists( path_home))
{
printf("Creating minuit home directory: %s\n", path_home);
mkdir( path_home, 0777);
}
s_cp( app->path_home, path_home, _PATH_);
}
int installed_p(struct install_options* param) {
int ret;
char *i,*impl;
impl=q(param->impl);
//TBD for util.
i=s_cat(configdir(),q("impls"),q(SLASH),q(param->arch),q(SLASH),q(param->os),q(SLASH),
q(impl),q(param->version?SLASH:""),q(param->version?param->version:""),q(SLASH),NULL);
ret=directory_exist_p(i);
cond_printf(1,"directory_exist_p(%s)=%d\n",i,ret);
s(i),s(impl);
return ret;
}
void exec_arg(char** arg) {
#ifdef _WIN32
int i;
char* cmd=q(arg[0]);
for(i=1;arg[i]!=NULL;++i) {
cmd=s_cat(cmd,q(" "),q("\""),escape_string(arg[i]),q("\""),NULL);
}
SetConsoleCtrlHandler(ConsoleCtrlHandler, TRUE);
exit(System(cmd));
s(cmd);
#else
execvp(arg[0],&(arg[0]));
#endif
}
char *RQ_BuildQuery(char **query)
{
int i;
char *buf = NULL;
char *ret = NULL;
int qlen = array_len(query);
s_cat(ret, "?");
for (i=0; i<qlen/2; i++) {
int blen;
if (i > 0)
s_cat(ret, "&");
blen = array_len(query[i*2])*3+1;
array_resize(buf, blen);
RQ_EscapePath(query[i*2], buf, blen, RQ_ESC_QUERY|RQ_ESC_LABEL|RQ_ESC_PATH);
s_cat(ret, buf);
s_cat(ret, "=");
if (i*2+1 >= qlen) {
break;
}
blen = array_len(query[i*2+1])*3+1;
array_resize(buf, blen);
RQ_EscapePath(query[i*2+1], buf, blen, RQ_ESC_QUERY|RQ_ESC_LABEL|RQ_ESC_PATH);
s_cat(ret, buf);
}
return ret;
}
char *app_get_file_path( t_app *app, int type)
{
switch ( type)
{
case( APP_FILENAME_SAVE):
s_cp( app_filename_save, app->path_home, _PATH_);
s_cat( app_filename_save, "minuit.save", _PATH_);
return app_filename_save;
break;
default:
printf("[APP] Error, unknown filename\n");
return NULL;
break;
}
}
/*
* Hides the prompt
*/
void ReadLinePromptHide ()
{
int pos = rl_colpos;
ReadLineHandleSig ();
if (rl_prompt_stat == 0)
return;
s_init (&rl_operate, "", 0);
rl_goto (0);
s_catc (&rl_operate, '\r');
#ifdef ANSI_TERM
s_cat (&rl_operate, ANSI_CLEAR);
#endif
printf ("%s", rl_operate.txt);
rl_prompt_stat = 0;
rl_colpos = pos;
rl_print ("\r");
}
char *RQ_BuildReq(ReqInfo *req, int add_path, int code)
{
char *s = NULL;
char buf[1024];
char **headers = req->headers;
char *reason;
int i, len;
s_cat(s, req->method);
if (add_path) {
s_cat(s, " ");
s_cat(s, req->path);
}
if (code == 200) {
reason = "OK";
} else if (code > 400) {
reason = "ERR";
}
sprintf(buf, "http/1.1 %d %s\r\n", code, reason);
s_cat(s, buf);
len = array_len(headers);
for (i=0; i<len/2; i++) {
if (i*2+1 >= len) break;
s_cat(s, headers[i*2]);
s_cat(s, ": ");
s_cat(s, headers[i*2+1]);
s_cat(s, "\r\n");
}
s_cat(s, "\r\n");
return s;
}
int cmd_script_frontend(int argc,char **argv,struct sub_command* cmd) {
FILE* in;
char buf[800];
int i=0,j,c;
int argc_;
char** argv_;
char** argv_gen;
struct opts* opt;
if(script_frontend_sentinel)
return cmd_script(argc,argv,cmd);
script_frontend_sentinel=1;
if(strcmp(argv[0],"--")==0)
++argv,--argc;
cond_printf(1,"frontend:script_%s:argc=%d argv[0]=%s\n",cmd->name,argc,argv[0]);
for(opt=local_opt;opt;opt=opt->next)
if(strcmp(opt->name,"lisp")==0)
opt->name=s_cat(q("*"),opt->name,NULL);
if((in=fopen(argv[0],"rb"))!=NULL) {
if(fgetc(in)!='#'||fgetc(in)!='!') {
fclose(in);
cmd_script(argc,argv,cmd);
}
for(i=0;i<3;++i)
while((c=fgetc(in))!=EOF && c!='\n');
for(i=0;(c=fgetc(in))!=EOF;buf[i++]=c)
if(c=='\r'||c=='\n'||i==799)
break;
fclose(in);
}
buf[i]='\0';
cond_printf(1,"ros_script_cmd=%s\n",buf);
argv_=parse_cmdline(buf,&argc_);
argv_gen=alloc(sizeof(char**)*(argc+argc_));
for(i=0;i<argc_-2&&strcmp(argv_[i+2],"$0")!=0;++i)
argv_gen[i]=argv_[i+2];
for(j=i;i<j+argc;++i)
argv_gen[i]=argv[i-j];
j=i;
for(i=0;i<j;i+=proccmd(j-i,&argv_gen[i],top_options,top_commands));
return 0;
}
int sbcl_bin_expand(struct install_options* param) {
char* impl=param->impl;
char* version=q(param->version);
int ret;
char* home=configdir();
char* arch= arch_(param);
char* archive=cat(impl,"-",version,"-",arch,".msi",NULL);
char* log_path=cat(home,"impls",SLASH,"log",SLASH,impl,"-",version,"-",arch,SLASH,"install.log",NULL);
char* dist_path;
int pos=position_char("-",impl);
if(pos!=-1) {
impl=subseq(impl,0,pos);
}else
impl=q(impl);
dist_path=cat(home,"src",SLASH,impl,"-",version,"-",arch,SLASH,NULL);
printf("Extracting the msi archive. %s to %s\n",archive,dist_path);
archive=s_cat(q(home),q("archives"),q(SLASH),archive,NULL);
delete_directory(dist_path,1);
ensure_directories_exist(dist_path);
ensure_directories_exist(log_path);
if(dist_path[strlen(dist_path)-1]=='\\')
dist_path[strlen(dist_path)-1]='\0';
char* cmd=cat("msiexec.exe /a \"",
archive,
"\" targetdir=\"",
dist_path,
"\" /qn /lv ",
"\"",
log_path,
"\"",
NULL);
cmd=cat("cmd /c \"",cmd,"\"",NULL);
cond_printf(1,"msiexeccmd:%s\n",cmd);
ret=System(cmd);
s(impl);
s(dist_path);
s(log_path);
s(archive);
s(cmd),s(home),s(version),s(arch);
return !ret;
}
/*
* Compresses part of the current edited line into an UTF8 string
*/
static void rl_linecompress (str_t line, UDWORD from, UDWORD to)
{
UDWORD i;
wint_tt ucs;
if (to == (UDWORD)-1)
to = rl_ucscol.len;
s_init (line, "", 0);
for (i = from; i < to; i++)
{
ucs = rl_ucs_at (&rl_ucs, i);
#if DEBUG_RL
fprintf (stderr, "ucs %x\n", ucs);
#endif
if (ucs != WEOF)
s_cat (line, ConvUTF8 (ucs));
}
#if DEBUG_RL
fprintf (stderr, "compress %s\n", s_qquote (line->txt));
#endif
}
/*
* Shows the prompt
*/
void ReadLinePrompt ()
{
int gpos = rl_colpos;
if (rl_prompt_stat == 1)
return;
#if DEBUG_RL
fprintf (stderr, "killoper: %s\n", s_qquote (rl_operate.txt));
#endif
s_init (&rl_operate, "", 0);
if (rl_prompt_stat == 2)
rl_goto (0);
if (rl_prompt_stat == 2)
{
s_catc (&rl_operate, '\r');
#ifdef ANSI_TERM
s_cat (&rl_operate, ANSI_CLEAR);
#endif
rl_prompt_stat = 0;
}
#if DEBUG_RL
fprintf (stderr, "oper(rm): %s\n", s_qquote (rl_operate.txt));
#endif
printf ("%s", rl_operate.txt);
if (rl_prompt_stat == 0)
{
rl_print ("\r");
rl_print (rl_prompt.txt);
rl_prompt_len = rl_pos ();
rl_prompt_stat = 1;
rl_colpos = 0;
}
s_init (&rl_operate, "", 0);
rl_recheck (TRUE);
rl_goto (gpos);
printf ("%s", rl_operate.txt);
}
char* ccl_binname(void) {
char* ret=q("");
char* _uname_m=uname_m();
char* _uname=uname();
if(strcmp(_uname,"linux")==0) {
if(strcmp(_uname_m,"armhf")!=0)
ret=s_cat(ret,q("l"),NULL);
}else if(strcmp(_uname,"windows")==0) {
ret=s_cat(ret,q("w"),NULL);
}else if(strcmp(_uname,"darwin")==0) {
ret=s_cat(ret,q("d"),NULL);
}
if(strcmp(_uname_m,"x86-64")==0 ||
strcmp(_uname_m,"x86")==0) {
ret=s_cat(ret,q("x86"),NULL);
}else if(strcmp(_uname_m,"armhf")==0)
ret=s_cat(ret,q("arm"),NULL);
ret=s_cat(ret,q("cl"),NULL);
if(strcmp(_uname_m,"x86-64")==0)
ret=s_cat(ret,q("64"),NULL);
return ret;
}
/*
* Determine width and correct display for given (UTF8) string
*/
strc_t ReadLineAnalyzeWidth (const char *text, UWORD *width)
{
static str_s str = { NULL, 0, 0 };
wchar_tt ucs;
UWORD twidth, swidth = 0;
const char *dis;
int off = 0;
str_s in;
in.txt = (char *)text;
in.len = strlen (text);
in.max = 0;
s_init (&str, "", 100);
for (off = 0; off < in.len; )
{
ucs = ConvGetUTF8 (&in, &off);
rl_analyze_ucs (ucs, &dis, &twidth);
swidth += twidth & 0xff;
s_cat (&str, twidth & 0x100 ? ConvUTF8 (ucs) : dis);
}
*width = swidth;
return &str;
}
/* Subroutine */ int dormtr_(char *side, char *uplo, char *trans, integer *m,
integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *lwork, integer *info,
ftnlen side_len, ftnlen uplo_len, ftnlen trans_len)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer i1, i2, nb, mi, ni, nq, nw;
static logical left;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static integer iinfo;
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dormql_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen),
dormqr_(char *, char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, ftnlen, ftnlen);
static integer lwkopt;
static logical lquery;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORMTR overwrites the general real M-by-N matrix C with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': Q * C C * Q */
/* TRANS = 'T': Q**T * C C * Q**T */
/* where Q is a real orthogonal matrix of order nq, with nq = m if */
/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
/* nq-1 elementary reflectors, as returned by DSYTRD: */
/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q or Q**T from the Left; */
/* = 'R': apply Q or Q**T from the Right. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A contains elementary reflectors */
/* from DSYTRD; */
/* = 'L': Lower triangle of A contains elementary reflectors */
/* from DSYTRD. */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, apply Q; */
/* = 'T': Transpose, apply Q**T. */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension */
/* (LDA,M) if SIDE = 'L' */
/* (LDA,N) if SIDE = 'R' */
/* The vectors which define the elementary reflectors, as */
/* returned by DSYTRD. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
/* TAU (input) DOUBLE PRECISION array, dimension */
/* (M-1) if SIDE = 'L' */
/* (N-1) if SIDE = 'R' */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DSYTRD. */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If SIDE = 'L', LWORK >= max(1,N); */
/* if SIDE = 'R', LWORK >= max(1,M). */
/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
/* blocksize. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! left && ! lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans,
"T", (ftnlen)1, (ftnlen)1)) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*lwork < max(1,nw) && ! lquery) {
*info = -12;
}
if (*info == 0) {
if (upper) {
if (left) {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *m - 1;
i__3 = *m - 1;
nb = ilaenv_(&c__1, "DORMQL", ch__1, &i__2, n, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2);
} else {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *n - 1;
i__3 = *n - 1;
nb = ilaenv_(&c__1, "DORMQL", ch__1, m, &i__2, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2);
}
} else {
if (left) {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *m - 1;
i__3 = *m - 1;
nb = ilaenv_(&c__1, "DORMQR", ch__1, &i__2, n, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2);
} else {
/* Writing concatenation */
i__1[0] = 1, a__1[0] = side;
i__1[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
i__2 = *n - 1;
i__3 = *n - 1;
nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &i__2, &i__3, &c_n1, (
ftnlen)6, (ftnlen)2);
}
}
lwkopt = max(1,nw) * nb;
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__2 = -(*info);
xerbla_("DORMTR", &i__2, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || nq == 1) {
work[1] = 1.;
return 0;
}
if (left) {
mi = *m - 1;
ni = *n;
} else {
mi = *m;
ni = *n - 1;
}
if (upper) {
/* Q was determined by a call to DSYTRD with UPLO = 'U' */
i__2 = nq - 1;
dormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &
tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo, (ftnlen)
1, (ftnlen)1);
} else {
/* Q was determined by a call to DSYTRD with UPLO = 'L' */
if (left) {
i1 = 2;
i2 = 1;
} else {
i1 = 1;
i2 = 2;
}
i__2 = nq - 1;
dormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &
c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo, (ftnlen)
1, (ftnlen)1);
}
work[1] = (doublereal) lwkopt;
return 0;
/* End of DORMTR */
} /* dormtr_ */
/* Subroutine */ int dormrz_(char *side, char *trans, integer *m, integer *n,
integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau,
doublereal *c__, integer *ldc, doublereal *work, integer *lwork,
integer *info)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__;
#ifdef LAPACK_DISABLE_MEMORY_HOGS
doublereal t[1] /* was [65][64] */;
/** This function uses too much memory, so we stopped allocating the memory
* above and assert false here. */
assert(0 && "dormrz_ was called. This function allocates too much"
" memory and has been disabled.");
#else
doublereal t[4160] /* was [65][64] */;
#endif
integer i1, i2, i3, ib, ic, ja, jc, nb, mi, ni, nq, nw, iws;
logical left;
extern logical lsame_(char *, char *);
integer nbmin, iinfo;
extern /* Subroutine */ int dormr3_(char *, char *, integer *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int dlarzb_(char *, char *, char *, char *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dlarzt_(char *, char
*, integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
logical notran;
integer ldwork;
char transt[1];
integer lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORMRZ overwrites the general real M-by-N matrix C with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': Q * C C * Q */
/* TRANS = 'T': Q**T * C C * Q**T */
/* where Q is a real orthogonal matrix defined as the product of k */
/* elementary reflectors */
/* Q = H(1) H(2) . . . H(k) */
/* as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N */
/* if SIDE = 'R'. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q or Q**T from the Left; */
/* = 'R': apply Q or Q**T from the Right. */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, apply Q; */
/* = 'T': Transpose, apply Q**T. */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines */
/* the matrix Q. */
/* If SIDE = 'L', M >= K >= 0; */
/* if SIDE = 'R', N >= K >= 0. */
/* L (input) INTEGER */
/* The number of columns of the matrix A containing */
/* the meaningful part of the Householder reflectors. */
/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
/* A (input) DOUBLE PRECISION array, dimension */
/* (LDA,M) if SIDE = 'L', */
/* (LDA,N) if SIDE = 'R' */
/* The i-th row must contain the vector which defines the */
/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
/* DTZRZF in the last k rows of its array argument A. */
/* A is modified by the routine but restored on exit. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,K). */
/* TAU (input) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DTZRZF. */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If SIDE = 'L', LWORK >= max(1,N); */
/* if SIDE = 'R', LWORK >= max(1,M). */
/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
/* blocksize. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
lquery = *lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = max(1,*n);
} else {
nq = *n;
nw = max(1,*m);
}
if (! left && ! lsame_(side, "R")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
*info = -6;
} else if (*lda < max(1,*k)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -11;
}
if (*info == 0) {
if (*m == 0 || *n == 0) {
lwkopt = 1;
} else {
/* Determine the block size. NB may be at most NBMAX, where */
/* NBMAX is used to define the local array T. */
/* Computing MIN */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 64, i__2 = ilaenv_(&c__1, "DORMRQ", ch__1, m, n, k, &c_n1);
nb = min(i__1,i__2);
lwkopt = nw * nb;
}
work[1] = (doublereal) lwkopt;
if (*lwork < max(1,nw) && ! lquery) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DORMRZ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
work[1] = 1.;
return 0;
}
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
iws = nw * nb;
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 2, i__2 = ilaenv_(&c__2, "DORMRQ", ch__1, m, n, k, &c_n1);
nbmin = max(i__1,i__2);
}
} else {
iws = nw;
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
dormr3_(side, trans, m, n, k, l, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo);
} else {
/* Use blocked code */
if (left && ! notran || ! left && notran) {
i1 = 1;
i2 = *k;
i3 = nb;
} else {
i1 = (*k - 1) / nb * nb + 1;
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
jc = 1;
ja = *m - *l + 1;
} else {
mi = *m;
ic = 1;
ja = *n - *l + 1;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */
/* H = H(i+ib-1) . . . H(i+1) H(i) */
dlarzt_("Backward", "Rowwise", l, &ib, &a[i__ + ja * a_dim1], lda,
&tau[i__], t, &c__65);
if (left) {
/* H or H' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H or H' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H or H' */
dlarzb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, l, &a[
i__ + ja * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1]
, ldc, &work[1], &ldwork);
/* L10: */
}
}
work[1] = (doublereal) lwkopt;
return 0;
/* End of DORMRZ */
} /* dormrz_ */
/* Subroutine */ int cunmql_(char *side, char *trans, integer *m, integer *n,
integer *k, complex *a, integer *lda, complex *tau, complex *c__,
integer *ldc, complex *work, integer *lwork, integer *info)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__;
complex t[4160] /* was [65][64] */;
integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws;
logical left;
extern logical lsame_(char *, char *);
integer nbmin, iinfo;
extern /* Subroutine */ int cunm2l_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *), clarfb_(char *, char *,
char *, char *, integer *, integer *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *), clarft_(char *, char *
, integer *, integer *, complex *, integer *, complex *, complex *
, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical notran;
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CUNMQL overwrites the general complex M-by-N matrix C with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': Q * C C * Q */
/* TRANS = 'C': Q**H * C C * Q**H */
/* where Q is a complex unitary matrix defined as the product of k */
/* elementary reflectors */
/* Q = H(k) . . . H(2) H(1) */
/* as returned by CGEQLF. Q is of order M if SIDE = 'L' and of order N */
/* if SIDE = 'R'. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q or Q**H from the Left; */
/* = 'R': apply Q or Q**H from the Right. */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, apply Q; */
/* = 'C': Transpose, apply Q**H. */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines */
/* the matrix Q. */
/* If SIDE = 'L', M >= K >= 0; */
/* if SIDE = 'R', N >= K >= 0. */
/* A (input) COMPLEX array, dimension (LDA,K) */
/* The i-th column must contain the vector which defines the */
/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
/* CGEQLF in the last k columns of its array argument A. */
/* A is modified by the routine but restored on exit. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* If SIDE = 'L', LDA >= max(1,M); */
/* if SIDE = 'R', LDA >= max(1,N). */
/* TAU (input) COMPLEX array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by CGEQLF. */
/* C (input/output) COMPLEX array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If SIDE = 'L', LWORK >= max(1,N); */
/* if SIDE = 'R', LWORK >= max(1,M). */
/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
/* blocksize. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
lquery = *lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = max(1,*n);
} else {
nq = *n;
nw = max(1,*m);
}
if (! left && ! lsame_(side, "R")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "C")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
}
if (*info == 0) {
if (*m == 0 || *n == 0) {
lwkopt = 1;
} else {
/* Determine the block size. NB may be at most NBMAX, where */
/* NBMAX is used to define the local array T. */
/* Computing MIN */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMQL", ch__1, m, n, k, &c_n1);
nb = min(i__1,i__2);
lwkopt = nw * nb;
}
work[1].r = (real) lwkopt, work[1].i = 0.f;
if (*lwork < nw && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CUNMQL", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
iws = nw * nb;
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMQL", ch__1, m, n, k, &c_n1);
nbmin = max(i__1,i__2);
}
} else {
iws = nw;
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
cunm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo);
} else {
/* Use blocked code */
if (left && notran || ! left && ! notran) {
i1 = 1;
i2 = *k;
i3 = nb;
} else {
i1 = (*k - 1) / nb * nb + 1;
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
} else {
mi = *m;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */
/* H = H(i+ib-1) . . . H(i+1) H(i) */
i__4 = nq - *k + i__ + ib - 1;
clarft_("Backward", "Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1]
, lda, &tau[i__], t, &c__65);
if (left) {
/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */
mi = *m - *k + i__ + ib - 1;
} else {
/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */
ni = *n - *k + i__ + ib - 1;
}
/* Apply H or H' */
clarfb_(side, trans, "Backward", "Columnwise", &mi, &ni, &ib, &a[
i__ * a_dim1 + 1], lda, t, &c__65, &c__[c_offset], ldc, &
work[1], &ldwork);
/* L10: */
}
}
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CUNMQL */
} /* cunmql_ */
/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n,
integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DORMQR overwrites the general real M-by-N matrix C with
SIDE = 'L' SIDE = 'R'
TRANS = 'N': Q * C C * Q
TRANS = 'T': Q**T * C C * Q**T
where Q is a real orthogonal matrix defined as the product of k
elementary reflectors
Q = H(1) H(2) . . . H(k)
as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N
if SIDE = 'R'.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply Q or Q**T from the Left;
= 'R': apply Q or Q**T from the Right.
TRANS (input) CHARACTER*1
= 'N': No transpose, apply Q;
= 'T': Transpose, apply Q**T.
M (input) INTEGER
The number of rows of the matrix C. M >= 0.
N (input) INTEGER
The number of columns of the matrix C. N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines
the matrix Q.
If SIDE = 'L', M >= K >= 0;
if SIDE = 'R', N >= K >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,K)
The i-th column must contain the vector which defines the
elementary reflector H(i), for i = 1,2,...,k, as returned by
DGEQRF in the first k columns of its array argument A.
A is modified by the routine but restored on exit.
LDA (input) INTEGER
The leading dimension of the array A.
If SIDE = 'L', LDA >= max(1,M);
if SIDE = 'R', LDA >= max(1,N).
TAU (input) DOUBLE PRECISION array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by DGEQRF.
C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
On entry, the M-by-N matrix C.
On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If SIDE = 'L', LWORK >= max(1,N);
if SIDE = 'R', LWORK >= max(1,M).
For optimum performance LWORK >= N*NB if SIDE = 'L', and
LWORK >= M*NB if SIDE = 'R', where NB is the optimal
blocksize.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__65 = 65;
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static logical left;
static integer i__;
static doublereal t[4160] /* was [65][64] */;
extern logical lsame_(char *, char *);
static integer nbmin, iinfo, i1, i2, i3;
extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static integer ib, ic, jc, nb, mi, ni;
extern /* Subroutine */ int dlarfb_(char *, char *, char *, char *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer nq, nw;
extern /* Subroutine */ int dlarft_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static logical notran;
static integer ldwork, lwkopt;
static logical lquery;
static integer iws;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
lquery = *lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! left && ! lsame_(side, "R")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*lwork < max(1,nw) && ! lquery) {
*info = -12;
}
if (*info == 0) {
/* Determine the block size. NB may be at most NBMAX, where NBMAX
is used to define the local array T.
Computing MIN
Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1, (
ftnlen)6, (ftnlen)2);
nb = min(i__1,i__2);
lwkopt = max(1,nw) * nb;
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DORMQR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
work[1] = 1.;
return 0;
}
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
iws = nw * nb;
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX
Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1, (
ftnlen)6, (ftnlen)2);
nbmin = max(i__1,i__2);
}
} else {
iws = nw;
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo);
} else {
/* Use blocked code */
if (left && ! notran || ! left && notran) {
i1 = 1;
i2 = *k;
i3 = nb;
} else {
i1 = (*k - 1) / nb * nb + 1;
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
jc = 1;
} else {
mi = *m;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector
H = H(i) H(i+1) . . . H(i+ib-1) */
i__4 = nq - i__ + 1;
dlarft_("Forward", "Columnwise", &i__4, &ib, &a_ref(i__, i__),
lda, &tau[i__], t, &c__65);
if (left) {
/* H or H' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H or H' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H or H' */
dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &
a_ref(i__, i__), lda, t, &c__65, &c___ref(ic, jc), ldc, &
work[1], &ldwork);
/* L10: */
}
}
work[1] = (doublereal) lwkopt;
return 0;
/* End of DORMQR */
} /* dormqr_ */
/* Subroutine */ int sormbr_(char *vect, char *side, char *trans, integer *m,
integer *n, integer *k, real *a, integer *lda, real *tau, real *c__,
integer *ldc, real *work, integer *lwork, integer *info)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2];
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i1, i2, nb, mi, ni, nq, nw;
logical left;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical notran, applyq;
char transt[1];
extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* If VECT = 'Q', SORMBR overwrites the general real M-by-N matrix C */
/* with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': Q * C C * Q */
/* TRANS = 'T': Q**T * C C * Q**T */
/* If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C */
/* with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': P * C C * P */
/* TRANS = 'T': P**T * C C * P**T */
/* Here Q and P**T are the orthogonal matrices determined by SGEBRD when */
/* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and */
/* P**T are defined as products of elementary reflectors H(i) and G(i) */
/* respectively. */
/* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */
/* order of the orthogonal matrix Q or P**T that is applied. */
/* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */
/* if nq >= k, Q = H(1) H(2) . . . H(k); */
/* if nq < k, Q = H(1) H(2) . . . H(nq-1). */
/* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */
/* if k < nq, P = G(1) G(2) . . . G(k); */
/* if k >= nq, P = G(1) G(2) . . . G(nq-1). */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* = 'Q': apply Q or Q**T; */
/* = 'P': apply P or P**T. */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q, Q**T, P or P**T from the Left; */
/* = 'R': apply Q, Q**T, P or P**T from the Right. */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, apply Q or P; */
/* = 'T': Transpose, apply Q**T or P**T. */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* K (input) INTEGER */
/* If VECT = 'Q', the number of columns in the original */
/* matrix reduced by SGEBRD. */
/* If VECT = 'P', the number of rows in the original */
/* matrix reduced by SGEBRD. */
/* K >= 0. */
/* A (input) REAL array, dimension */
/* (LDA,min(nq,K)) if VECT = 'Q' */
/* (LDA,nq) if VECT = 'P' */
/* The vectors which define the elementary reflectors H(i) and */
/* G(i), whose products determine the matrices Q and P, as */
/* returned by SGEBRD. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* If VECT = 'Q', LDA >= max(1,nq); */
/* if VECT = 'P', LDA >= max(1,min(nq,K)). */
/* TAU (input) REAL array, dimension (min(nq,K)) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i) or G(i) which determines Q or P, as returned */
/* by SGEBRD in the array argument TAUQ or TAUP. */
/* C (input/output) REAL array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q */
/* or P*C or P**T*C or C*P or C*P**T. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If SIDE = 'L', LWORK >= max(1,N); */
/* if SIDE = 'R', LWORK >= max(1,M). */
/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
/* blocksize. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
applyq = lsame_(vect, "Q");
left = lsame_(side, "L");
notran = lsame_(trans, "N");
lquery = *lwork == -1;
/* NQ is the order of Q or P and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! applyq && ! lsame_(vect, "P")) {
*info = -1;
} else if (! left && ! lsame_(side, "R")) {
*info = -2;
} else if (! notran && ! lsame_(trans, "T")) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*k < 0) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = min(nq,*k);
if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -11;
} else if (*lwork < max(1,nw) && ! lquery) {
*info = -13;
}
}
if (*info == 0) {
if (applyq) {
if (left) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *m - 1;
i__2 = *m - 1;
nb = ilaenv_(&c__1, "SORMQR", ch__1, &i__1, n, &i__2, &c_n1);
} else {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *n - 1;
i__2 = *n - 1;
nb = ilaenv_(&c__1, "SORMQR", ch__1, m, &i__1, &i__2, &c_n1);
}
} else {
if (left) {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *m - 1;
i__2 = *m - 1;
nb = ilaenv_(&c__1, "SORMLQ", ch__1, &i__1, n, &i__2, &c_n1);
} else {
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = *n - 1;
i__2 = *n - 1;
nb = ilaenv_(&c__1, "SORMLQ", ch__1, m, &i__1, &i__2, &c_n1);
}
}
lwkopt = max(1,nw) * nb;
work[1] = (real) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORMBR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
work[1] = 1.f;
if (*m == 0 || *n == 0) {
return 0;
}
if (applyq) {
/* Apply Q */
if (nq >= *k) {
/* Q was determined by a call to SGEBRD with nq >= k */
sormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], lwork, &iinfo);
} else if (nq > 1) {
/* Q was determined by a call to SGEBRD with nq < k */
if (left) {
mi = *m - 1;
ni = *n;
i1 = 2;
i2 = 1;
} else {
mi = *m;
ni = *n - 1;
i1 = 1;
i2 = 2;
}
i__1 = nq - 1;
sormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1]
, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
}
} else {
/* Apply P */
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
if (nq > *k) {
/* P was determined by a call to SGEBRD with nq > k */
sormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], lwork, &iinfo);
} else if (nq > 1) {
/* P was determined by a call to SGEBRD with nq <= k */
if (left) {
mi = *m - 1;
ni = *n;
i1 = 2;
i2 = 1;
} else {
mi = *m;
ni = *n - 1;
i1 = 1;
i2 = 2;
}
i__1 = nq - 1;
sormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda,
&tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &
iinfo);
}
}
work[1] = (real) lwkopt;
return 0;
/* End of SORMBR */
} /* sormbr_ */
extern CDECL int
main(int argc, char **argv)
{
int d;
time_t tmUserStart = time(NULL);
clock_t tmCPUStart = clock();
{
/* FIXME: localtime? */
struct tm * t = localtime(&tmUserStart);
int y = t->tm_year + 1900;
current_days_since_1900 = days_since_1900(y, t->tm_mon + 1, t->tm_mday);
}
/* Always buffer by line for aven's benefit. */
setvbuf(stdout, NULL, _IOLBF, 0);
msg_init(argv);
#if OS_WIN32 || OS_UNIX_MACOSX
pj_set_finder(msg_proj_finder);
#endif
pcs = osnew(settings);
pcs->next = NULL;
pcs->Translate = ((short*) osmalloc(ossizeof(short) * 257)) + 1;
pcs->meta = NULL;
pcs->proj = NULL;
pcs->declination = HUGE_REAL;
pcs->convergence = 0.0;
/* Set up root of prefix hierarchy */
root = osnew(prefix);
root->up = root->right = root->down = NULL;
root->stn = NULL;
root->pos = NULL;
root->ident = NULL;
root->min_export = root->max_export = 0;
root->sflags = BIT(SFLAGS_SURVEY);
root->filename = NULL;
nosurveyhead = NULL;
stnlist = NULL;
cLegs = cStns = cComponents = 0;
totadj = total = totplan = totvert = 0.0;
for (d = 0; d <= 2; d++) {
min[d] = HUGE_REAL;
max[d] = -HUGE_REAL;
pfxHi[d] = pfxLo[d] = NULL;
}
/* at least one argument must be given */
cmdline_init(argc, argv, short_opts, long_opts, NULL, help, 1, -1);
while (1) {
int opt = cmdline_getopt();
if (opt == EOF) break;
switch (opt) {
case 'p':
/* Ignore for compatibility with older versions. */
break;
case 'o': {
osfree(fnm_output_base); /* in case of multiple -o options */
/* can be a directory (in which case use basename of leaf input)
* or a file (in which case just trim the extension off) */
if (fDirectory(optarg)) {
/* this is a little tricky - we need to note the path here,
* and then add the leaf later on (in datain.c) */
fnm_output_base = base_from_fnm(optarg);
fnm_output_base_is_dir = 1;
} else {
fnm_output_base = base_from_fnm(optarg);
}
break;
}
case 'q':
if (fQuiet) fMute = 1;
fQuiet = 1;
break;
case 's':
fSuppress = 1;
break;
case 'v': {
int v = atoi(optarg);
if (v < IMG_VERSION_MIN || v > IMG_VERSION_MAX)
fatalerror(/*3d file format versions %d to %d supported*/88,
IMG_VERSION_MIN, IMG_VERSION_MAX);
img_output_version = v;
break;
}
case 'w':
f_warnings_are_errors = 1;
break;
case 'z': {
/* Control which network optimisations are used (development tool) */
static int first_opt_z = 1;
char c;
if (first_opt_z) {
optimize = 0;
first_opt_z = 0;
}
/* Lollipops, Parallel legs, Iterate mx, Delta* */
while ((c = *optarg++) != '\0')
if (islower((unsigned char)c)) optimize |= BITA(c);
break;
case 1:
fLog = fTrue;
break;
#if OS_WIN32
case 2:
atexit(pause_on_exit);
break;
#endif
}
}
}
if (fLog) {
char *fnm;
if (!fnm_output_base) {
char *p;
p = baseleaf_from_fnm(argv[optind]);
fnm = add_ext(p, EXT_LOG);
osfree(p);
} else if (fnm_output_base_is_dir) {
char *p;
fnm = baseleaf_from_fnm(argv[optind]);
p = use_path(fnm_output_base, fnm);
osfree(fnm);
fnm = add_ext(p, EXT_LOG);
osfree(p);
} else {
fnm = add_ext(fnm_output_base, EXT_LOG);
}
if (!freopen(fnm, "w", stdout))
fatalerror(/*Failed to open output file “%s”*/47, fnm);
osfree(fnm);
}
if (!fMute) {
const char *p = COPYRIGHT_MSG;
puts(PRETTYPACKAGE" "VERSION);
while (1) {
const char *q = p;
p = strstr(p, "(C)");
if (p == NULL) {
puts(q);
break;
}
fwrite(q, 1, p - q, stdout);
fputs(msg(/*©*/0), stdout);
p += 3;
}
}
atexit(delete_output_on_error);
/* end of options, now process data files */
while (argv[optind]) {
const char *fnm = argv[optind];
if (!fExplicitTitle) {
char *lf;
lf = baseleaf_from_fnm(fnm);
if (survey_title) s_catchar(&survey_title, &survey_title_len, ' ');
s_cat(&survey_title, &survey_title_len, lf);
osfree(lf);
}
/* Select defaults settings */
default_all(pcs);
data_file(NULL, fnm); /* first argument is current path */
optind++;
}
validate();
solve_network(/*stnlist*/); /* Find coordinates of all points */
validate();
/* close .3d file */
if (!img_close(pimg)) {
char *fnm = add_ext(fnm_output_base, EXT_SVX_3D);
fatalerror(img_error2msg(img_error()), fnm);
}
if (fhErrStat) safe_fclose(fhErrStat);
out_current_action(msg(/*Calculating statistics*/120));
if (!fMute) do_stats();
if (!fQuiet) {
/* clock() typically wraps after 72 minutes, but there doesn't seem
* to be a better way. Still 72 minutes means some cave!
* We detect if clock() could have wrapped and suppress CPU time
* printing in this case.
*/
double tmUser = difftime(time(NULL), tmUserStart);
double tmCPU;
clock_t now = clock();
#define CLOCK_T_WRAP \
(sizeof(clock_t)<sizeof(long)?(1ul << (CHAR_BIT * sizeof(clock_t))):0)
tmCPU = (now - (unsigned long)tmCPUStart)
/ (double)CLOCKS_PER_SEC;
if (now < tmCPUStart)
tmCPU += CLOCK_T_WRAP / (double)CLOCKS_PER_SEC;
if (tmUser >= tmCPU + CLOCK_T_WRAP / (double)CLOCKS_PER_SEC)
tmCPU = 0;
/* tmUser is integer, tmCPU not - equivalent to (ceil(tmCPU) >= tmUser) */
if (tmCPU + 1 > tmUser) {
printf(msg(/*CPU time used %5.2fs*/140), tmCPU);
} else if (tmCPU == 0) {
if (tmUser != 0.0) {
printf(msg(/*Time used %5.2fs*/141), tmUser);
} else {
fputs(msg(/*Time used unavailable*/142), stdout);
}
} else {
printf(msg(/*Time used %5.2fs (%5.2fs CPU time)*/143), tmUser, tmCPU);
}
putnl();
}
if (msg_warnings || msg_errors) {
if (msg_errors || (f_warnings_are_errors && msg_warnings)) {
printf(msg(/*There were %d warning(s) and %d error(s) - no output files produced.*/113),
msg_warnings, msg_errors);
putnl();
return EXIT_FAILURE;
}
printf(msg(/*There were %d warning(s).*/16), msg_warnings);
putnl();
}
return EXIT_SUCCESS;
}
