void pix_equal :: vecUpperBoundMess(t_symbol*s,int argc, t_atom *argv)
{
m_upper[chAlpha] = 255;
setvec("upper bound", m_upper, argc, argv);
setPixModified();
}
void pix_equal :: vecLowerBoundMess(t_symbol*s,int argc, t_atom *argv)
{
m_lower[chAlpha] = 0;
setvec("lower bound", m_lower, argc, argv);
setPixModified();
}
VOID return_user(void)
{
psp FAR *p,
FAR * q;
REG COUNT i;
iregs FAR *irp;
/* long j;*/
/* restore parent */
p = MK_FP(cu_psp, 0);
/* When process returns - restore the isv */
setvec(0x22, p->ps_isv22);
setvec(0x23, p->ps_isv23);
setvec(0x24, p->ps_isv24);
/* And free all process memory if not a TSR return */
int2f_Remote_call(REM_PROCESS_END, 0, 0, 0, 0, 0, 0);
if (!tsr)
{
int2f_Remote_call(REM_CLOSEALL, 0, 0, 0, 0, 0, 0);
for (i = 0; i < p->ps_maxfiles; i++)
{
DosClose(i);
}
FcbCloseAll();
FreeProcessMem(cu_psp);
}
cu_psp = p->ps_parent;
q = MK_FP(cu_psp, 0);
dta = q->ps_dta;
irp = (iregs FAR *) q->ps_stack;
irp->CS = FP_SEG(p->ps_isv22);
irp->IP = FP_OFF(p->ps_isv22);
if (InDOS)
--InDOS;
exec_user((iregs FAR *) q->ps_stack);
}
VOID return_user(void)
{
psp FAR *p, FAR * q;
REG COUNT i;
iregs FAR *irp;
/* long j;*/
/* restore parent */
p = MK_FP(cu_psp, 0);
/* When process returns - restore the isv */
setvec(0x22, p->ps_isv22);
setvec(0x23, p->ps_isv23);
setvec(0x24, p->ps_isv24);
/* And free all process memory if not a TSR return */
remote_process_end(); /* might be a good idea to do that after closing
but doesn't help NET either TE */
if (!tsr)
{
remote_close_all();
for (i = 0; i < p->ps_maxfiles; i++)
{
DosClose(i);
}
FcbCloseAll();
FreeProcessMem(cu_psp);
}
cu_psp = p->ps_parent;
q = MK_FP(cu_psp, 0);
dta = q->ps_dta;
irp = (iregs FAR *) q->ps_stack;
irp->CS = FP_SEG(p->ps_isv22);
irp->IP = FP_OFF(p->ps_isv22);
if (InDOS)
--InDOS;
exec_user((iregs FAR *) q->ps_stack);
}
int
etherinit(void)
{
Ctlr *ctlr;
int ctlrno, i, mask, n;
mask = 0;
for(ctlrno = 0; ctlrno < MaxEther; ctlrno++){
ctlr = ðer[ctlrno];
memset(ctlr, 0, sizeof(Ctlr));
if(isaconfig("ether", ctlrno, &ctlr->card) == 0)
continue;
for(n = 0; cards[n].type; n++){
if(strcmp(cards[n].type, ctlr->card.type))
continue;
ctlr->ctlrno = ctlrno;
if((*cards[n].reset)(ctlr))
break;
ctlr->iq = qopen(16*1024, 1, 0, 0);
ctlr->oq = qopen(16*1024, 1, 0, 0);
ctlr->present = 1;
mask |= 1<<ctlrno;
print("ether%d: %s: port 0x%luX irq %d",
ctlr->ctlrno, ctlr->card.type, ctlr->card.port, ctlr->card.irq);
if(ctlr->card.mem)
print(" addr 0x%luX", ctlr->card.mem & ~KZERO);
if(ctlr->card.size)
print(" size 0x%luX", ctlr->card.size);
print(":");
for(i = 0; i < sizeof(ctlr->card.ea); i++)
print(" %2.2uX", ctlr->card.ea[i]);
print("\n"); uartwait();
setvec(ctlr->card.irq, ctlr->card.intr, ctlr);
break;
}
}
return mask;
}
void
mainloop(void) /* get and process input */
{
static struct node *sis[MAXDEPTH];
register struct node *newp;
char buf[128];
int level;
register int i;
level = 0;
while (fgets(buf, sizeof(buf), pin) != NULL) {
if ((newp = newnode()) == NULL) {
fprintf(stderr, "%s: memory error\n", progname);
return;
}
for (i = 0; buf[i] == '\t'; i++)
;
if (strtoipt(newp->ipt, buf+i) < 0) {
fprintf(stderr, "%s: bad read\n", progname);
return;
}
newp->sister = sis[i];
sis[i] = newp;
if (i < level) {
newp->daughter = sis[level];
sis[level] = NULL;
}
level = i;
if (i == 0) {
setvec(sis[0]->ipt);
tracerays(sis[0]);
freetree(sis[0]);
sis[0] = NULL;
if (!slow)
XFlush(theDisplay);
}
}
}
int
etherinit(void)
{
Ether *ctlr;
int ctlrno, i, mask, n, x;
fmtinstall('E', eipfmt);
if (getconf("*fakeintrs") != nil || getconf("*9loadfakeintrs") != nil)
startfakeintrs();
etherdetach = xetherdetach;
mask = 0;
for(ctlrno = 0; ctlrno < MaxEther; ctlrno++){
ctlr = ðer[ctlrno];
memset(ctlr, 0, sizeof(Ether));
if(iniread && isaconfig("ether", ctlrno, ctlr) == 0)
continue;
for(n = 0; ethercards[n].type; n++){
if(!iniread){
if(ethercards[n].noprobe)
continue;
memset(ctlr, 0, sizeof(Ether));
strcpy(ctlr->type, ethercards[n].type);
}
else if(cistrcmp(ethercards[n].type, ctlr->type))
continue;
ctlr->ctlrno = ctlrno;
x = splhi();
if((*ethercards[n].reset)(ctlr)){
splx(x);
if(iniread)
break;
else
continue;
}
ctlr->state = 1; /* card found */
mask |= 1<<ctlrno;
if(ctlr->irq == 2)
ctlr->irq = 9;
setvec(VectorPIC + ctlr->irq, ctlr->interrupt, ctlr);
print("ether#%d: %s: port 0x%luX irq %lud",
ctlr->ctlrno, ctlr->type, ctlr->port, ctlr->irq);
if(ctlr->mem)
print(" addr 0x%luX", ctlr->mem & ~KZERO);
if(ctlr->size)
print(" size 0x%luX", ctlr->size);
print(": %E\n", ctlr->ea);
if(ctlr->nrb == 0)
ctlr->nrb = Nrb;
ctlr->rb = ialloc(sizeof(RingBuf)*ctlr->nrb, 0);
if(ctlr->ntb == 0)
ctlr->ntb = Ntb;
ctlr->tb = ialloc(sizeof(RingBuf)*ctlr->ntb, 0);
ctlr->rh = 0;
ctlr->ri = 0;
for(i = 0; i < ctlr->nrb; i++)
ctlr->rb[i].owner = Interface;
ctlr->th = 0;
ctlr->ti = 0;
for(i = 0; i < ctlr->ntb; i++)
ctlr->tb[i].owner = Host;
splx(x);
break;
}
}
if (mask == 0) {
print("no ethernet interfaces recognised\n");
pcihinv(nil, Pcibcnet);
}
return mask;
}
COUNT DosExeLoader(BYTE FAR * namep, exec_blk FAR * exp, COUNT mode)
{
COUNT rc,
/*err, */
/*env_size,*/
i;
UCOUNT nBytesRead;
UWORD mem,
env,
asize,
start_seg;
ULONG image_size;
ULONG image_offset;
BYTE FAR *sp;
psp FAR *p;
psp FAR *q = MK_FP(cu_psp, 0);
mcb FAR *mp;
iregs FAR *irp;
UWORD reloc[2];
seg FAR *spot;
LONG exe_size;
int ModeLoadHigh = mode & 0x80;
UBYTE UMBstate = uppermem_link;
mode &= 0x7f;
/* Clone the environement and create a memory arena */
if (mode != OVERLAY)
{
if ((rc = ChildEnv(exp, &env, namep)) != SUCCESS)
return rc;
}
else
mem = exp->load.load_seg;
/* compute image offset from the header */
asize = 16;
image_offset = (ULONG)header.exHeaderSize * asize;
/* compute image size by removing the offset from the */
/* number pages scaled to bytes plus the remainder and */
/* the psp */
/* First scale the size */
asize = 512;
image_size = (ULONG)header.exPages * asize;
/* remove the offset */
image_size -= image_offset;
/* and finally add in the psp size */
if (mode != OVERLAY)
image_size += sizeof(psp); /*TE 03/20/01*/
if (mode != OVERLAY)
{
if ( ModeLoadHigh && uppermem_root)
{
DosUmbLink(1); /* link in UMB's */
mem_access_mode |= ModeLoadHigh;
}
/* Now find out how many paragraphs are available */
if ((rc = DosMemLargest((seg FAR *) & asize)) != SUCCESS)
{
DosMemFree(env);
return rc;
}
exe_size = (LONG) long2para(image_size) + header.exMinAlloc;
/* + long2para((LONG) sizeof(psp)); ?? see above
image_size += sizeof(psp) -- 1999/04/21 ska */
if (exe_size > asize && (mem_access_mode & 0x80))
{
/* First try low memory */
mem_access_mode &= ~0x80;
rc = DosMemLargest((seg FAR *) & asize);
mem_access_mode |= 0x80;
if (rc != SUCCESS)
{
DosMemFree(env);
return rc;
}
}
if (exe_size > asize)
{
DosMemFree(env);
return DE_NOMEM;
}
exe_size = (LONG) long2para(image_size) + header.exMaxAlloc;
/* + long2para((LONG) sizeof(psp)); ?? -- 1999/04/21 ska */
if (exe_size > asize)
exe_size = asize;
/* TE if header.exMinAlloc == header.exMaxAlloc == 0,
DOS will allocate the largest possible memory area
and load the image as high as possible into it.
discovered (and after that found in RBIL), when testing NET */
if ((header.exMinAlloc | header.exMaxAlloc ) == 0)
exe_size = asize;
/* /// Removed closing curly brace. We should not attempt to allocate
memory if we are overlaying the current process, because the new
process will simply re-use the block we already have allocated.
This was causing execl() to fail in applications which use it to
overlay (replace) the current exe file with a new one.
Jun 11, 2000 - rbc
} */
/* Allocate our memory and pass back any errors */
/* We can still get an error on first fit if the above */
/* returned size was a bet fit case */
/* ModeLoadHigh = 80 = try high, then low */
if ((rc = DosMemAlloc((seg) exe_size, mem_access_mode | ModeLoadHigh, (seg FAR *) & mem
,(UWORD FAR *) & asize)) < 0)
{
if (rc == DE_NOMEM)
{
if ((rc = DosMemAlloc(0, LARGEST, (seg FAR *) & mem
,(UWORD FAR *) & asize)) < 0)
{
DosMemFree(env);
return rc;
}
/* This should never happen, but ... */
if (asize < exe_size)
{
DosMemFree(mem);
DosMemFree(env);
return rc;
}
}
else
{
DosMemFree(env);
return rc;
}
}
else
/* with no error, we got exactly what we asked for */
asize = exe_size;
#ifdef DEBUG
printf("loading '%S' at %04x\n", namep, mem);
#endif
/* /// Added open curly brace and "else" clause. We should not attempt
to allocate memory if we are overlaying the current process, because
the new process will simply re-use the block we already have allocated.
This was causing execl() to fail in applications which use it to
overlay (replace) the current exe file with a new one.
Jun 11, 2000 - rbc */
}
else
asize = exe_size;
/* /// End of additions. Jun 11, 2000 - rbc */
if ( ModeLoadHigh && uppermem_root)
{
mem_access_mode &= ~ModeLoadHigh; /* restore old situation */
DosUmbLink(UMBstate); /* restore link state */
}
if (mode != OVERLAY)
{
/* memory found large enough - continue processing */
mp = MK_FP(mem, 0);
++mem;
}
else
mem = exp->load.load_seg;
/* create the start seg for later computations */
if (mode == OVERLAY)
start_seg = mem;
else
{
start_seg = mem + long2para((LONG) sizeof(psp));
}
/* Now load the executable */
/* If file not found - error */
/* NOTE - this is fatal because we lost it in transit */
/* from DosExec! */
if ((rc = DosOpen(namep, 0)) < 0)
{
fatal("(DosExeLoader) exe file lost in transit");
}
/* offset to start of image */
if (doslseek(rc, image_offset, 0) != image_offset)
{
if (mode != OVERLAY)
{
DosMemFree(--mem);
DosMemFree(env);
}
return DE_INVLDDATA;
}
/* read in the image in 32K chunks */
if (mode != OVERLAY)
{
exe_size = image_size - sizeof(psp);
}
else
exe_size = image_size;
if (exe_size > 0)
{
if (mode != OVERLAY)
{
if ((header.exMinAlloc == 0) && (header.exMaxAlloc == 0))
{
/* then the image should be placed as high as possible */
start_seg = start_seg + mp->m_size - (image_size + 15) / 16;
}
}
sp = MK_FP(start_seg, 0x0);
do
{
nBytesRead = DosRead((COUNT) rc, (COUNT) (exe_size < CHUNK ? exe_size : CHUNK), (VOID FAR *) sp, &UnusedRetVal);
sp = add_far((VOID FAR *) sp, (ULONG) nBytesRead);
exe_size -= nBytesRead;
}
while (nBytesRead && exe_size > 0);
}
/* relocate the image for new segment */
doslseek(rc, (LONG) header.exRelocTable, 0);
for (i = 0; i < header.exRelocItems; i++)
{
if (DosRead(rc, sizeof(reloc), (VOID FAR *) & reloc[0], &UnusedRetVal) != sizeof(reloc))
{
return DE_INVLDDATA;
}
if (mode == OVERLAY)
{
spot = MK_FP(reloc[1] + mem, reloc[0]);
*spot += exp->load.reloc;
}
else
{
/* spot = MK_FP(reloc[1] + mem + 0x10, reloc[0]); */
spot = MK_FP(reloc[1] + start_seg, reloc[0]);
*spot += start_seg;
}
}
/* and finally close the file */
DosClose(rc);
/* exit here for overlay */
if (mode == OVERLAY)
return SUCCESS;
/* point to the PSP so we can build it */
p = MK_FP(mem, 0);
setvec(0x22, (VOID(INRPT FAR *) (VOID)) MK_FP(user_r->CS, user_r->IP));
new_psp(p, mem + asize);
asize = patchPSP(mem - 1, env, exp, namep); /* asize = fcbcode */
/* Transfer control to the executable */
p->ps_parent = cu_psp;
p->ps_prevpsp = (BYTE FAR *) MK_FP(cu_psp, 0);
q->ps_stack = (BYTE FAR *) user_r;
user_r->FLAGS &= ~FLG_CARRY;
switch (mode)
{
case LOADNGO:
/* build the user area on the stack */
irp = MK_FP(header.exInitSS + start_seg,
((header.exInitSP - sizeof(iregs)) & 0xffff));
/* start allocating REGs */
/* Note: must match es & ds memory segment */
irp->ES = irp->DS = mem;
irp->CS = header.exInitCS + start_seg;
irp->IP = header.exInitIP;
irp->AX = asize; /* asize = fcbcode */
irp->BX =
irp->CX =
irp->DX =
irp->SI =
irp->DI =
irp->BP = 0;
irp->FLAGS = 0x200;
cu_psp = mem;
dta = p->ps_dta;
if (InDOS)
--InDOS;
exec_user(irp);
/* We should never be here */
fatal("KERNEL RETURNED!!!");
break;
case LOAD:
cu_psp = mem;
exp->exec.stack = MK_FP(header.exInitSS + start_seg, header.exInitSP);
*((UWORD FAR *) exp->exec.stack) = asize; /* fcbcode */
exp->exec.start_addr = MK_FP(header.exInitCS + start_seg, header.exInitIP);
return SUCCESS;
}
return DE_INVLDFMT;
}
COUNT DosComLoader(BYTE FAR * namep, exec_blk FAR * exp, COUNT mode)
{
COUNT rc
/* err */
/*,env_size*/;
COUNT nread;
UWORD mem;
UWORD env,
asize;
BYTE FAR *sp;
psp FAR *p;
psp FAR *q = MK_FP(cu_psp, 0);
iregs FAR *irp;
LONG com_size;
int ModeLoadHigh = mode & 0x80;
UBYTE UMBstate = uppermem_link;
mode &= 0x7f;
if (mode != OVERLAY)
{
if ((rc = ChildEnv(exp, &env, namep)) != SUCCESS)
{
return rc;
}
/* Now find out how many paragraphs are available */
if ((rc = DosMemLargest((seg FAR *) & asize)) != SUCCESS)
{
DosMemFree(env);
return rc;
}
com_size = asize;
if ( ModeLoadHigh && uppermem_root)
{
DosUmbLink(1); /* link in UMB's */
}
/* Allocate our memory and pass back any errors */
if ((rc = DosMemAlloc((seg) com_size, mem_access_mode, (seg FAR *) & mem
,(UWORD FAR *) & asize)) < 0)
{
if (rc == DE_NOMEM)
{
if ((rc = DosMemAlloc(0, LARGEST, (seg FAR *) & mem
,(UWORD FAR *) & asize)) < 0)
{
DosMemFree(env);
return rc;
}
/* This should never happen, but ... */
if (asize < com_size)
{
DosMemFree(mem);
DosMemFree(env);
return rc;
}
}
else
{
DosMemFree(env); /* env may be 0 */
return rc;
}
}
++mem;
}
else
mem = exp->load.load_seg;
if ( ModeLoadHigh && uppermem_root)
{
DosUmbLink(UMBstate); /* restore link state */
}
/* Now load the executable */
/* If file not found - error */
/* NOTE - this is fatal because we lost it in transit */
/* from DosExec! */
if ((rc = DosOpen(namep, 0)) < 0)
fatal("(DosComLoader) com file lost in transit");
/* do it in 32K chunks */
if ((com_size = DosGetFsize(rc)) != 0)
{
if (mode == OVERLAY) /* memory already allocated */
sp = MK_FP(mem, 0);
else
{ /* test the filesize against the allocated memory */
UWORD tmp = 16;
sp = MK_FP(mem, sizeof(psp));
/* This is a potential problem, what to do with .COM files larger than
the allocated memory?
MS DOS always only loads the very first 64KB - sizeof(psp) bytes.
-- 1999/04/21 ska */
if ((ULONG)com_size > (ULONG)asize * tmp) /* less memory than the .COM file has */
(ULONG)com_size = (ULONG)asize * tmp; /* << 4 */
}
do
{
nread = DosRead(rc, CHUNK, sp, &UnusedRetVal);
sp = add_far((VOID FAR *) sp, (ULONG) nread);
}
while ((com_size -= nread) > 0 && nread == CHUNK);
}
DosClose(rc);
if (mode == OVERLAY)
return SUCCESS;
/* point to the PSP so we can build it */
p = MK_FP(mem, 0);
setvec(0x22, (VOID(INRPT FAR *) (VOID)) MK_FP(user_r->CS, user_r->IP));
new_psp(p, mem + asize);
asize = patchPSP(mem - 1, env, exp, namep); /* asize=fcbcode for ax */
/* Transfer control to the executable */
p->ps_parent = cu_psp;
p->ps_prevpsp = (BYTE FAR *) MK_FP(cu_psp, 0);
q->ps_stack = (BYTE FAR *) user_r;
user_r->FLAGS &= ~FLG_CARRY;
cu_psp = mem;
dta = p->ps_dta;
switch (mode)
{
case LOADNGO:
{
*((UWORD FAR *) MK_FP(mem, 0xfffe)) = (UWORD) 0;
/* build the user area on the stack */
irp = MK_FP(mem, (0xfffe - sizeof(iregs)));
/* start allocating REGs */
irp->ES = irp->DS = mem;
irp->CS = mem;
irp->IP = 0x100;
irp->AX = asize; /* fcbcode */
irp->BX =
irp->CX =
irp->DX =
irp->SI =
irp->DI =
irp->BP = 0;
irp->FLAGS = 0x200;
if (InDOS)
--InDOS;
exec_user(irp);
/* We should never be here */
fatal("KERNEL RETURNED!!!");
break;
}
case LOAD:
exp->exec.stack = MK_FP(mem, 0xfffe);
*((UWORD FAR *)exp->exec.stack) = asize;
exp->exec.start_addr = MK_FP(mem, 0x100);
return SUCCESS;
}
return DE_INVLDFMT;
}
void
lanczos_FO (
struct vtx_data **A, /* graph data structure */
int n, /* number of rows/colums in matrix */
int d, /* problem dimension = # evecs to find */
double **y, /* columns of y are eigenvectors of A */
double *lambda, /* ritz approximation to eigenvals of A */
double *bound, /* on ritz pair approximations to eig pairs of A */
double eigtol, /* tolerance on eigenvectors */
double *vwsqrt, /* square root of vertex weights */
double maxdeg, /* maximum degree of graph */
int version /* 1 = standard mode, 2 = inverse operator mode */
)
{
extern FILE *Output_File; /* output file or NULL */
extern int DEBUG_EVECS; /* print debugging output? */
extern int DEBUG_TRACE; /* trace main execution path */
extern int WARNING_EVECS; /* print warning messages? */
extern int LANCZOS_MAXITNS; /* maximum Lanczos iterations allowed */
extern double BISECTION_SAFETY; /* safety factor for bisection algorithm */
extern double SRESTOL; /* resid tol for T evec comp */
extern double DOUBLE_MAX; /* Warning on inaccurate computation of evec of T */
extern double splarax_time; /* time matvecs */
extern double orthog_time; /* time orthogonalization work */
extern double tevec_time; /* time tridiagonal eigvec work */
extern double evec_time; /* time to generate eigenvectors */
extern double ql_time; /* time tridiagonal eigval work */
extern double blas_time; /* time for blas (not assembly coded) */
extern double init_time; /* time for allocating memory, etc. */
extern double scan_time; /* time for scanning bounds list */
extern double debug_time; /* time for debug computations and output */
int i, j; /* indicies */
int maxj; /* maximum number of Lanczos iterations */
double *u, *r; /* Lanczos vectors */
double *Aq; /* sparse matrix-vector product vector */
double *alpha, *beta; /* the Lanczos scalars from each step */
double *ritz; /* copy of alpha for tqli */
double *workj; /* work vector (eg. for tqli) */
double *workn; /* work vector (eg. for checkeig) */
double *s; /* eigenvector of T */
double **q; /* columns of q = Lanczos basis vectors */
double *bj; /* beta(j)*(last element of evecs of T) */
double bis_safety; /* real safety factor for bisection algorithm */
double Sres; /* how well Tevec calculated eigvecs */
double Sres_max; /* Maximum value of Sres */
int inc_bis_safety; /* need to increase bisection safety */
double *Ares; /* how well Lanczos calculated each eigpair */
double *inv_lambda; /* eigenvalues of inverse operator */
int *index; /* the Ritz index of an eigenpair */
struct orthlink *orthlist = NULL; /* vectors to orthogonalize against in Lanczos */
struct orthlink *orthlist2 = NULL; /* vectors to orthogonalize against in Symmlq */
struct orthlink *temp; /* for expanding orthogonalization list */
double *ritzvec=NULL; /* ritz vector for current iteration */
double *zeros=NULL; /* vector of all zeros */
double *ones=NULL; /* vector of all ones */
struct scanlink *scanlist; /* list of fields for min ritz vals */
struct scanlink *curlnk; /* for traversing the scanlist */
double bji_tol; /* tol on bji estimate of A e-residual */
int converged; /* has the iteration converged? */
double time; /* current clock time */
double shift, rtol; /* symmlq input */
long precon, goodb, nout; /* symmlq input */
long checka, intlim; /* symmlq input */
double anorm, acond; /* symmlq output */
double rnorm, ynorm; /* symmlq output */
long istop, itn; /* symmlq output */
double macheps; /* machine precision calculated by symmlq */
double normxlim; /* a stopping criteria for symmlq */
long itnmin; /* enforce minimum number of iterations */
int symmlqitns; /* # symmlq itns */
double *wv1=NULL, *wv2=NULL, *wv3=NULL; /* Symmlq work space */
double *wv4=NULL, *wv5=NULL, *wv6=NULL; /* Symmlq work space */
long long_n; /* long int copy of n for symmlq */
int ritzval_flag = 0; /* status flag for ql() */
double Anorm; /* Norm estimate of the Laplacian matrix */
int left, right; /* ranges on the search for ritzvals */
int memory_ok; /* TRUE as long as don't run out of memory */
double *mkvec(); /* allocates space for a vector */
double *mkvec_ret(); /* mkvec() which returns error code */
double dot(); /* standard dot product routine */
struct orthlink *makeorthlnk(); /* make space for entry in orthog. set */
double ch_norm(); /* vector norm */
double Tevec(); /* calc evec of T by linear recurrence */
struct scanlink *mkscanlist(); /* make scan list for min ritz vecs */
double lanc_seconds(); /* current clock timer */
int symmlq_(), get_ritzvals();
void setvec(), vecscale(), update(), vecran(), strout();
void splarax(), scanmin(), scanmax(), frvec(), orthogonalize();
void orthog1(), orthogvec(), bail(), warnings(), mkeigvecs();
if (DEBUG_TRACE > 0) {
printf("<Entering lanczos_FO>\n");
}
if (DEBUG_EVECS > 0) {
if (version == 1) {
printf("Full orthogonalization Lanczos, matrix size = %d\n", n);
}
else {
printf("Full orthogonalization Lanczos, inverted operator, matrix size = %d\n", n);
}
}
/* Initialize time. */
time = lanc_seconds();
if (n < d + 1) {
bail("ERROR: System too small for number of eigenvalues requested.",1);
/* d+1 since don't use zero eigenvalue pair */
}
/* Allocate Lanczos space. */
maxj = LANCZOS_MAXITNS;
u = mkvec(1, n);
r = mkvec(1, n);
Aq = mkvec(1, n);
ritzvec = mkvec(1, n);
zeros = mkvec(1, n);
setvec(zeros, 1, n, 0.0);
workn = mkvec(1, n);
Ares = mkvec(1, d);
inv_lambda = mkvec(1, d);
index = smalloc((d + 1) * sizeof(int));
alpha = mkvec(1, maxj);
beta = mkvec(1, maxj + 1);
ritz = mkvec(1, maxj);
s = mkvec(1, maxj);
bj = mkvec(1, maxj);
workj = mkvec(1, maxj + 1);
q = smalloc((maxj + 1) * sizeof(double *));
scanlist = mkscanlist(d);
if (version == 2) {
/* Allocate Symmlq space all in one chunk. */
wv1 = smalloc(6 * (n + 1) * sizeof(double));
wv2 = &wv1[(n + 1)];
wv3 = &wv1[2 * (n + 1)];
wv4 = &wv1[3 * (n + 1)];
wv5 = &wv1[4 * (n + 1)];
wv6 = &wv1[5 * (n + 1)];
/* Set invariant symmlq parameters */
precon = FALSE; /* FALSE until we figure out a good way */
goodb = FALSE; /* should be FALSE for this application */
checka = FALSE; /* if don't know by now, too bad */
intlim = n; /* set to enforce a maximum number of Symmlq itns */
itnmin = 0; /* set to enforce a minimum number of Symmlq itns */
shift = 0.0; /* since just solving rather than doing RQI */
symmlqitns = 0; /* total number of Symmlq iterations */
nout = 0; /* Effectively disabled - see notes in symmlq.f */
rtol = 1.0e-5; /* requested residual tolerance */
normxlim = DOUBLE_MAX; /* Effectively disables ||x|| termination criterion */
long_n = n; /* copy to long for linting */
}
/* Initialize. */
vecran(r, 1, n);
if (vwsqrt == NULL) {
/* whack one's direction from initial vector */
orthog1(r, 1, n);
/* list the ones direction for later use in Symmlq */
if (version == 2) {
orthlist2 = makeorthlnk();
ones = mkvec(1, n);
setvec(ones, 1, n, 1.0);
orthlist2->vec = ones;
orthlist2->pntr = NULL;
}
}
else {
/* whack vwsqrt direction from initial vector */
orthogvec(r, 1, n, vwsqrt);
if (version == 2) {
/* list the vwsqrt direction for later use in Symmlq */
orthlist2 = makeorthlnk();
orthlist2->vec = vwsqrt;
orthlist2->pntr = NULL;
}
}
beta[1] = ch_norm(r, 1, n);
q[0] = zeros;
bji_tol = eigtol;
orthlist = NULL;
Sres_max = 0.0;
Anorm = 2 * maxdeg; /* Gershgorin estimate for ||A|| */
bis_safety = BISECTION_SAFETY;
inc_bis_safety = FALSE;
init_time += lanc_seconds() - time;
/* Main Lanczos loop. */
j = 1;
converged = FALSE;
memory_ok = TRUE;
while ((j <= maxj) && (converged == FALSE) && memory_ok) {
time = lanc_seconds();
/* Allocate next Lanczos vector. If fail, back up one step and compute approx. eigvec. */
q[j] = mkvec_ret(1, n);
if (q[j] == NULL) {
memory_ok = FALSE;
if (DEBUG_EVECS > 0 || WARNING_EVECS > 0) {
strout("WARNING: Lanczos out of memory; computing best approximation available.\n");
}
if (j <= 2) {
bail("ERROR: Sorry, can't salvage Lanczos.",1);
/* ... save yourselves, men. */
}
j--;
}
vecscale(q[j], 1, n, 1.0 / beta[j], r);
blas_time += lanc_seconds() - time;
time = lanc_seconds();
if (version == 1) {
splarax(Aq, A, n, q[j], vwsqrt, workn);
}
else {
symmlq_(&long_n, &(q[j][1]), &wv1[1], &wv2[1], &wv3[1], &wv4[1], &Aq[1], &wv5[1],
&wv6[1], &checka, &goodb, &precon, &shift, &nout,
&intlim, &rtol, &istop, &itn, &anorm, &acond,
&rnorm, &ynorm, (double *) A, vwsqrt, (double *) orthlist2,
&macheps, &normxlim, &itnmin);
symmlqitns += itn;
if (DEBUG_EVECS > 2) {
printf("Symmlq report: rtol %g\n", rtol);
printf(" system norm %g, solution norm %g\n", anorm, ynorm);
printf(" system condition %g, residual %g\n", acond, rnorm);
printf(" termination condition %2ld, iterations %3ld\n", istop, itn);
}
}
splarax_time += lanc_seconds() - time;
time = lanc_seconds();
update(u, 1, n, Aq, -beta[j], q[j - 1]);
alpha[j] = dot(u, 1, n, q[j]);
update(r, 1, n, u, -alpha[j], q[j]);
blas_time += lanc_seconds() - time;
time = lanc_seconds();
if (vwsqrt == NULL) {
orthog1(r, 1, n);
}
else {
orthogvec(r, 1, n, vwsqrt);
}
orthogonalize(r, n, orthlist);
temp = orthlist;
orthlist = makeorthlnk();
orthlist->vec = q[j];
orthlist->pntr = temp;
beta[j + 1] = ch_norm(r, 1, n);
orthog_time += lanc_seconds() - time;
time = lanc_seconds();
left = j/2;
right = j - left + 1;
if (inc_bis_safety) {
bis_safety *= 10;
inc_bis_safety = FALSE;
}
ritzval_flag = get_ritzvals(alpha, beta+1, j, Anorm, workj+1,
ritz, d, left, right, eigtol, bis_safety);
/* ... have to off-set beta and workj since full orthogonalization
indexes these from 1 to maxj+1 whereas selective orthog.
indexes them from 0 to maxj */
if (ritzval_flag != 0) {
bail("ERROR: Both Sturm bisection and QL failed.",1);
/* ... give up. */
}
ql_time += lanc_seconds() - time;
/* Convergence check using Paige bji estimates. */
time = lanc_seconds();
for (i = 1; i <= j; i++) {
Sres = Tevec(alpha, beta, j, ritz[i], s);
if (Sres > Sres_max) {
Sres_max = Sres;
}
if (Sres > SRESTOL) {
inc_bis_safety = TRUE;
}
bj[i] = s[j] * beta[j + 1];
}
tevec_time += lanc_seconds() - time;
time = lanc_seconds();
if (version == 1) {
scanmin(ritz, 1, j, &scanlist);
}
else {
scanmax(ritz, 1, j, &scanlist);
}
converged = TRUE;
if (j < d)
converged = FALSE;
else {
curlnk = scanlist;
while (curlnk != NULL) {
if (bj[curlnk->indx] > bji_tol) {
converged = FALSE;
}
curlnk = curlnk->pntr;
}
}
scan_time += lanc_seconds() - time;
j++;
}
j--;
/* Collect eigenvalue and bound information. */
time = lanc_seconds();
mkeigvecs(scanlist,lambda,bound,index,bj,d,&Sres_max,alpha,beta+1,j,s,y,n,q);
evec_time += lanc_seconds() - time;
/* Analyze computation for and report additional problems */
time = lanc_seconds();
if (DEBUG_EVECS>0 && version == 2) {
printf("\nTotal Symmlq iterations %3d\n", symmlqitns);
}
if (version == 2) {
for (i = 1; i <= d; i++) {
lambda[i] = 1.0/lambda[i];
}
}
warnings(workn, A, y, n, lambda, vwsqrt, Ares, bound, index,
d, j, maxj, Sres_max, eigtol, u, Anorm, Output_File);
debug_time += lanc_seconds() - time;
/* Free any memory allocated in this routine. */
time = lanc_seconds();
frvec(u, 1);
frvec(r, 1);
frvec(Aq, 1);
frvec(ritzvec, 1);
frvec(zeros, 1);
if (vwsqrt == NULL && version == 2) {
frvec(ones, 1);
}
frvec(workn, 1);
frvec(Ares, 1);
frvec(inv_lambda, 1);
sfree(index);
frvec(alpha, 1);
frvec(beta, 1);
frvec(ritz, 1);
frvec(s, 1);
frvec(bj, 1);
frvec(workj, 1);
if (version == 2) {
frvec(wv1, 0);
}
while (scanlist != NULL) {
curlnk = scanlist->pntr;
sfree(scanlist);
scanlist = curlnk;
}
for (i = 1; i <= j; i++) {
frvec(q[i], 1);
}
while (orthlist != NULL) {
temp = orthlist->pntr;
sfree(orthlist);
orthlist = temp;
}
while (version == 2 && orthlist2 != NULL) {
temp = orthlist2->pntr;
sfree(orthlist2);
orthlist2 = temp;
}
sfree(q);
init_time += lanc_seconds() - time;
}
int
lanczos_ext_float (
struct vtx_data **A, /* sparse matrix in row linked list format */
int n, /* problem size */
int d, /* problem dimension = number of eigvecs to find */
double **y, /* columns of y are eigenvectors of A */
double eigtol, /* tolerance on eigenvectors */
double *vwsqrt, /* square roots of vertex weights */
double maxdeg, /* maximum degree of graph */
int version, /* flags which version of sel. orth. to use */
double *gvec, /* the rhs n-vector in the extended eigen problem */
double sigma /* specifies the norm constraint on extended
eigenvector */
)
{
extern FILE *Output_File; /* output file or null */
extern int LANCZOS_SO_INTERVAL; /* interval between orthogonalizations */
extern int LANCZOS_MAXITNS; /* maximum Lanczos iterations allowed */
extern int DEBUG_EVECS; /* print debugging output? */
extern int DEBUG_TRACE; /* trace main execution path */
extern int WARNING_EVECS; /* print warning messages? */
extern double BISECTION_SAFETY; /* safety factor for T bisection */
extern double SRESTOL; /* resid tol for T evec comp */
extern double DOUBLE_EPSILON; /* machine precision */
extern double DOUBLE_MAX; /* largest double value */
extern double splarax_time; /* time matvec */
extern double orthog_time; /* time orthogonalization work */
extern double evec_time; /* time to generate eigenvectors */
extern double ql_time; /* time tridiagonal eigenvalue work */
extern double blas_time; /* time for blas. linear algebra */
extern double init_time; /* time to allocate, intialize variables */
extern double scan_time; /* time for scanning eval and bound lists */
extern double debug_time; /* time for (some of) debug computations */
extern double ritz_time; /* time to generate ritz vectors */
extern double pause_time; /* time to compute whether to pause */
int i, j, k; /* indicies */
int maxj; /* maximum number of Lanczos iterations */
float *u, *r; /* Lanczos vectors */
double *u_double; /* double version of u */
double *alpha, *beta; /* the Lanczos scalars from each step */
double *ritz; /* copy of alpha for ql */
double *workj; /* work vector, e.g. copy of beta for ql */
float *workn; /* work vector, e.g. product Av for checkeig */
double *workn_double; /* work vector, e.g. product Av for checkeig */
double *s; /* eigenvector of T */
float **q; /* columns of q are Lanczos basis vectors */
double *bj; /* beta(j)*(last el. of corr. eigvec s of T) */
double bis_safety; /* real safety factor for T bisection */
double Sres; /* how well Tevec calculated eigvec s */
double Sres_max; /* Max value of Sres */
int inc_bis_safety; /* need to increase bisection safety */
double *Ares; /* how well Lanczos calc. eigpair lambda,y */
int *index; /* the Ritz index of an eigenpair */
struct orthlink_float **solist; /* vec. of structs with vecs. to orthog. against */
struct scanlink *scanlist; /* linked list of fields to do with min ritz vals */
struct scanlink *curlnk; /* for traversing the scanlist */
double bji_tol; /* tol on bji est. of eigen residual of A */
int converged; /* has the iteration converged? */
double goodtol; /* error tolerance for a good Ritz vector */
int ngood; /* total number of good Ritz pairs at current step */
int maxngood; /* biggest val of ngood through current step */
int left_ngood; /* number of good Ritz pairs on left end */
int lastpause; /* Most recent step with good ritz vecs */
int nopauses; /* Have there been any pauses? */
int interval; /* number of steps between pauses */
double time; /* Current clock time */
int left_goodlim; /* number of ritz pairs checked on left end */
double Anorm; /* Norm estimate of the Laplacian matrix */
int pausemode; /* which Lanczos pausing criterion to use */
int pause; /* whether to pause */
int temp; /* used to prevent redundant index computations */
double *extvec; /* n-vector solving the extended A eigenproblem */
double *v; /* j-vector solving the extended T eigenproblem */
double extval=0.0; /* computed extended eigenvalue (of both A and T) */
double *work1, *work2; /* work vectors */
double check; /* to check an orthogonality condition */
double numerical_zero; /* used for zero in presense of round-off */
int ritzval_flag; /* status flag for get_ritzvals() */
double resid; /* residual */
int memory_ok; /* TRUE until memory runs out */
float *vwsqrt_float = NULL; /* float version of vwsqrt */
struct orthlink_float *makeorthlnk_float(); /* makes space for new entry in orthog. set */
struct scanlink *mkscanlist(); /* init scan list for min ritz vecs */
double *mkvec(); /* allocates space for a vector */
float *mkvec_float(); /* allocates space for a vector */
float *mkvec_ret_float(); /* mkvec() which returns error code */
double dot_float(); /* standard dot product routine */
double ch_norm(); /* vector norm */
double norm_float(); /* vector norm */
double Tevec(); /* calc eigenvector of T by linear recurrence */
double lanc_seconds(); /* switcheable timer */
/* free allocated memory safely */
int lanpause_float(); /* figure when to pause Lanczos iteration */
int get_ritzvals(); /* compute eigenvalues of T */
void setvec(); /* initialize a vector */
void setvec_float(); /* initialize a vector */
void vecscale_float(); /* scale a vector */
void splarax(); /* matrix vector multiply */
void splarax_float(); /* matrix vector multiply */
void update_float(); /* add scalar multiple of a vector to another */
void sorthog_float(); /* orthogonalize vector against list of others */
void bail(); /* our exit routine */
void scanmin(); /* store small values of vector in linked list */
void frvec(); /* free vector */
void frvec_float(); /* free vector */
void scadd(); /* add scalar multiple of vector to another */
void scadd_float(); /* add scalar multiple of vector to another */
void scadd_mixed(); /* add scalar multiple of vector to another */
void orthog1_float(); /* efficiently orthog. against vector of ones */
void solistout_float(); /* print out orthogonalization list */
void doubleout(); /* print a double precision number */
void orthogvec_float(); /* orthogonalize one vector against another */
void double_to_float(); /* copy a double vector to a float vector */
void get_extval(); /* find extended Ritz values */
void scale_diag(); /* scale vector by diagonal matrix */
void scale_diag_float(); /* scale vector by diagonal matrix */
void strout(); /* print string to screen and file */
if (DEBUG_TRACE > 0) {
printf("<Entering lanczos_ext_float>\n");
}
if (DEBUG_EVECS > 0) {
printf("Selective orthogonalization Lanczos for extended eigenproblem, matrix size = %d.\n", n);
}
/* Initialize time. */
time = lanc_seconds();
if (d != 1) {
bail("ERROR: Extended Lanczos only available for bisection.",1);
/* ... something must be wrong upstream. */
}
if (n < d + 1) {
bail("ERROR: System too small for number of eigenvalues requested.",1);
/* ... d+1 since don't use zero eigenvalue pair */
}
/* Allocate space. */
maxj = LANCZOS_MAXITNS;
u = mkvec_float(1, n);
u_double = mkvec(1, n);
r = mkvec_float(1, n);
workn = mkvec_float(1, n);
workn_double = mkvec(1, n);
Ares = mkvec(0, d);
index = smalloc((d + 1) * sizeof(int));
alpha = mkvec(1, maxj);
beta = mkvec(0, maxj);
ritz = mkvec(1, maxj);
s = mkvec(1, maxj);
bj = mkvec(1, maxj);
workj = mkvec(0, maxj);
q = smalloc((maxj + 1) * sizeof(float *));
solist = smalloc((maxj + 1) * sizeof(struct orthlink_float *));
scanlist = mkscanlist(d);
extvec = mkvec(1, n);
v = mkvec(1, maxj);
work1 = mkvec(1, maxj);
work2 = mkvec(1, maxj);
/* Set some constants governing orthogonalization */
ngood = 0;
maxngood = 0;
bji_tol = eigtol;
Anorm = 2 * maxdeg; /* Gershgorin estimate for ||A|| */
goodtol = Anorm * sqrt(DOUBLE_EPSILON); /* Parlett & Scott's bound, p.224 */
interval = 2 + (int) min(LANCZOS_SO_INTERVAL - 2, n / (2 * LANCZOS_SO_INTERVAL));
bis_safety = BISECTION_SAFETY;
numerical_zero = 1.0e-6;
if (DEBUG_EVECS > 0) {
printf(" maxdeg %g\n", maxdeg);
printf(" goodtol %g\n", goodtol);
printf(" interval %d\n", interval);
printf(" maxj %d\n", maxj);
}
/* Make a float copy of vwsqrt */
if (vwsqrt != NULL) {
vwsqrt_float = mkvec_float(0,n);
double_to_float(vwsqrt_float,1,n,vwsqrt);
}
/* Initialize space. */
double_to_float(r,1,n,gvec);
if (vwsqrt_float != NULL) {
scale_diag_float(r,1,n,vwsqrt_float);
}
check = norm_float(r,1,n);
if (vwsqrt_float == NULL) {
orthog1_float(r, 1, n);
}
else {
orthogvec_float(r, 1, n, vwsqrt_float);
}
check = fabs(check - norm_float(r,1,n));
if (check > 10*numerical_zero && WARNING_EVECS > 0) {
strout("WARNING: In terminal propagation, rhs should have no component in the");
printf(" nullspace of the Laplacian, so check val %g should be zero.\n", check);
if (Output_File != NULL) {
fprintf(Output_File,
" nullspace of the Laplacian, so check val %g should be zero.\n",
check);
}
}
beta[0] = norm_float(r, 1, n);
q[0] = mkvec_float(1, n);
setvec_float(q[0], 1, n, 0.0);
setvec(bj, 1, maxj, DOUBLE_MAX);
if (beta[0] < numerical_zero) {
/* The rhs vector, Dg, of the transformed problem is numerically zero or is
in the null space of the Laplacian, so this is not a well posed extended
eigenproblem. Set maxj to zero to force a quick exit but still clean-up
memory and return(1) to indicate to eigensolve that it should call the
default eigensolver routine for the standard eigenproblem. */
maxj = 0;
}
/* Main Lanczos loop. */
j = 1;
lastpause = 0;
pausemode = 1;
left_ngood = 0;
left_goodlim = 0;
converged = FALSE;
Sres_max = 0.0;
inc_bis_safety = FALSE;
nopauses = TRUE;
memory_ok = TRUE;
init_time += lanc_seconds() - time;
while ((j <= maxj) && (!converged) && memory_ok) {
time = lanc_seconds();
/* Allocate next Lanczos vector. If fail, back up to last pause. */
q[j] = mkvec_ret_float(1, n);
if (q[j] == NULL) {
memory_ok = FALSE;
if (DEBUG_EVECS > 0 || WARNING_EVECS > 0) {
strout("WARNING: Lanczos_ext out of memory; computing best approximation available.\n");
}
if (nopauses) {
bail("ERROR: Sorry, can't salvage Lanczos_ext.",1);
/* ... save yourselves, men. */
}
for (i = lastpause+1; i <= j-1; i++) {
frvec_float(q[i], 1);
}
j = lastpause;
}
/* Basic Lanczos iteration */
vecscale_float(q[j], 1, n, (float)(1.0 / beta[j - 1]), r);
blas_time += lanc_seconds() - time;
time = lanc_seconds();
splarax_float(u, A, n, q[j], vwsqrt_float, workn);
splarax_time += lanc_seconds() - time;
time = lanc_seconds();
update_float(r, 1, n, u, (float)(-beta[j - 1]), q[j - 1]);
alpha[j] = dot_float(r, 1, n, q[j]);
update_float(r, 1, n, r, (float)(-alpha[j]), q[j]);
blas_time += lanc_seconds() - time;
/* Selective orthogonalization */
time = lanc_seconds();
if (vwsqrt_float == NULL) {
orthog1_float(r, 1, n);
}
else {
orthogvec_float(r, 1, n, vwsqrt_float);
}
if ((j == (lastpause + 1)) || (j == (lastpause + 2))) {
sorthog_float(r, n, solist, ngood);
}
orthog_time += lanc_seconds() - time;
beta[j] = norm_float(r, 1, n);
time = lanc_seconds();
pause = lanpause_float(j, lastpause, interval, q, n, &pausemode, version, beta[j]);
pause_time += lanc_seconds() - time;
if (pause) {
nopauses = FALSE;
lastpause = j;
/* Compute limits for checking Ritz pair convergence. */
if (version == 2) {
if (left_ngood + 2 > left_goodlim) {
left_goodlim = left_ngood + 2;
}
}
/* Special case: need at least d Ritz vals on left. */
left_goodlim = max(left_goodlim, d);
/* Special case: can't find more than j total Ritz vals. */
if (left_goodlim > j) {
left_goodlim = min(left_goodlim, j);
}
/* Find Ritz vals using faster of Sturm bisection or ql. */
time = lanc_seconds();
if (inc_bis_safety) {
bis_safety *= 10;
inc_bis_safety = FALSE;
}
ritzval_flag = get_ritzvals(alpha, beta, j, Anorm, workj, ritz, d,
left_goodlim, 0, eigtol, bis_safety);
ql_time += lanc_seconds() - time;
if (ritzval_flag != 0) {
bail("ERROR: Lanczos_ext failed in computing eigenvalues of T.",1);
/* ... we recover from this in lanczos_SO, but don't worry here. */
}
/* Scan for minimum evals of tridiagonal. */
time = lanc_seconds();
scanmin(ritz, 1, j, &scanlist);
scan_time += lanc_seconds() - time;
/* Compute Ritz pair bounds at left end. */
time = lanc_seconds();
setvec(bj, 1, j, 0.0);
for (i = 1; i <= left_goodlim; i++) {
Sres = Tevec(alpha, beta - 1, j, ritz[i], s);
if (Sres > Sres_max) {
Sres_max = Sres;
}
if (Sres > SRESTOL) {
inc_bis_safety = TRUE;
}
bj[i] = s[j] * beta[j];
}
ritz_time += lanc_seconds() - time;
/* Show the portion of the spectrum checked for convergence. */
if (DEBUG_EVECS > 2) {
time = lanc_seconds();
printf("\nindex Ritz vals bji bounds\n");
for (i = 1; i <= left_goodlim; i++) {
printf(" %3d", i);
doubleout(ritz[i], 1);
doubleout(bj[i], 1);
printf("\n");
}
printf("\n");
curlnk = scanlist;
while (curlnk != NULL) {
temp = curlnk->indx;
if ((temp > left_goodlim) && (temp < j)) {
printf(" %3d", temp);
doubleout(ritz[temp], 1);
doubleout(bj[temp], 1);
printf("\n");
}
curlnk = curlnk->pntr;
}
printf(" -------------------\n");
printf(" goodtol: %19.16f\n\n", goodtol);
debug_time += lanc_seconds() - time;
}
get_extval(alpha, beta, j, ritz[1], s, eigtol, beta[0], sigma, &extval,
v, work1, work2);
/* check convergence of Ritz pairs */
time = lanc_seconds();
converged = TRUE;
if (j < d)
converged = FALSE;
else {
curlnk = scanlist;
while (curlnk != NULL) {
if (bj[curlnk->indx] > bji_tol) {
converged = FALSE;
}
curlnk = curlnk->pntr;
}
}
scan_time += lanc_seconds() - time;
if (!converged) {
ngood = 0;
left_ngood = 0; /* for setting left_goodlim on next loop */
/* Compute converged Ritz pairs on left end */
time = lanc_seconds();
for (i = 1; i <= left_goodlim; i++) {
if (bj[i] <= goodtol) {
ngood += 1;
left_ngood += 1;
if (ngood > maxngood) {
maxngood = ngood;
solist[ngood] = makeorthlnk_float();
(solist[ngood])->vec = mkvec_float(1, n);
}
(solist[ngood])->index = i;
Sres = Tevec(alpha, beta - 1, j, ritz[i], s);
if (Sres > Sres_max) {
Sres_max = Sres;
}
if (Sres > SRESTOL) {
inc_bis_safety = TRUE;
}
setvec_float((solist[ngood])->vec, 1, n, 0.0);
for (k = 1; k <= j; k++) {
scadd_float((solist[ngood])->vec, 1, n, s[k], q[k]);
}
}
}
ritz_time += lanc_seconds() - time;
if (DEBUG_EVECS > 2) {
time = lanc_seconds();
printf(" j %3d; goodlim lft %2d, rgt %2d; list ",
j, left_goodlim, 0);
solistout_float(solist, n, ngood, j);
printf("---------------------end of iteration---------------------\n\n");
debug_time += lanc_seconds() - time;
}
}
}
j++;
}
j--;
if (DEBUG_EVECS > 0) {
time = lanc_seconds();
if (maxj == 0) {
printf("Not extended eigenproblem -- calling ordinary eigensolver.\n");
}
else {
printf(" Lanczos_ext itns: %d\n",j);
printf(" eigenvalue: %g\n",ritz[1]);
printf(" extended eigenvalue: %g\n",extval);
}
debug_time += lanc_seconds() - time;
}
if (maxj != 0) {
/* Compute (scaled) extended eigenvector. */
time = lanc_seconds();
setvec(y[1], 1, n, 0.0);
for (k = 1; k <= j; k++) {
scadd_mixed(y[1], 1, n, v[k], q[k]);
}
evec_time += lanc_seconds() - time;
/* Note: assign() will scale this y vector back to x (since y = Dx) */
/* Compute and check residual directly. Use the Ay = extval*y + Dg version of
the problem for convenience. Note that u and v are used here as workspace */
time = lanc_seconds();
splarax(workn_double, A, n, y[1], vwsqrt, u_double);
scadd(workn_double, 1, n, -extval, y[1]);
scale_diag(gvec,1,n,vwsqrt);
scadd(workn_double, 1, n, -1.0, gvec);
resid = ch_norm(workn_double, 1, n);
if (DEBUG_EVECS > 0) {
printf(" extended residual: %g\n",resid);
if (Output_File != NULL) {
fprintf(Output_File, " extended residual: %g\n",resid);
}
}
if (WARNING_EVECS > 0 && resid > eigtol) {
printf("WARNING: Extended residual (%g) greater than tolerance (%g).\n",
resid, eigtol);
if (Output_File != NULL) {
fprintf(Output_File,
"WARNING: Extended residual (%g) greater than tolerance (%g).\n",
resid, eigtol);
}
}
debug_time += lanc_seconds() - time;
}
/* free up memory */
time = lanc_seconds();
frvec_float(u, 1);
frvec(u_double, 1);
frvec_float(r, 1);
frvec_float(workn, 1);
frvec(workn_double, 1);
frvec(Ares, 0);
sfree(index);
frvec(alpha, 1);
frvec(beta, 0);
frvec(ritz, 1);
frvec(s, 1);
frvec(bj, 1);
frvec(workj, 0);
for (i = 0; i <= j; i++) {
frvec_float(q[i], 1);
}
sfree(q);
while (scanlist != NULL) {
curlnk = scanlist->pntr;
sfree(scanlist);
scanlist = curlnk;
}
for (i = 1; i <= maxngood; i++) {
frvec_float((solist[i])->vec, 1);
sfree(solist[i]);
}
sfree(solist);
frvec(extvec, 1);
frvec(v, 1);
frvec(work1, 1);
frvec(work2, 1);
if (vwsqrt != NULL)
frvec_float(vwsqrt_float, 1);
init_time += lanc_seconds() - time;
if (maxj == 0) return(1); /* see note on beta[0] and maxj above */
else return(0);
}
VOID int21_service(iregs FAR * r)
{
COUNT rc = 0,
rc1;
psp FAR *p = MK_FP(cu_psp, 0);
void FAR *FP_DS_DX = MK_FP(r->DS, r->DX); /* this is saved so often,
that this saves ~100 bytes */
#define CLEAR_CARRY_FLAG() r->FLAGS &= ~FLG_CARRY
#define SET_CARRY_FLAG() r->FLAGS |= FLG_CARRY
p->ps_stack = (BYTE FAR *) r;
#ifdef DEBUG
if (bDumpRegs)
{
fbcopy((VOID FAR *) user_r, (VOID FAR *) & error_regs, sizeof(iregs));
printf("System call (21h): %02x\n", user_r->AX);
dump_regs = TRUE;
dump();
}
#endif
if(r->AH >=0x38 && r->AH <= 0x4F)
CLEAR_CARRY_FLAG();
/* Clear carry by default for these functions */
dispatch:
/* Check for Ctrl-Break */
switch (r->AH)
{
default:
if (!break_ena)
break;
case 0x01:
case 0x02:
case 0x03:
case 0x04:
case 0x05:
case 0x08:
case 0x09:
case 0x0a:
case 0x0b:
if (control_break())
handle_break();
}
/* The dispatch handler */
switch (r->AH)
{
/* int 21h common error handler */
case 0x64:
error_invalid:
r->AX = -DE_INVLDFUNC;
goto error_out;
error_exit:
r->AX = -rc;
error_out:
CritErrCode = r->AX; /* Maybe set */
SET_CARRY_FLAG();
break;
/* case 0x00: --> Simulate a DOS-4C-00 */
/* Read Keyboard with Echo */
case 0x01:
r->AL = _sti(TRUE);
sto(r->AL);
break;
/* Display Character */
case 0x02:
sto(r->DL);
break;
/* Auxiliary Input */
case 0x03:
{
COUNT scratch;
GenericRead(STDAUX, 1, (BYTE FAR *) & r->AL, (COUNT FAR *) & scratch, TRUE);
break;
}
/* Auxiliary Output */
case 0x04:
{
COUNT scratch;
DosWrite(STDAUX, 1, (BYTE FAR *) & r->DL, (COUNT FAR *) &scratch);
break;
}
/* Print Character */
case 0x05:
{
COUNT scratch;
DosWrite(STDPRN, 1, (BYTE FAR *) & r->DL, (COUNT FAR *) &scratch);
break;
}
/* Direct Console I/O */
case 0x06:
if (r->DL != 0xff)
sto(r->DL);
else if (StdinBusy())
{
r->AL = 0x00;
r->FLAGS |= FLG_ZERO;
}
else
{
r->FLAGS &= ~FLG_ZERO;
r->AL = _sti(FALSE);
}
break;
/* Direct Console Input */
case 0x07:
r->AL = _sti(FALSE);
break;
/* Read Keyboard Without Echo */
case 0x08:
r->AL = _sti(TRUE);
break;
/* Display String */
case 0x09:
{
BYTE FAR * q;
q = FP_DS_DX;
while (*q != '$')
++q;
DosWrite(STDOUT, FP_OFF(q) - FP_OFF(FP_DS_DX), FP_DS_DX, (COUNT FAR *) & UnusedRetVal);
}
r->AL = '$';
break;
/* Buffered Keyboard Input */
case 0x0a:
sti_0a((keyboard FAR *) FP_DS_DX);
break;
/* Check Stdin Status */
case 0x0b:
if (StdinBusy())
r->AL = 0x00;
else
r->AL = 0xFF;
break;
/* Flush Buffer, Read Keayboard */
case 0x0c:
KbdFlush();
switch (r->AL)
{
case 0x01:
case 0x06:
case 0x07:
case 0x08:
case 0x0a:
r->AH = r->AL;
goto dispatch;
default:
r->AL = 0x00;
break;
}
break;
/* Reset Drive */
case 0x0d:
flush();
break;
/* Set Default Drive */
case 0x0e:
r->AL = DosSelectDrv(r->DL);
break;
case 0x0f:
if (FcbOpen(FP_DS_DX))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x10:
if (FcbClose(FP_DS_DX))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x11:
if (FcbFindFirst(FP_DS_DX))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x12:
if (FcbFindNext(FP_DS_DX))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x13:
if (FcbDelete(FP_DS_DX))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x14:
{
if (FcbRead(FP_DS_DX, &CritErrCode))
r->AL = 0;
else
r->AL = CritErrCode;
break;
}
case 0x15:
{
if (FcbWrite(FP_DS_DX, &CritErrCode))
r->AL = 0;
else
r->AL = CritErrCode;
break;
}
case 0x16:
if (FcbCreate(FP_DS_DX))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x17:
if (FcbRename(FP_DS_DX))
r->AL = 0;
else
r->AL = 0xff;
break;
default:
#ifdef DEBUG
printf("Unsupported INT21 AH = 0x%x, AL = 0x%x.\n", r->AH, r->AL);
#endif
/* Fall through. */
/* CP/M compatibility functions */
case 0x18:
case 0x1d:
case 0x1e:
case 0x20:
#ifndef TSC
case 0x61:
#endif
case 0x6b:
r->AL = 0;
break;
/* Get Default Drive */
case 0x19:
r->AL = default_drive;
break;
/* Set DTA */
case 0x1a:
{
psp FAR *p = MK_FP(cu_psp, 0);
p->ps_dta = FP_DS_DX;
dos_setdta(p->ps_dta);
}
break;
/* Get Default Drive Data */
case 0x1b:
{
BYTE FAR *p;
FatGetDrvData(0,
(COUNT FAR *) & r->AX,
(COUNT FAR *) & r->CX,
(COUNT FAR *) & r->DX,
(BYTE FAR **) & p);
r->DS = FP_SEG(p);
r->BX = FP_OFF(p);
}
break;
/* Get Drive Data */
case 0x1c:
{
BYTE FAR *p;
FatGetDrvData(r->DL,
(COUNT FAR *) & r->AX,
(COUNT FAR *) & r->CX,
(COUNT FAR *) & r->DX,
(BYTE FAR **) & p);
r->DS = FP_SEG(p);
r->BX = FP_OFF(p);
}
break;
/* Get default DPB */
/* case 0x1f: see case 0x32 */
/* Random read using FCB */
case 0x21:
{
if (FcbRandomIO(FP_DS_DX, &CritErrCode, FcbRead))
r->AL = 0;
else
r->AL = CritErrCode;
break;
}
/* Random write using FCB */
case 0x22:
{
if (FcbRandomIO(FP_DS_DX, &CritErrCode, FcbWrite))
r->AL = 0;
else
r->AL = CritErrCode;
break;
}
/* Get file size in records using FCB */
case 0x23:
if (FcbGetFileSize(FP_DS_DX))
r->AL = 0;
else
r->AL = 0xff;
break;
/* Set random record field in FCB */
case 0x24:
FcbSetRandom(FP_DS_DX);
break;
/* Set Interrupt Vector */
case 0x25:
{
VOID(INRPT FAR * p) () = FP_DS_DX;
setvec(r->AL, p);
}
break;
/* Dos Create New Psp */
case 0x26:
{
psp FAR *p = MK_FP(cu_psp, 0);
new_psp((psp FAR *) MK_FP(r->DX, 0), p->ps_size);
}
break;
/* Read random record(s) using FCB */
case 0x27:
{
if (FcbRandomBlockRead(FP_DS_DX, r->CX, &CritErrCode))
r->AL = 0;
else
r->AL = CritErrCode;
break;
}
/* Write random record(s) using FCB */
case 0x28:
{
if (FcbRandomBlockWrite(FP_DS_DX, r->CX, &CritErrCode))
r->AL = 0;
else
r->AL = CritErrCode;
break;
}
/* Parse File Name */
case 0x29:
{
BYTE FAR *lpFileName;
lpFileName = MK_FP(r->DS, r->SI);
r->AL = FcbParseFname(r->AL,
&lpFileName,
MK_FP(r->ES, r->DI));
r->DS = FP_SEG(lpFileName);
r->SI = FP_OFF(lpFileName);
}
break;
/* Get Date */
case 0x2a:
DosGetDate(
(BYTE FAR *) & (r->AL), /* WeekDay */
(BYTE FAR *) & (r->DH), /* Month */
(BYTE FAR *) & (r->DL), /* MonthDay */
(COUNT FAR *) & (r->CX)); /* Year */
break;
/* Set Date */
case 0x2b:
rc = DosSetDate(
(BYTE FAR *) & (r->DH), /* Month */
(BYTE FAR *) & (r->DL), /* MonthDay */
(COUNT FAR *) & (r->CX)); /* Year */
if (rc != SUCCESS)
r->AL = 0xff;
else
r->AL = 0;
break;
/* Get Time */
case 0x2c:
DosGetTime(
(BYTE FAR *) & (r->CH), /* Hour */
(BYTE FAR *) & (r->CL), /* Minutes */
(BYTE FAR *) & (r->DH), /* Seconds */
(BYTE FAR *) & (r->DL)); /* Hundredths */
break;
/* Set Date */
case 0x2d:
rc = DosSetTime(
(BYTE FAR *) & (r->CH), /* Hour */
(BYTE FAR *) & (r->CL), /* Minutes */
(BYTE FAR *) & (r->DH), /* Seconds */
(BYTE FAR *) & (r->DL)); /* Hundredths */
if (rc != SUCCESS)
r->AL = 0xff;
else
r->AL = 0;
break;
/* Set verify flag */
case 0x2e:
verify_ena = (r->AL ? TRUE : FALSE);
break;
/* Get DTA */
case 0x2f:
r->ES = FP_SEG(dta);
r->BX = FP_OFF(dta);
break;
/* Get DOS Version */
case 0x30:
r->AL = os_major;
r->AH = os_minor;
r->BH = OEM_ID;
r->CH = REVISION_MAJOR; /* JPP */
r->CL = REVISION_MINOR;
r->BL = REVISION_SEQ;
if (ReturnAnyDosVersionExpected)
{
/* TE for testing purpose only and NOT
to be documented:
return programs, who ask for version == XX.YY
exactly this XX.YY.
this makes most MS programs more happy.
*/
UBYTE FAR *retp = MK_FP(r->cs, r->ip);
if ( retp[0] == 0x3d && /* cmp ax, xxyy */
(retp[3] == 0x75 || retp[3] == 0x74)) /* je/jne error */
{
r->AL = retp[1];
r->AH = retp[2];
}
else if(retp[0] == 0x86 && /* xchg al,ah */
retp[1] == 0xc4 &&
retp[2] == 0x3d && /* cmp ax, xxyy */
(retp[5] == 0x75 || retp[5] == 0x74)) /* je/jne error */
{
r->AL = retp[4];
r->AH = retp[3];
}
}
break;
/* Keep Program (Terminate and stay resident) */
case 0x31:
DosMemChange(cu_psp, r->DX < 6 ? 6 : r->DX, 0);
return_mode = 3;
return_code = r->AL;
tsr = TRUE;
return_user();
break;
/* Get default BPB */
case 0x1f:
/* Get DPB */
case 0x32:
/* r->DL is NOT changed by MS 6.22 */
/* INT21/32 is documented to reread the DPB */
{
struct dpb FAR *dpb;
UCOUNT drv = r->DL;
if (drv == 0 || r->AH == 0x1f) drv = default_drive;
else drv--;
if (drv >= lastdrive)
{
r->AL = 0xFF;
CritErrCode = 0x0f;
break;
}
dpb = CDSp->cds_table[drv].cdsDpb;
if (dpb == 0 ||
CDSp->cds_table[drv].cdsFlags & CDSNETWDRV)
{
r->AL = 0xFF;
CritErrCode = 0x0f;
break;
}
dpb->dpb_flags = M_CHANGED; /* force reread of drive BPB/DPB */
if (media_check(dpb) < 0)
{
r->AL = 0xff;
CritErrCode = 0x0f;
break;
}
r->DS = FP_SEG(dpb);
r->BX = FP_OFF(dpb);
r->AL = 0;
}
break;
/*
case 0x33:
see int21_syscall
*/
/* Get InDOS flag */
case 0x34:
{
BYTE FAR *p;
p = (BYTE FAR *) ((BYTE *) & InDOS);
r->ES = FP_SEG(p);
r->BX = FP_OFF(p);
}
break;
/* Get Interrupt Vector */
case 0x35:
{
BYTE FAR *p;
p = getvec((COUNT) r->AL);
r->ES = FP_SEG(p);
r->BX = FP_OFF(p);
}
break;
/* Dos Get Disk Free Space */
case 0x36:
DosGetFree(
r->DL,
(COUNT FAR *) & r->AX,
(COUNT FAR *) & r->BX,
(COUNT FAR *) & r->CX,
(COUNT FAR *) & r->DX);
break;
/* Undocumented Get/Set Switchar */
case 0x37:
switch (r->AL)
{
/* Get switch character */
case 0x00:
r->DL = switchar;
r->AL = 0x00;
break;
/* Set switch character */
case 0x01:
switchar = r->DL;
r->AL = 0x00;
break;
default:
goto error_invalid;
}
break;
/* Get/Set Country Info */
case 0x38:
{
UWORD cntry = r->AL;
if(cntry == 0)
cntry = (UWORD)-1;
else if(cntry == 0xff)
cntry = r->BX;
if (0xffff == r->DX) {
/* Set Country Code */
if((rc = DosSetCountry(cntry)) < 0)
goto error_invalid;
} else {
/* Get Country Information */
if((rc = DosGetCountryInformation(cntry, FP_DS_DX)) < 0)
goto error_invalid;
/* HACK FIXME */
if(cntry == (UWORD)-1)
cntry = 1;
/* END OF HACK */
r->AX = r->BX = cntry;
}
}
break;
/* Dos Create Directory */
case 0x39:
rc = DosMkdir((BYTE FAR *) FP_DS_DX);
if (rc != SUCCESS)
goto error_exit;
break;
/* Dos Remove Directory */
case 0x3a:
rc = DosRmdir((BYTE FAR *) FP_DS_DX);
if (rc != SUCCESS)
goto error_exit;
break;
/* Dos Change Directory */
case 0x3b:
if ((rc = DosChangeDir((BYTE FAR *) FP_DS_DX)) < 0)
goto error_exit;
break;
/* Dos Create File */
case 0x3c:
if ((rc = DosCreat(FP_DS_DX, r->CX)) < 0)
goto error_exit;
else
r->AX = rc;
break;
/* Dos Open */
case 0x3d:
if ((rc = DosOpen(FP_DS_DX, r->AL)) < 0)
goto error_exit;
else
r->AX = rc;
break;
/* Dos Close */
case 0x3e:
if ((rc = DosClose(r->BX)) < 0)
goto error_exit;
break;
/* Dos Read */
case 0x3f:
rc1 = DosRead(r->BX, r->CX, FP_DS_DX, (COUNT FAR *) & rc);
if (rc != SUCCESS)
goto error_exit;
else
r->AX = rc1;
break;
/* Dos Write */
case 0x40:
rc1 = DosWrite(r->BX, r->CX, FP_DS_DX, (COUNT FAR *) & rc);
if (rc != SUCCESS)
goto error_exit;
else
r->AX = rc1;
break;
/* Dos Delete File */
case 0x41:
rc = DosDelete((BYTE FAR *) FP_DS_DX);
if (rc < 0)
goto error_exit;
break;
/* Dos Seek */
case 0x42:
{
ULONG lrc;
if ((rc = DosSeek(r->BX, (LONG) ((((LONG) (r->CX)) << 16) + r->DX), r->AL, &lrc)) < 0)
goto error_exit;
else
{
r->DX = (lrc >> 16);
r->AX = (UWORD)lrc;
}
}
break;
/* Get/Set File Attributes */
case 0x43:
switch (r->AL)
{
case 0x00:
rc = DosGetFattr((BYTE FAR *) FP_DS_DX);
if (rc >= SUCCESS)
r->CX = rc;
break;
case 0x01:
rc = DosSetFattr((BYTE FAR *) FP_DS_DX, r->CX);
break;
default:
goto error_invalid;
}
if (rc < SUCCESS)
goto error_exit;
break;
/* Device I/O Control */
case 0x44:
rc = DosDevIOctl(r);
if (rc != SUCCESS)
goto error_exit;
break;
/* Duplicate File Handle */
case 0x45:
rc = DosDup(r->BX);
if (rc < SUCCESS)
goto error_exit;
else
r->AX = rc;
break;
/* Force Duplicate File Handle */
case 0x46:
rc = DosForceDup(r->BX, r->CX);
if (rc < SUCCESS)
goto error_exit;
break;
/* Get Current Directory */
case 0x47:
if ((rc = DosGetCuDir(r->DL, MK_FP(r->DS, r->SI))) < 0)
goto error_exit;
else
r->AX = 0x0100; /*jpp: from interrupt list */
break;
/* Allocate memory */
case 0x48:
if ((rc = DosMemAlloc(r->BX, mem_access_mode, &(r->AX), &(r->BX))) < 0)
{
DosMemLargest(&(r->BX));
goto error_exit;
}
else
++(r->AX); /* DosMemAlloc() returns seg of MCB rather than data */
break;
/* Free memory */
case 0x49:
if ((rc = DosMemFree((r->ES) - 1)) < 0)
goto error_exit;
break;
/* Set memory block size */
case 0x4a:
{
UWORD maxSize;
if ((rc = DosMemChange(r->ES, r->BX, &maxSize)) < 0)
{
if (rc == DE_NOMEM)
r->BX = maxSize;
#if 0
if (cu_psp == r->ES)
{
psp FAR *p;
p = MK_FP(cu_psp, 0);
p->ps_size = r->BX + cu_psp;
}
#endif
goto error_exit;
}
break;
}
/* Load and Execute Program */
case 0x4b:
break_flg = FALSE;
if ((rc = DosExec(r->AL, MK_FP(r->ES, r->BX), FP_DS_DX))
!= SUCCESS)
goto error_exit;
break;
/* Terminate Program */
case 0x00:
r->AX = 0x4c00;
/* End Program */
case 0x4c:
if (cu_psp == RootPsp
|| ((psp FAR *) (MK_FP(cu_psp, 0)))->ps_parent == cu_psp)
break;
tsr = FALSE;
if (ErrorMode)
{
ErrorMode = FALSE;
return_mode = 2;
}
else if (break_flg)
{
break_flg = FALSE;
return_mode = 1;
}
else
{
return_mode = 0;
}
return_code = r->AL;
if (DosMemCheck() != SUCCESS)
panic("MCB chain corrupted");
#ifdef TSC
StartTrace();
#endif
return_user();
break;
/* Get Child-program Return Value */
case 0x4d:
r->AL = return_code;
r->AH = return_mode;
break;
/* Dos Find First */
case 0x4e:
/* dta for this call is set on entry. This */
/* needs to be changed for new versions. */
if ((rc = DosFindFirst((UCOUNT) r->CX, (BYTE FAR *) FP_DS_DX)) < 0)
goto error_exit;
r->AX = 0;
break;
/* Dos Find Next */
case 0x4f:
/* dta for this call is set on entry. This */
/* needs to be changed for new versions. */
if ((rc = DosFindNext()) < 0)
{
if (rc == DE_FILENOTFND)
rc = DE_NFILES;
goto error_exit;
}
else
r->AX = -SUCCESS;
break;
/*
case 0x50:
case 0x51:
see int21_syscall
*/
/* ************UNDOCUMENTED************************************* */
/* Get List of Lists */
case 0x52:
{
BYTE FAR *p;
p = (BYTE FAR *) & DPBp;
r->ES = FP_SEG(p);
r->BX = FP_OFF(p);
}
break;
case 0x53:
/* DOS 2+ internal - TRANSLATE BIOS PARAMETER BLOCK TO DRIVE PARAM BLOCK */
bpb_to_dpb((bpb FAR *)MK_FP(r->DS, r->SI), (struct dpb FAR *)MK_FP(r->ES, r->BP));
break;
/* Get verify state */
case 0x54:
r->AL = (verify_ena ? TRUE : FALSE);
break;
/* ************UNDOCUMENTED************************************* */
/* Dos Create New Psp & set p_size */
case 0x55:
new_psp((psp FAR *) MK_FP(r->DX, 0), r->SI);
cu_psp = r->DX;
break;
/* Dos Rename */
case 0x56:
rc = DosRename((BYTE FAR *) FP_DS_DX, (BYTE FAR *) MK_FP(r->ES, r->DI));
if (rc < SUCCESS)
goto error_exit;
else
CLEAR_CARRY_FLAG();
break;
/* Get/Set File Date and Time */
case 0x57:
CLEAR_CARRY_FLAG();
switch (r->AL)
{
case 0x00:
rc = DosGetFtime(
(COUNT) r->BX, /* Handle */
(date FAR *) & r->DX, /* FileDate */
(time FAR *) & r->CX); /* FileTime */
if (rc < SUCCESS)
goto error_exit;
break;
case 0x01:
rc = DosSetFtime(
(COUNT) r->BX, /* Handle */
(date) r->DX, /* FileDate */
(time) r->CX); /* FileTime */
if (rc < SUCCESS)
goto error_exit;
break;
default:
goto error_invalid;
}
break;
/* Get/Set Allocation Strategy */
case 0x58:
CLEAR_CARRY_FLAG();
switch (r->AL)
{
case 0x00:
r->AL = mem_access_mode;
r->AH = 0;
break;
case 0x01:
{
switch (r->BL)
{
case LAST_FIT:
case LAST_FIT_U:
case LAST_FIT_UO:
case BEST_FIT:
case BEST_FIT_U:
case BEST_FIT_UO:
case FIRST_FIT:
case FIRST_FIT_U:
case FIRST_FIT_UO:
mem_access_mode = r->BL;
break;
default:
goto error_invalid;
}
}
break;
case 0x02:
r->AL = uppermem_link;
break;
case 0x03:
if (uppermem_root) {
DosUmbLink(r->BL);
break;
} /* else fall through */
default:
goto error_invalid;
#ifdef DEBUG
case 0xff:
show_chain();
break;
#endif
}
break;
/* Get Extended Error */
case 0x59:
r->AX = CritErrCode;
r->ES = FP_SEG(CritErrDev);
r->DI = FP_OFF(CritErrDev);
r->CH = CritErrLocus;
r->BH = CritErrClass;
r->BL = CritErrAction;
CLEAR_CARRY_FLAG();
break;
/* Create Temporary File */
case 0x5a:
if ((rc = DosMkTmp(FP_DS_DX, r->CX)) < 0)
goto error_exit;
else
{
r->AX = rc;
CLEAR_CARRY_FLAG();
}
break;
/* Create New File */
case 0x5b:
if (!IsDevice(FP_DS_DX) && (rc = DosOpen(FP_DS_DX, 0)) >= 0)
{
DosClose(rc);
r->AX = 80;
goto error_out;
}
else
{
if ((rc = DosCreat(FP_DS_DX, r->CX)) < 0)
goto error_exit;
else
{
r->AX = rc;
CLEAR_CARRY_FLAG();
}
}
break;
/* /// Added for SHARE. - Ron Cemer */
/* Lock/unlock file access */
case 0x5c:
if ((rc = DosLockUnlock
(r->BX,
(((unsigned long)r->CX)<<16)|(((unsigned long)r->DX)&0xffffL),
(((unsigned long)r->SI)<<16)|(((unsigned long)r->DI)&0xffffL),
((r->AX & 0xff) != 0))) != 0)
goto error_exit;
CLEAR_CARRY_FLAG();
break;
/* /// End of additions for SHARE. - Ron Cemer */
/* UNDOCUMENTED: server, share.exe and sda function */
case 0x5d:
switch (r->AL)
{
/* Remote Server Call */
case 0x00:
{
UWORD FAR *x = FP_DS_DX;
r->AX = x[0];
r->BX = x[1];
r->CX = x[2];
r->DX = x[3];
r->SI = x[4];
r->DI = x[5];
r->DS = x[6];
r->ES = x[7];
}
goto dispatch;
case 0x06:
r->DS = FP_SEG(internal_data);
r->SI = FP_OFF(internal_data);
r->CX = swap_always - internal_data;
r->DX = swap_indos - internal_data;
CLEAR_CARRY_FLAG();
break;
case 0x07:
case 0x08:
case 0x09:
rc = -int2f_Remote_call(REM_PRINTREDIR, 0, 0, r->DX, 0, 0, (MK_FP(0, Int21AX)));
if (rc != SUCCESS)
goto error_exit;
CLEAR_CARRY_FLAG();
break;
default:
goto error_invalid;
}
break;
case 0x5e:
CLEAR_CARRY_FLAG();
switch (r->AL)
{
case 0x00:
r->CX = get_machine_name(FP_DS_DX);
break;
case 0x01:
set_machine_name(FP_DS_DX, r->CX);
break;
default:
rc = -int2f_Remote_call(REM_PRINTSET, r->BX, r->CX, r->DX, (MK_FP(r->ES, r->DI)), r->SI, (MK_FP(r->DS, Int21AX)));
if (rc != SUCCESS) goto error_exit;
r->AX=SUCCESS;
break;
}
break;
case 0x5f:
CLEAR_CARRY_FLAG();
switch (r->AL)
{
case 0x07:
if (r->DL < lastdrive) {
CDSp->cds_table[r->DL].cdsFlags |= 0x100;
}
break;
case 0x08:
if (r->DL < lastdrive) {
CDSp->cds_table[r->DL].cdsFlags &= ~0x100;
}
break;
default:
/*
void int_2f_111e_call(iregs FAR *r);
int_2f_111e_call(r);
break;*/
rc = -int2f_Remote_call(REM_DOREDIRECT, r->BX, r->CX, r->DX,
(MK_FP(r->ES, r->DI)), r->SI, (MK_FP(r->DS, Int21AX)));
if (rc != SUCCESS)
goto error_exit;
r->AX=SUCCESS;
break;
}
break;
case 0x60: /* TRUENAME */
CLEAR_CARRY_FLAG();
if ((rc = truename(MK_FP(r->DS, r->SI),
adjust_far(MK_FP(r->ES, r->DI)), FALSE)) != SUCCESS)
goto error_exit;
break;
#ifdef TSC
/* UNDOCUMENTED: no-op */
/* */
/* DOS-C: tsc support */
case 0x61:
#ifdef DEBUG
switch (r->AL)
{
case 0x01:
bTraceNext = TRUE;
break;
case 0x02:
bDumpRegs = FALSE;
break;
}
#endif
r->AL = 0x00;
break;
#endif
/* UNDOCUMENTED: return current psp
case 0x62: is in int21_syscall
r->BX = cu_psp;
break;
*/
/* UNDOCUMENTED: Double byte and korean tables */
case 0x63:
{
#define DBLBYTE
#ifdef DBLBYTE
static char dbcsTable[2] =
{
0, 0
};
void FAR *dp = &dbcsTable;
r->DS = FP_SEG(dp);
r->SI = FP_OFF(dp);
r->AL = 0;
#else
/* not really supported, but will pass. */
r->AL = 0x00; /*jpp: according to interrupt list */
/*Bart: fails for PQDI: use the above again */
#endif
break;
}
/*
case 0x64:
see above (invalid)
*/
/* Extended country info */
case 0x65:
switch(r->AL) {
case 0x20: /* upcase single character */
r->DL = DosUpChar(r->DL);
break;
case 0x21: /* upcase memory area */
DosUpMem(FP_DS_DX, r->CX);
break;
case 0x22: /* upcase ASCIZ */
DosUpString(FP_DS_DX);
break;
case 0xA0: /* upcase single character of filenames */
r->DL = DosUpFChar(r->DL);
break;
case 0xA1: /* upcase memory area of filenames */
DosUpFMem(FP_DS_DX, r->CX);
break;
case 0xA2: /* upcase ASCIZ of filenames */
DosUpFString(FP_DS_DX);
break;
case 0x23: /* check Yes/No response */
r->AX = DosYesNo(r->DL);
break;
default:
if ((rc = DosGetData(
r->AL, r->BX, r->DX, r->CX,
MK_FP(r->ES, r->DI))) < 0) {
#ifdef NLS_DEBUG
printf("DosGetData() := %d\n", rc);
#endif
goto error_exit;
}
#ifdef NLS_DEBUG
printf("DosGetData() returned successfully\n", rc);
#endif
break;
}
CLEAR_CARRY_FLAG();
break;
/* Code Page functions */
case 0x66: {
int rc;
switch (r->AL)
{
case 1:
rc = DosGetCodepage(&r->BX, &r->DX);
break;
case 2:
rc = DosSetCodepage(r->BX, r->DX);
break;
default:
goto error_invalid;
}
if(rc != SUCCESS)
goto error_exit;
CLEAR_CARRY_FLAG();
break;
}
/* Set Max file handle count */
case 0x67:
if ((rc = SetJFTSize(r->BX)) != SUCCESS)
goto error_exit;
else
CLEAR_CARRY_FLAG();
break;
/* Flush file buffer -- COMMIT FILE -- dummy function right now. */
case 0x68:
case 0x6a:
CLEAR_CARRY_FLAG();
break;
/* Get/Set Serial Number */
case 0x69:
rc = ( r->BL == 0 ? default_drive : r->BL - 1);
if (rc < lastdrive)
{
UWORD saveCX = r->CX;
if (CDSp->cds_table[rc].cdsFlags & CDSNETWDRV) {
goto error_invalid;
}
switch(r->AL){
case 0x00:
r->AL = 0x0d;
r->CX = 0x0866;
rc = DosDevIOctl(r);
break;
case 0x01:
r->AL = 0x0d;
r->CX = 0x0846;
rc = DosDevIOctl(r);
break;
}
r->CX = saveCX;
if (rc != SUCCESS)
goto error_exit;
CLEAR_CARRY_FLAG();
break;
}
else
r->AL = 0xFF;
break;
/*
case 0x6a: see case 0x68
case 0x6b: dummy func: return AL=0
*/
/* Extended Open-Creat, not fully functional. (bits 4,5,6 of BH) */
case 0x6c:
{
COUNT x = 0;
if (r->AL != 0 || r->DH != 0 ||
(r->DL&0x0f) > 0x2 || (r->DL&0xf0) > 0x10)
goto error_invalid;
CLEAR_CARRY_FLAG();
if ((rc = DosOpen(MK_FP(r->DS, r->SI),
(r->DL&0x0f) == 0x1 ? r->BL : 0)) < 0)
{
if (r->DL < 0x10)
goto error_exit;
/* else try to create below */
}
else switch (r->DL & 0x0f)
{
case 0x0:
/* fail if file exists */
DosClose(rc);
rc = DE_FILEEXISTS;
goto error_exit;
case 0x1:
/* file exists and opened: OK */
r->CX = 0x01;
goto break_out;
case 0x2:
/* file exists: replace/open */
DosClose(rc);
x = 1;
break;
}
/* cases 0x00, 0x01 are finished now */
if ((rc = DosCreat(MK_FP(r->DS, r->SI), r->CX)) < 0)
goto error_exit;
r->CX = x+2;
break_out:
r->AX = rc;
break;
}
/* case 0x6d and above not implemented : see default; return AL=0 */
}
#ifdef DEBUG
if (bDumpRegs)
{
fbcopy((VOID FAR *) user_r, (VOID FAR *) & error_regs,
sizeof(iregs));
dump_regs = TRUE;
dump();
}
#endif
}
void mexFunction(int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[] )
{ mxArray *blk_cell_pr;
double *Avec, *idxstarttmp, *nzlistAtmp, *permAtmp, *U, *V, *schur;
double *blksizetmp, *Utmp, *Vtmp, *schurcol, *nzschur, *P;
mwIndex *irP, *jcP, *irU, *jcU, *irV, *jcV;
int *idxstart, *colm, *permA, *nzlistAr, *nzlistAc;
int *nzlistAi, *nzlistAj, *blksize, *cumblksize, *blknnz, *blkidx;
mwIndex subs[2];
mwSize nsubs=2;
int index, colend, type, isspU, isspV, numblk, nzP, existP;
int len, row, col, nU, nV, n, m, m1, idx1, idx2, l, k, nsub, n1, n2, opt, opt2;
int kstart, kend, rb, cb, cblk, colcb, count;
double tmp;
/* CHECK THE DIMENSIONS */
if (nrhs < 10) {
mexErrMsgTxt(" mexschur: must have at least 10 inputs"); }
if (!mxIsCell(prhs[0])) {
mexErrMsgTxt("mexschur: 1ST input must be the cell array blk"); }
if (mxGetM(prhs[0])>1) {
mexErrMsgTxt("mexschur: blk can have only 1 row"); }
subs[0] = 0;
subs[1] = 1;
index = mxCalcSingleSubscript(prhs[0],nsubs,subs);
blk_cell_pr = mxGetCell(prhs[0],index);
numblk = mxGetN(blk_cell_pr);
blksizetmp = mxGetPr(blk_cell_pr);
blksize = mxCalloc(numblk,sizeof(int));
for (k=0; k<numblk; k++) {
blksize[k] = (int)blksizetmp[k];
}
/**** get pointers ****/
Avec = mxGetPr(prhs[1]);
if (!mxIsSparse(prhs[1])) {
mexErrMsgTxt("mexschur: Avec must be sparse"); }
idxstarttmp = mxGetPr(prhs[2]);
len = MAX(mxGetM(prhs[2]),mxGetN(prhs[2]));
idxstart = mxCalloc(len,sizeof(int));
for (k=0; k<len; k++) {
idxstart[k] = (int)idxstarttmp[k];
}
nzlistAtmp = mxGetPr(prhs[3]);
len = mxGetM(prhs[3]);
nzlistAi = mxCalloc(len,sizeof(int));
nzlistAj = mxCalloc(len,sizeof(int));
for (k=0; k<len; k++) {
nzlistAi[k] = (int)nzlistAtmp[k] -1; /* -1 to adjust for matlab index */
nzlistAj[k] = (int)nzlistAtmp[k+len] -1;
}
permAtmp = mxGetPr(prhs[4]);
m1 = mxGetN(prhs[4]);
permA = mxCalloc(m1,sizeof(int));
for (k=0; k<m1; k++) {
permA[k] = (int)permAtmp[k]-1; /* -1 to adjust for matlab index */
}
U = mxGetPr(prhs[5]); nU = mxGetM(prhs[5]);
isspU = mxIsSparse(prhs[5]);
if (isspU) { irU = mxGetIr(prhs[5]); jcU = mxGetJc(prhs[5]); }
V = mxGetPr(prhs[6]); nV = mxGetM(prhs[6]);
isspV = mxIsSparse(prhs[6]);
if (isspV) { irV = mxGetIr(prhs[6]); jcV = mxGetJc(prhs[6]); }
if ((isspU & !isspV) || (!isspU & isspV)) {
mexErrMsgTxt("mexschur: U,V must be both dense or both sparse");
}
colend = (int)*mxGetPr(prhs[7]);
type = (int)*mxGetPr(prhs[8]);
schur = mxGetPr(prhs[9]);
m = mxGetM(prhs[9]);
if (m!= m1) {
mexErrMsgTxt("mexschur: schur and permA are not compatible"); }
if (nrhs == 11) {
P=mxGetPr(prhs[10]); irP=mxGetIr(prhs[10]); jcP=mxGetJc(prhs[10]);
existP = 1;
} else {
existP = 0;
}
/************************************
* output
************************************/
plhs[0] = mxCreateDoubleMatrix(1,1,mxREAL);
nzschur = mxGetPr(plhs[0]);
if (nlhs==2) {
nzP = (int) (0.2*m*m+5);
plhs[1] = mxCreateSparse(m,colend,nzP,mxREAL);
P=mxGetPr(plhs[1]); irP=mxGetIr(plhs[1]); jcP=mxGetJc(plhs[1]);
jcP[0] = 0;
}
/************************************
* initialization
************************************/
if (isspU & isspV) {
cumblksize = mxCalloc(numblk+1,sizeof(int));
blknnz = mxCalloc(numblk+1,sizeof(int));
cumblksize[0] = 0; blknnz[0] = 0;
n1 = 0; n2 = 0;
for (k=0; k<numblk; ++k) {
nsub = blksize[k];
n1 += nsub;
n2 += nsub*nsub;
cumblksize[k+1] = n1;
blknnz[k+1] = n2; }
if (nU != n1 || nV != n1) {
mexErrMsgTxt("mexschur: blk and dimension of U not compatible"); }
Utmp = mxCalloc(n2,sizeof(double));
vec(numblk,cumblksize,blknnz,U,irU,jcU,Utmp);
Vtmp = mxCalloc(n2,sizeof(double));
vec(numblk,cumblksize,blknnz,V,irV,jcV,Vtmp);
blkidx = mxCalloc(nU,sizeof(int));
for (l=0; l<numblk; l++) {
kstart=cumblksize[l]; kend=cumblksize[l+1];
for (k=kstart; k<kend; k++) { blkidx[k] = l; }
}
nzlistAc = mxCalloc(len,sizeof(int));
nzlistAr = mxCalloc(len,sizeof(int));
for (k=0; k<len; k++) {
rb = nzlistAi[k];
cb = nzlistAj[k];
cblk = blkidx[cb]; colcb = cumblksize[cblk];
nzlistAc[k] = blknnz[cblk]+(cb-colcb)*blksize[cblk]-colcb;
nzlistAr[k] = blknnz[cblk]+(rb-colcb)*blksize[cblk]-colcb;
}
}
/************************************
* compute schur(i,j)
************************************/
colm = mxCalloc(colend,sizeof(int));
for (k=0; k<colend; k++) { colm[k] = permA[k]*m; }
n = nU;
if (type==1 & !isspU) { opt=1; }
else if (type==0 & !isspU) { opt=3; }
else if (type==1 & isspU) { opt=2; }
else if (type==0 & isspU) { opt=4; }
/*************************************/
schurcol = mxCalloc(colend,sizeof(double));
count = 0;
for (col=0; col<colend; col++) {
if (existP) {
setvec(col,schurcol,0.0);
for (k=jcP[col]; k<jcP[col+1]; k++) { schurcol[irP[k]]=1.0;}
} else {
setvec(col,schurcol,1.0);
}
if (opt==1) {
schurij1(n,Avec,idxstart,nzlistAi,nzlistAj,U,col,schurcol);
} else if (opt==3) {
schurij3(n,Avec,idxstart,nzlistAi,nzlistAj,U,V,col,schurcol);
} else if (opt==2) {
schurij2(Avec,idxstart,nzlistAi,nzlistAj,Utmp, \
nzlistAr,nzlistAc,cumblksize,blkidx,col,schurcol);
} else if (opt==4) {
schurij4(Avec,idxstart,nzlistAi,nzlistAj,Utmp,Vtmp, \
nzlistAr,nzlistAc,cumblksize,blkidx,col,schurcol);
}
for (row=0; row<=col; row++) {
if (schurcol[row] != 0) {
if (count<nzP & nlhs==2) { jcP[col+1]=count+1; irP[count]=row; P[count]=1; }
count++;
idx1 = permA[row]+colm[col];
idx2 = permA[col]+colm[row];
schur[idx1] += schurcol[row];
schur[idx2] = schur[idx1];
}
}
}
nzschur[0] = count;
mxFree(blksize); mxFree(nzlistAi); mxFree(nzlistAj);
mxFree(permA); mxFree(idxstart); mxFree(schurcol);
if (isspU) {
mxFree(Utmp); mxFree(Vtmp);
mxFree(nzlistAc); mxFree(nzlistAr);
mxFree(blknnz); mxFree(cumblksize); mxFree(blkidx);
}
return;
}
VOID int21_service(iregs FAR * r)
{
COUNT rc,
rc1;
ULONG lrc;
psp FAR *p = MK_FP(cu_psp, 0);
p->ps_stack = (BYTE FAR *) r;
#ifdef DEBUG
if (bDumpRegs)
{
fbcopy((VOID FAR *) user_r, (VOID FAR *) & error_regs, sizeof(iregs));
printf("System call (21h): %02x\n", user_r->AX);
dump_regs = TRUE;
dump();
}
#endif
dispatch:
/* Check for Ctrl-Break */
switch (r->AH)
{
default:
if (!break_ena)
break;
case 0x01:
case 0x02:
case 0x03:
case 0x04:
case 0x05:
case 0x08:
case 0x09:
case 0x0a:
case 0x0b:
if (control_break())
handle_break();
}
/* The dispatch handler */
switch (r->AH)
{
/* int 21h common error handler */
case 0x64:
case 0x6b:
default:
error_invalid:
r->AX = -DE_INVLDFUNC;
goto error_out;
error_exit:
r->AX = -rc;
error_out:
r->FLAGS |= FLG_CARRY;
break;
#if 0
/* Moved to simulate a 0x4c00 -- 1999/04/21 ska */
/* Terminate Program */
case 0x00:
if (cu_psp == RootPsp)
break;
else if (((psp FAR *) (MK_FP(cu_psp, 0)))->ps_parent == cu_psp)
break;
tsr = FALSE;
return_mode = break_flg ? 1 : 0;
return_code = r->AL;
if (DosMemCheck() != SUCCESS)
panic("MCB chain corrupted");
#ifdef TSC
StartTrace();
#endif
return_user();
break;
#endif
/* Read Keyboard with Echo */
case 0x01:
Do_DosIdle_loop();
r->AL = _sti();
sto(r->AL);
break;
/* Display Character */
case 0x02:
sto(r->DL);
break;
/* Auxiliary Input */
case 0x03:
r->AL = _sti();
break;
/* Auxiliary Output */
case 0x04:
sto(r->DL);
break;
/* Print Character */
case 0x05:
sto(r->DL);
break;
/* Direct Cosole I/O */
case 0x06:
if (r->DL != 0xff)
sto(r->DL);
else if (StdinBusy())
{
r->AL = 0x00;
r->FLAGS |= FLG_ZERO;
}
else
{
r->FLAGS &= ~FLG_ZERO;
r->AL = _sti();
}
break;
/* Direct Console Input */
case 0x07:
/* Read Keyboard Without Echo */
case 0x08:
Do_DosIdle_loop();
r->AL = _sti();
break;
/* Display String */
case 0x09:
{
static COUNT scratch;
BYTE FAR *p = MK_FP(r->DS, r->DX),
FAR * q;
q = p;
while (*q != '$')
++q;
DosWrite(STDOUT, q - p, p, (COUNT FAR *) & scratch);
}
r->AL = '$';
break;
/* Buffered Keyboard Input */
case 0x0a:
((keyboard FAR *) MK_FP(r->DS, r->DX))->kb_count = 0;
sti((keyboard FAR *) MK_FP(r->DS, r->DX));
((keyboard FAR *) MK_FP(r->DS, r->DX))->kb_count -= 2;
break;
/* Check Stdin Status */
case 0x0b:
if (StdinBusy())
r->AL = 0xFF;
else
r->AL = 0x00;
break;
/* Flush Buffer, Read Keayboard */
case 0x0c:
KbdFlush();
switch (r->AL)
{
case 0x01:
case 0x06:
case 0x07:
case 0x08:
case 0x0a:
r->AH = r->AL;
goto dispatch;
default:
r->AL = 0x00;
break;
}
break;
/* Reset Drive */
case 0x0d:
flush();
break;
/* Set Default Drive */
case 0x0e:
r->AL = DosSelectDrv(r->DL);
break;
case 0x0f:
if (FcbOpen(MK_FP(r->DS, r->DX)))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x10:
if (FcbClose(MK_FP(r->DS, r->DX)))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x11:
if (FcbFindFirst(MK_FP(r->DS, r->DX)))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x12:
if (FcbFindNext(MK_FP(r->DS, r->DX)))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x13:
if (FcbDelete(MK_FP(r->DS, r->DX)))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x14:
{
COUNT nErrorCode;
if (FcbRead(MK_FP(r->DS, r->DX), &nErrorCode))
r->AL = 0;
else
r->AL = nErrorCode;
break;
}
case 0x15:
{
COUNT nErrorCode;
if (FcbWrite(MK_FP(r->DS, r->DX), &nErrorCode))
r->AL = 0;
else
r->AL = nErrorCode;
break;
}
case 0x16:
if (FcbCreate(MK_FP(r->DS, r->DX)))
r->AL = 0;
else
r->AL = 0xff;
break;
case 0x17:
if (FcbRename(MK_FP(r->DS, r->DX)))
r->AL = 0;
else
r->AL = 0xff;
break;
/* CP/M compatibility functions */
case 0x18:
case 0x1d:
case 0x1e:
case 0x20:
#ifndef TSC
case 0x61:
#endif
r->AL = 0;
break;
/* Get Default Drive */
case 0x19:
r->AL = default_drive;
break;
/* Set DTA */
case 0x1a:
{
psp FAR *p = MK_FP(cu_psp, 0);
p->ps_dta = MK_FP(r->DS, r->DX);
dos_setdta(p->ps_dta);
}
break;
/* Get Default Drive Data */
case 0x1b:
{
BYTE FAR *p;
FatGetDrvData(0,
(COUNT FAR *) & r->AX,
(COUNT FAR *) & r->CX,
(COUNT FAR *) & r->DX,
(BYTE FAR **) & p);
r->DS = FP_SEG(p);
r->BX = FP_OFF(p);
}
break;
/* Get Drive Data */
case 0x1c:
{
BYTE FAR *p;
FatGetDrvData(r->DL,
(COUNT FAR *) & r->AX,
(COUNT FAR *) & r->CX,
(COUNT FAR *) & r->DX,
(BYTE FAR **) & p);
r->DS = FP_SEG(p);
r->BX = FP_OFF(p);
}
break;
/* Get default DPB */
case 0x1f:
if (default_drive < lastdrive)
{
struct dpb FAR *dpb = (struct dpb FAR *)CDSp->cds_table[default_drive].cdsDpb;
if (dpb == 0)
{
r->AL = 0xff;
break;
}
r->DS = FP_SEG(dpb);
r->BX = FP_OFF(dpb);
r->AL = 0;
}
else
r->AL = 0xff;
break;
/* Random read using FCB */
case 0x21:
{
COUNT nErrorCode;
if (FcbRandomRead(MK_FP(r->DS, r->DX), &nErrorCode))
r->AL = 0;
else
r->AL = nErrorCode;
break;
}
/* Random write using FCB */
case 0x22:
{
COUNT nErrorCode;
if (FcbRandomWrite(MK_FP(r->DS, r->DX), &nErrorCode))
r->AL = 0;
else
r->AL = nErrorCode;
break;
}
/* Get file size in records using FCB */
case 0x23:
if (FcbGetFileSize(MK_FP(r->DS, r->DX)))
r->AL = 0;
else
r->AL = 0xff;
break;
/* Set random record field in FCB */
case 0x24:
FcbSetRandom(MK_FP(r->DS, r->DX));
break;
/* Set Interrupt Vector */
case 0x25:
{
VOID(INRPT FAR * p) () = MK_FP(r->DS, r->DX);
setvec(r->AL, p);
}
break;
/* Dos Create New Psp */
case 0x26:
{
psp FAR *p = MK_FP(cu_psp, 0);
new_psp((psp FAR *) MK_FP(r->DX, 0), p->ps_size);
}
break;
/* Read random record(s) using FCB */
case 0x27:
{
COUNT nErrorCode;
if (FcbRandomBlockRead(MK_FP(r->DS, r->DX), r->CX, &nErrorCode))
r->AL = 0;
else
r->AL = nErrorCode;
break;
}
/* Write random record(s) using FCB */
case 0x28:
{
COUNT nErrorCode;
if (FcbRandomBlockWrite(MK_FP(r->DS, r->DX), r->CX, &nErrorCode))
r->AL = 0;
else
r->AL = nErrorCode;
break;
}
/* Parse File Name */
case 0x29:
{
BYTE FAR *lpFileName;
lpFileName = MK_FP(r->DS, r->SI);
r->AL = FcbParseFname(r->AL,
&lpFileName,
MK_FP(r->ES, r->DI));
r->DS = FP_SEG(lpFileName);
r->SI = FP_OFF(lpFileName);
}
break;
/* Get Date */
case 0x2a:
DosGetDate(
(BYTE FAR *) & (r->AL), /* WeekDay */
(BYTE FAR *) & (r->DH), /* Month */
(BYTE FAR *) & (r->DL), /* MonthDay */
(COUNT FAR *) & (r->CX)); /* Year */
break;
/* Set Date */
case 0x2b:
rc = DosSetDate(
(BYTE FAR *) & (r->DH), /* Month */
(BYTE FAR *) & (r->DL), /* MonthDay */
(COUNT FAR *) & (r->CX)); /* Year */
if (rc != SUCCESS)
r->AL = 0xff;
else
r->AL = 0;
break;
/* Get Time */
case 0x2c:
DosGetTime(
(BYTE FAR *) & (r->CH), /* Hour */
(BYTE FAR *) & (r->CL), /* Minutes */
(BYTE FAR *) & (r->DH), /* Seconds */
(BYTE FAR *) & (r->DL)); /* Hundredths */
break;
/* Set Date */
case 0x2d:
rc = DosSetTime(
(BYTE FAR *) & (r->CH), /* Hour */
(BYTE FAR *) & (r->CL), /* Minutes */
(BYTE FAR *) & (r->DH), /* Seconds */
(BYTE FAR *) & (r->DL)); /* Hundredths */
if (rc != SUCCESS)
r->AL = 0xff;
else
r->AL = 0;
break;
/* Set verify flag */
case 0x2e:
verify_ena = (r->AL ? TRUE : FALSE);
break;
/* Get DTA */
case 0x2f:
r->ES = FP_SEG(dta);
r->BX = FP_OFF(dta);
break;
/* Get DOS Version */
case 0x30:
r->AL = os_major;
r->AH = os_minor;
r->BH = OEM_ID;
r->CH = REVISION_MAJOR; /* JPP */
r->CL = REVISION_MINOR;
r->BL = REVISION_SEQ;
break;
/* Keep Program (Terminate and stay resident) */
case 0x31:
DosMemChange(cu_psp, r->DX < 6 ? 6 : r->DX, 0);
return_mode = 3;
return_code = r->AL;
tsr = TRUE;
return_user();
break;
/* Get DPB */
case 0x32:
if (r->DL < lastdrive)
{
struct dpb FAR *dpb = CDSp->cds_table[r->DL].cdsDpb;
if (dpb == 0)
{
r->AL = 0xff;
break;
}
r->DS = FP_SEG(dpb);
r->BX = FP_OFF(dpb);
r->AL = 0;
}
else
r->AL = 0xFF;
break;
/* Get InDOS flag */
case 0x34:
{
BYTE FAR *p;
p = (BYTE FAR *) ((BYTE *) & InDOS);
r->ES = FP_SEG(p);
r->BX = FP_OFF(p);
}
break;
/* Get Interrupt Vector */
case 0x35:
{
BYTE FAR *p;
p = getvec((COUNT) r->AL);
r->ES = FP_SEG(p);
r->BX = FP_OFF(p);
}
break;
/* Dos Get Disk Free Space */
case 0x36:
DosGetFree(
(COUNT) r->DL,
(COUNT FAR *) & r->AX,
(COUNT FAR *) & r->BX,
(COUNT FAR *) & r->CX,
(COUNT FAR *) & r->DX);
break;
/* Undocumented Get/Set Switchar */
case 0x37:
switch (r->AL)
{
/* Get switch character */
case 0x00:
r->DL = switchar;
r->AL = 0x00;
break;
/* Set switch character */
case 0x01:
switchar = r->DL;
r->AL = 0x00;
break;
default:
goto error_invalid;
}
break;
/* Get/Set Country Info */
case 0x38:
{
BYTE FAR *lpTable
= (BYTE FAR *) MK_FP(r->DS, r->DX);
BYTE nRetCode;
if (0xffff == r->DX)
{
r->BX = SetCtryInfo(
(UBYTE FAR *) & (r->AL),
(UWORD FAR *) & (r->BX),
(BYTE FAR *) & lpTable,
(UBYTE *) & nRetCode);
if (nRetCode != 0)
{
r->AX = 0xff;
r->FLAGS |= FLG_CARRY;
}
else
{
r->AX = nRetCode;
r->FLAGS &= ~FLG_CARRY;
}
}
else
{
r->BX = GetCtryInfo(&(r->AL), &(r->BX), lpTable);
r->FLAGS &= ~FLG_CARRY;
}
}
break;
/* Dos Create Directory */
case 0x39:
rc = dos_mkdir((BYTE FAR *) MK_FP(r->DS, r->DX));
if (rc != SUCCESS)
goto error_exit;
else
{
r->FLAGS &= ~FLG_CARRY;
}
break;
/* Dos Remove Directory */
case 0x3a:
rc = dos_rmdir((BYTE FAR *) MK_FP(r->DS, r->DX));
if (rc != SUCCESS)
goto error_exit;
else
{
r->FLAGS &= ~FLG_CARRY;
}
break;
/* Dos Change Directory */
case 0x3b:
if ((rc = DosChangeDir((BYTE FAR *) MK_FP(r->DS, r->DX))) < 0)
goto error_exit;
else
{
r->FLAGS &= ~FLG_CARRY;
}
break;
/* Dos Create File */
case 0x3c:
if ((rc = DosCreat(MK_FP(r->DS, r->DX), r->CX)) < 0)
goto error_exit;
else
{
r->AX = rc;
r->FLAGS &= ~FLG_CARRY;
}
break;
/* Dos Open */
case 0x3d:
if ((rc = DosOpen(MK_FP(r->DS, r->DX), r->AL)) < 0)
goto error_exit;
else
{
r->AX = rc;
r->FLAGS &= ~FLG_CARRY;
}
break;
/* Dos Close */
case 0x3e:
if ((rc = DosClose(r->BX)) < 0)
goto error_exit;
else
r->FLAGS &= ~FLG_CARRY;
break;
/* Dos Read */
case 0x3f:
rc = DosRead(r->BX, r->CX, MK_FP(r->DS, r->DX), (COUNT FAR *) & rc1);
if (rc1 != SUCCESS)
{
r->FLAGS |= FLG_CARRY;
r->AX = -rc1;
}
else
{
r->FLAGS &= ~FLG_CARRY;
r->AX = rc;
}
break;
/* Dos Write */
case 0x40:
rc = DosWrite(r->BX, r->CX, MK_FP(r->DS, r->DX), (COUNT FAR *) & rc1);
if (rc1 != SUCCESS)
{
r->FLAGS |= FLG_CARRY;
r->AX = -rc1;
}
else
{
r->FLAGS &= ~FLG_CARRY;
r->AX = rc;
}
break;
/* Dos Delete File */
case 0x41:
rc = dos_delete((BYTE FAR *) MK_FP(r->DS, r->DX));
if (rc < 0)
{
r->FLAGS |= FLG_CARRY;
r->AX = -rc1;
}
else
r->FLAGS &= ~FLG_CARRY;
break;
/* Dos Seek */
case 0x42:
if ((rc = DosSeek(r->BX, (LONG) ((((LONG) (r->CX)) << 16) + r->DX), r->AL, &lrc)) < 0)
goto error_exit;
else
{
r->DX = (lrc >> 16);
r->AX = lrc & 0xffff;
r->FLAGS &= ~FLG_CARRY;
}
break;
/* Get/Set File Attributes */
case 0x43:
switch (r->AL)
{
case 0x00:
rc = DosGetFattr((BYTE FAR *) MK_FP(r->DS, r->DX), (UWORD FAR *) & r->CX);
if (rc < SUCCESS)
goto error_exit;
else
{
r->FLAGS &= ~FLG_CARRY;
}
break;
case 0x01:
rc = DosSetFattr((BYTE FAR *) MK_FP(r->DS, r->DX), (UWORD FAR *) & r->CX);
if (rc != SUCCESS)
goto error_exit;
else
r->FLAGS &= ~FLG_CARRY;
break;
default:
goto error_invalid;
}
break;
/* Device I/O Control */
case 0x44:
{
rc = DosDevIOctl(r, (COUNT FAR *) & rc1);
if (rc1 != SUCCESS)
{
r->FLAGS |= FLG_CARRY;
r->AX = -rc1;
}
else
{
r->FLAGS &= ~FLG_CARRY;
}
}
break;
/* Duplicate File Handle */
case 0x45:
rc = DosDup(r->BX);
if (rc < SUCCESS)
goto error_exit;
else
{
r->FLAGS &= ~FLG_CARRY;
r->AX = rc;
}
break;
/* Force Duplicate File Handle */
case 0x46:
rc = DosForceDup(r->BX, r->CX);
if (rc < SUCCESS)
goto error_exit;
else
r->FLAGS &= ~FLG_CARRY;
break;
/* Get Current Directory */
case 0x47:
if ((rc = DosGetCuDir(r->DL, MK_FP(r->DS, r->SI))) < 0)
goto error_exit;
else
{
r->FLAGS &= ~FLG_CARRY;
r->AX = 0x0100; /*jpp: from interrupt list */
}
break;
/* Allocate memory */
case 0x48:
if ((rc = DosMemAlloc(r->BX, mem_access_mode, &(r->AX), &(r->BX))) < 0)
{
DosMemLargest(&(r->BX));
goto error_exit;
}
else
{
++(r->AX); /* DosMemAlloc() returns seg of MCB rather than data */
r->FLAGS &= ~FLG_CARRY;
}
break;
/* Free memory */
case 0x49:
if ((rc = DosMemFree((r->ES) - 1)) < 0)
goto error_exit;
else
r->FLAGS &= ~FLG_CARRY;
break;
/* Set memory block size */
case 0x4a:
{
UWORD maxSize;
if ((rc = DosMemChange(r->ES, r->BX, &maxSize)) < 0)
{
if (rc == DE_NOMEM)
r->BX = maxSize;
#if 0
if (cu_psp == r->ES)
{
psp FAR *p;
p = MK_FP(cu_psp, 0);
p->ps_size = r->BX + cu_psp;
}
#endif
goto error_exit;
}
else
r->FLAGS &= ~FLG_CARRY;
break;
}
/* Load and Execute Program */
case 0x4b:
break_flg = FALSE;
if ((rc = DosExec(r->AL, MK_FP(r->ES, r->BX), MK_FP(r->DS, r->DX)))
!= SUCCESS)
goto error_exit;
else
r->FLAGS &= ~FLG_CARRY;
break;
/* Terminate Program */
case 0x00:
r->AX = 0x4c00;
/* End Program */
case 0x4c:
if (cu_psp == RootPsp
|| ((psp FAR *) (MK_FP(cu_psp, 0)))->ps_parent == cu_psp)
break;
tsr = FALSE;
/* int2f_Remote_call(0x1122, 0, 0, 0, 0, 0, 0);
int2f_Remote_call(REM_CLOSEALL, 0, 0, 0, 0, 0, 0);
*/
if (ErrorMode)
{
ErrorMode = FALSE;
return_mode = 2;
}
else if (break_flg)
{
break_flg = FALSE;
return_mode = 1;
}
else
{
return_mode = 0;
}
return_code = r->AL;
if (DosMemCheck() != SUCCESS)
panic("MCB chain corrupted");
#ifdef TSC
StartTrace();
#endif
return_user();
break;
/* Get Child-program Return Value */
case 0x4d:
r->AL = return_code;
r->AH = return_mode;
break;
/* Dos Find First */
case 0x4e:
{
/* dta for this call is set on entry. This */
/* needs to be changed for new versions. */
if ((rc = DosFindFirst((UCOUNT) r->CX, (BYTE FAR *) MK_FP(r->DS, r->DX))) < 0)
goto error_exit;
else
{
r->AX = 0;
r->FLAGS &= ~FLG_CARRY;
}
}
break;
/* Dos Find Next */
case 0x4f:
{
/* dta for this call is set on entry. This */
/* needs to be changed for new versions. */
if ((rc = DosFindNext()) < 0)
{
r->AX = -rc;
if (r->AX == 2)
r->AX = 18;
r->FLAGS |= FLG_CARRY;
}
else
{
r->FLAGS &= ~FLG_CARRY;
}
}
break;
/* ************UNDOCUMENTED************************************* */
/* Get List of Lists */
case 0x52:
{
BYTE FAR *p;
p = (BYTE FAR *) & DPBp;
r->ES = FP_SEG(p);
r->BX = FP_OFF(p);
}
break;
/* Get verify state */
case 0x54:
r->AL = (verify_ena ? TRUE : FALSE);
break;
/* ************UNDOCUMENTED************************************* */
/* Dos Create New Psp & set p_size */
case 0x55:
new_psp((psp FAR *) MK_FP(r->DX, 0), r->SI);
break;
/* Dos Rename */
case 0x56:
rc = dos_rename(
(BYTE FAR *) MK_FP(r->DS, r->DX), /* OldName */
(BYTE FAR *) MK_FP(r->ES, r->DI)); /* NewName */
if (rc < SUCCESS)
goto error_exit;
else
{
r->FLAGS &= ~FLG_CARRY;
}
break;
/* Get/Set File Date and Time */
case 0x57:
switch (r->AL)
{
case 0x00:
rc = DosGetFtime(
(COUNT) r->BX, /* Handle */
(date FAR *) & r->DX, /* FileDate */
(time FAR *) & r->CX); /* FileTime */
if (rc < SUCCESS)
goto error_exit;
else
r->FLAGS &= ~FLG_CARRY;
break;
case 0x01:
rc = DosSetFtime(
(COUNT) r->BX, /* Handle */
(date FAR *) & r->DX, /* FileDate */
(time FAR *) & r->CX); /* FileTime */
if (rc < SUCCESS)
goto error_exit;
else
r->FLAGS &= ~FLG_CARRY;
break;
default:
goto error_invalid;
}
break;
/* Get/Set Allocation Strategy */
case 0x58:
switch (r->AL)
{
case 0x00:
r->AX = mem_access_mode;
break;
case 0x01:
if (((COUNT) r->BX) < 0 || r->BX > 2)
goto error_invalid;
else
{
mem_access_mode = r->BX;
r->FLAGS &= ~FLG_CARRY;
}
break;
default:
goto error_invalid;
#ifdef DEBUG
case 0xff:
show_chain();
break;
#endif
}
break;
/* Create Temporary File */
case 0x5a:
if ((rc = DosMkTmp(MK_FP(r->DS, r->DX), r->CX)) < 0)
goto error_exit;
else
{
r->AX = rc;
r->FLAGS &= ~FLG_CARRY;
}
break;
/* Create New File */
case 0x5b:
if ((rc = DosOpen(MK_FP(r->DS, r->DX), 0)) >= 0)
{
DosClose(rc);
r->AX = 80;
r->FLAGS |= FLG_CARRY;
}
else
{
if ((rc = DosCreat(MK_FP(r->DS, r->DX), r->CX)) < 0)
goto error_exit;
else
{
r->AX = rc;
r->FLAGS &= ~FLG_CARRY;
}
}
break;
/* UNDOCUMENTED: server, share.exe and sda function */
case 0x5d:
switch (r->AL)
{
/* Remote Server Call */
case 0x00:
{
UWORD FAR *x = MK_FP(r->DS, r->DX);
r->AX = x[0];
r->BX = x[1];
r->CX = x[2];
r->DX = x[3];
r->SI = x[4];
r->DI = x[5];
r->DS = x[6];
r->ES = x[7];
}
goto dispatch;
case 0x06:
r->DS = FP_SEG(internal_data);
r->SI = FP_OFF(internal_data);
r->CX = swap_always - internal_data;
r->DX = swap_indos - internal_data;
r->FLAGS &= ~FLG_CARRY;
break;
case 0x07:
case 0x08:
case 0x09:
int2f_Remote_call(REM_PRINTREDIR, 0, 0, r->DX, 0, 0, (MK_FP(0, Int21AX)));
break;
default:
goto error_invalid;
}
break;
case 0x5e:
switch (r->AL)
{
case 0x00:
r->CX = get_machine_name(MK_FP(r->DS, r->DX));
break;
case 0x01:
set_machine_name(MK_FP(r->DS, r->DX), r->CX);
break;
default:
int2f_Remote_call(REM_PRINTSET, r->BX, r->CX, r->DX, (MK_FP(r->ES, r->DI)), r->SI, (MK_FP(r->DS, Int21AX)));
break;
}
break;
case 0x5f:
switch (r->AL)
{
case 0x07:
CDSp->cds_table[r->DL].cdsFlags |= 0x100;
break;
case 0x08:
CDSp->cds_table[r->DL].cdsFlags &= ~0x100;
break;
default:
int2f_Remote_call(REM_DOREDIRECT, r->BX, r->CX, r->DX, (MK_FP(r->ES, r->DI)), r->SI, (MK_FP(r->DS, Int21AX)));
break;
}
break;
case 0x60: /* TRUENAME */
if ((rc = truename(MK_FP(r->DS, r->SI),
adjust_far(MK_FP(r->ES, r->DI)), TRUE)) != SUCCESS)
goto error_exit;
else
{
r->FLAGS &= ~FLG_CARRY;
}
break;
#ifdef TSC
/* UNDOCUMENTED: no-op */
/* */
/* DOS-C: tsc support */
case 0x61:
#ifdef DEBUG
switch (r->AL)
{
case 0x01:
bTraceNext = TRUE;
break;
case 0x02:
bDumpRegs = FALSE;
break;
}
#endif
r->AL = 0x00;
break;
#endif
/* UNDOCUMENTED: return current psp */
case 0x62:
r->BX = cu_psp;
break;
/* UNDOCUMENTED: Double byte and korean tables */
case 0x63:
{
#ifdef DBLBYTE
static char dbcsTable[2] =
{
0, 0
};
void FAR *dp = &dbcsTable;
r->DS = FP_SEG(dp);
r->SI = FP_OFF(dp);
r->AL = 0;
#else
/* not really supported, but will pass. */
r->AL = 0x00; /*jpp: according to interrupt list */
#endif
break;
}
/* Extended country info */
case 0x65:
if (r->AL <= 0x7)
{
if (ExtCtryInfo(
r->AL,
r->BX,
r->CX,
MK_FP(r->ES, r->DI)))
r->FLAGS &= ~FLG_CARRY;
else
goto error_invalid;
}
else if ((r->AL >= 0x20) && (r->AL <= 0x22))
{
switch (r->AL)
{
case 0x20:
r->DL = upChar(r->DL);
goto okay;
case 0x21:
upMem(
MK_FP(r->DS, r->DX),
r->CX);
goto okay;
case 0x22:
upString(MK_FP(r->DS, r->DX));
okay:
r->FLAGS &= ~FLG_CARRY;
break;
case 0x23:
r->AX = yesNo(r->DL);
goto okay;
default:
goto error_invalid;
}
}
else
r->FLAGS |= FLG_CARRY;
break;
/* Code Page functions */
case 0x66:
switch (r->AL)
{
case 1:
GetGlblCodePage(
(UWORD FAR *) & (r->BX),
(UWORD FAR *) & (r->DX));
goto okay_66;
case 2:
SetGlblCodePage(
(UWORD FAR *) & (r->BX),
(UWORD FAR *) & (r->DX));
okay_66:
r->FLAGS &= ~FLG_CARRY;
break;
default:
goto error_invalid;
}
break;
/* Set Max file handle count */
case 0x67:
if ((rc = SetJFTSize(r->BX)) != SUCCESS)
goto error_exit;
else
{
r->FLAGS &= ~FLG_CARRY;
}
break;
/* Flush file buffer -- dummy function right now. */
case 0x68:
r->FLAGS &= ~FLG_CARRY;
break;
}
#ifdef DEBUG
if (bDumpRegs)
{
fbcopy((VOID FAR *) user_r, (VOID FAR *) & error_regs,
sizeof(iregs));
dump_regs = TRUE;
dump();
}
#endif
}
