PROJECT_TEMPLATE::PROJECT_TEMPLATE( const wxString& aPath )
{
templateBasePath = wxFileName::DirName( aPath );
templateMetaPath = wxFileName::DirName( aPath + SEP() + METADIR );
templateMetaHtmlFile = wxFileName::FileName( aPath + SEP() + METADIR + SEP() +
METAFILE_INFO_HTML );
templateMetaIconFile = wxFileName::FileName( aPath + SEP() + METADIR + SEP() + METAFILE_ICON );
title = wxEmptyString;
// Test the project template requirements to make sure aPath is a valid
// template structure
if( !wxFileName::DirExists( templateBasePath.GetPath() ) )
{
// Error, the path doesn't exist!
title = wxT( "Could open the template path! " + aPath );
}
else if( !wxFileName::DirExists( templateMetaPath.GetPath() ) )
{
// Error, the meta information directory doesn't exist!
title = wxT( "Couldn't open the meta information directory for this template! " +
templateMetaPath.GetPath() );
}
else if( !wxFileName::FileExists( templateMetaHtmlFile.GetFullPath() ) )
{
// Error, the meta information directory doesn't contain the informational html file!
title = wxT( "Cound't find the meta html information file for this template!" );
}
// Try to load an icon
metaIcon = new wxBitmap( templateMetaIconFile.GetFullPath(), wxBITMAP_TYPE_PNG );
}
int main(int argc, char** argv) {
BEGIN_PARAMETER_LIST(pl)
ADD_PARAMETER_GROUP(pl, "Group1")
ADD_BOOL_PARAMETER(pl, isHelp, "-h", "provide help")
ADD_INT_PARAMETER(pl, inum, "--number", "a int number")
ADD_DOUBLE_PARAMETER(pl, dnum, "--double", "a double number")
ADD_PARAMETER_GROUP(pl, "Group2")
ADD_STRING_PARAMETER(pl, str, "--string", "sample string")
ADD_PARAMETER_GROUP(pl, "Input/Output")
ADD_STRING_PARAMETER(pl,inputVCFFileName, "--input", "input file name")
ADD_STRING_PARAMETER(pl,outputPrefix, "--outputPrefix", "output prefix for 012 files")
ADD_PARAMETER_GROUP(pl, "People Filter")
ADD_STRING_PARAMETER(pl, peopleIncludeID, "--peopleIncludeID", "include people with these ID in the analysis")
ADD_STRING_PARAMETER(pl, peopleIncludeFile, "--peopleIncludeFile", "specify a file, so ID in that file will be included in analysis")
ADD_STRING_PARAMETER(pl, peopleExcludeID, "--peopleExcludeID", "exclude people with these ID in the analysis")
ADD_STRING_PARAMETER(pl, peopleExcludeFile, "--peopleExcludeFile","specify a file, so ID in that file will be excluded in analysis")
ADD_PARAMETER_GROUP(pl, "INFO field Grepper")
ADD_STRING_PARAMETER(pl, infoGrep, "--infoGrep", "You can use regular expression to filter the INFO field of the VCF file. "
"For example, use --infoGrep ANNO=synonymous|ANNO=nonsynonymous to grep both "
"synonymous and nonsynonymous annotations")
END_PARAMETER_LIST(pl)
;
SEP(Help);
pl.Help();
SEP(END);
return 0;
};
char*
cleanname(char *name)
{
char *p, *q, *dotdot;
int rooted, erasedprefix;
rooted = name[0] == '/';
erasedprefix = 0;
/*
* invariants:
* p points at beginning of path element we're considering.
* q points just past the last path element we wrote (no slash).
* dotdot points just past the point where .. cannot backtrack
* any further (no slash).
*/
p = q = dotdot = name+rooted;
while(*p) {
if(p[0] == '/') /* null element */
p++;
else if(p[0] == '.' && SEP(p[1])) {
if(p == name)
erasedprefix = 1;
p += 1; /* don't count the separator in case it is nul */
} else if(p[0] == '.' && p[1] == '.' && SEP(p[2])) {
p += 2;
if(q > dotdot) { /* can backtrack */
while(--q > dotdot && *q != '/')
;
} else if(!rooted) { /* /.. is / but ./../ is .. */
if(q != name)
*q++ = '/';
*q++ = '.';
*q++ = '.';
dotdot = q;
}
if(q == name)
erasedprefix = 1; /* erased entire path via dotdot */
} else { /* real path element */
if(q != name+rooted)
*q++ = '/';
while((*q = *p) != '/' && *q != 0)
p++, q++;
}
}
if(q == name) /* empty string is really ``.'' */
*q++ = '.';
*q = '\0';
if(erasedprefix && name[0] == '#'){
/* this was not a #x device path originally - make it not one now */
memmove(name+2, name, strlen(name)+1);
name[0] = '.';
name[1] = '/';
}
return name;
}
static char *
xps_clean_path(char *name)
{
char *p, *q, *dotdot, *start;
int rooted;
start = skip_scheme(name);
start = skip_authority(start);
rooted = start[0] == '/';
/*
* invariants:
* p points at beginning of path element we're considering.
* q points just past the last path element we wrote (no slash).
* dotdot points just past the point where .. cannot backtrack
* any further (no slash).
*/
p = q = dotdot = start + rooted;
while (*p)
{
if(p[0] == '/') /* null element */
p++;
else if (p[0] == '.' && SEP(p[1]))
p += 1; /* don't count the separator in case it is nul */
else if (p[0] == '.' && p[1] == '.' && SEP(p[2]))
{
p += 2;
if (q > dotdot) /* can backtrack */
{
while(--q > dotdot && *q != '/')
;
}
else if (!rooted) /* /.. is / but ./../ is .. */
{
if (q != start)
*q++ = '/';
*q++ = '.';
*q++ = '.';
dotdot = q;
}
}
else /* real path element */
{
if (q != start+rooted)
*q++ = '/';
while ((*q = *p) != '/' && *q != 0)
p++, q++;
}
}
if (q == start) /* empty string is really "." */
*q++ = '.';
*q = '\0';
return name;
}
void cuUtils::DisplayKernelProfilingData(char* kernelName, cuProfile* profile)
{
COUT << TAB; SEP();
COUT << TAB << "Kernel Execution Time @[" << CATS(kernelName) << "]" << ENDL;
COUT << TAB << TAB << "@Nano-Seconds (ns) : " << (profile->kernelDuration * (1000 * 1000)) << ENDL;
COUT << TAB << TAB << "@Micro-Seconds (us) : " << (profile->kernelDuration * 1000) << ENDL;
COUT << TAB << TAB << "@Milli-Seconds (ms) : " << profile->kernelDuration << ENDL;
COUT << TAB << TAB << "@Seconds (s) : " << (profile->kernelDuration / (1000)) << ENDL;
COUT << TAB; SEP();
}
void I_UpdateSoundParams(int channel, int vol, int sep, int pitch)
{
// proff 07/04/98: Added for CYGWIN32 compatibility
#ifdef HAVE_LIBDSOUND
int DSB_Status;
if (noDSound == true)
return;
// proff 07/26/98: Added volume check
if (vol==0)
{
IDirectSoundBuffer_Stop(lpSecondaryDSB[channel]);
return;
}
IDirectSoundBuffer_SetVolume(lpSecondaryDSB[channel],VOL(vol));
IDirectSoundBuffer_SetPan(lpSecondaryDSB[channel],SEP(sep));
IDirectSoundBuffer_SetFrequency
(lpSecondaryDSB[channel], ChannelInfo[channel].samplerate+PITCH(pitch));
if (ChannelInfo[channel].playing == true)
{
IDirectSoundBuffer_GetStatus(lpSecondaryDSB[channel], &DSB_Status);
if ((DSB_Status & DSBSTATUS_PLAYING) == 0)
IDirectSoundBuffer_Play(lpSecondaryDSB[channel], 0, 0, 0);
}
#endif // HAVE_LIBDSOUND
}
char*
cleanname(char *name)
{
char *p, *q, *dotdot;
int rooted;
rooted = name[0] == '/';
/*
* invariants:
* p points at beginning of path element we're considering.
* q points just past the last path element we wrote (no slash).
* dotdot points just past the point where .. cannot backtrack
* any further (no slash).
*/
p = q = dotdot = name+rooted;
while(*p) {
if(p[0] == '/') /* null element */
p++;
else if(p[0] == '.' && SEP(p[1]))
p += 1; /* don't count the separator in case it is nul */
else if(p[0] == '.' && p[1] == '.' && SEP(p[2])) {
p += 2;
if(q > dotdot) { /* can backtrack */
while(--q > dotdot && *q != '/')
;
} else if(!rooted) { /* /.. is / but ./../ is .. */
if(q != name)
*q++ = '/';
*q++ = '.';
*q++ = '.';
dotdot = q;
}
} else { /* real path element */
if(q != name+rooted)
*q++ = '/';
while((*q = *p) != '/' && *q != 0)
p++, q++;
}
}
if(q == name) /* empty string is really ``.'' */
*q++ = '.';
*q = '\0';
return name;
}
static char *
tokenise(char *s, char **start, char **end)
{
char *to;
Rune r;
int n;
while(*s && SEP(*s)) /* skip leading white space */
s++;
to = *start = s;
while(*s){
n = chartorune(&r, s);
if(SEP(r)){
if(to != *start) /* we have data */
break;
s += n; /* null string - keep looking */
while(*s && SEP(*s))
s++;
to = *start = s;
}
else if(r == '\''){
s += n; /* skip leading quote */
while(*s){
n = chartorune(&r, s);
if(r == '\''){
if(s[1] != '\'')
break;
s++; /* embedded quote */
}
while (n--)
*to++ = *s++;
}
if(!*s) /* no trailing quote */
break;
s++; /* skip trailing quote */
}
else {
while(n--)
*to++ = *s++;
}
}
*end = to;
return s;
}
void DrawBox(int x, int y, int _color, bool light)
{
CHC_Vector3 color = Color2Vector(_color);
glPushAttrib(GL_ENABLE_BIT);
glPushMatrix();
if (light) {
glBindTexture(GL_TEXTURE_2D, WhiteTexture); //加纹理来高亮
} else {
glBindTexture(GL_TEXTURE_2D, BlackTexture); //加纹理来高亮
}
glColor4f(SEP(color), 1.0);
glTranslated((float)x, 0.5, (float)y);
glutSolidCube(1.0);
glPopMatrix();
glPopAttrib();
}
/* Creates a new project folder, copy a template into this new folder.
* and open this new project as working project
*/
void KICAD_MANAGER_FRAME::OnCreateProjectFromTemplate( wxCommandEvent& event )
{
wxString default_dir = wxFileName( Prj().GetProjectFullName() ).GetPathWithSep();
wxString title = _("New Project Folder");
wxDirDialog dlg( this, title, default_dir );
if( dlg.ShowModal() == wxID_CANCEL )
return;
// Builds the project .pro filename, from the new project folder name
wxFileName fn;
fn.AssignDir( dlg.GetPath() );
fn.SetName( dlg.GetPath().AfterLast( SEP() ) );
fn.SetExt( wxT( "pro" ) );
// Launch the template selector dialog, and copy files
CreateNewProject( fn.GetFullPath(), true );
// Initialize the project
event.SetId( wxID_ANY );
OnLoadProject( event );
}
void KICAD_MANAGER_FRAME::CreateNewProject( const wxString& aPrjFullFileName,
bool aTemplateSelector = false )
{
wxFileName newProjectName = aPrjFullFileName;
wxChar sep[2] = { SEP(), 0 }; // nul terminated separator wxChar string.
ClearMsg();
// If we are creating a project from a template, make sure the template directory is sane
if( aTemplateSelector )
{
DIALOG_TEMPLATE_SELECTOR* ps = new DIALOG_TEMPLATE_SELECTOR( this );
wxFileName templatePath;
wxString envStr;
#ifndef __WXMAC__
wxGetEnv( wxT( "KICAD" ), &envStr );
// Add a new tab for system templates
if( !envStr.empty() )
{
// user may or may not have including terminating separator.
if( !envStr.EndsWith( sep ) )
envStr += sep;
templatePath = envStr + wxT( "template" ) + sep;
}
else
{
// The standard path should be in the share directory for kicad. As
// it is normal on Windows to only have the share directory and not
// the kicad sub-directory we fall back to that if the directory
// doesn't exist
templatePath = wxPathOnly( wxStandardPaths::Get().GetExecutablePath() ) +
sep + wxT( ".." ) + sep + wxT( "share" ) + sep + wxT( "kicad" ) +
sep + wxT( "template" ) + sep;
if( !wxDirExists( templatePath.GetFullPath() ) )
{
templatePath = wxPathOnly( wxStandardPaths::Get().GetExecutablePath() ) +
sep + wxT( ".." ) + sep + wxT( "share" ) + sep + wxT( "template" ) + sep;
}
}
#else
// Use what is provided in the bundle data dir
templatePath = GetOSXKicadDataDir() + sep + wxT( "template" );
#endif
ps->AddTemplatesPage( _( "System Templates" ), templatePath );
// Add a new tab for user templates
wxFileName userPath = wxStandardPaths::Get().GetDocumentsDir() +
sep + wxT( "kicad" ) + sep + wxT( "template" ) + sep;
ps->AddTemplatesPage( _( "User Templates" ), userPath );
// Check to see if a custom template location is available and setup a
// new selection tab if there is.
envStr.clear();
wxGetEnv( wxT( "KICAD_PTEMPLATES" ), &envStr );
if( !envStr.empty() )
{
if( !envStr.EndsWith( sep ) )
envStr += sep;
wxFileName envPath = envStr;
ps->AddTemplatesPage( _( "Portable Templates" ), envPath );
}
// Show the project template selector dialog
int result = ps->ShowModal();
if( ( result != wxID_OK ) || ( ps->GetSelectedTemplate() == NULL ) )
{
if( ps->GetSelectedTemplate() == NULL )
{
wxMessageBox( _( "No project template was selected. Cannot generate new "
"project." ),
_( "Error" ),
wxOK | wxICON_ERROR,
this );
}
}
else
{
// The selected template widget contains the template we're attempting to use to
// create a project
if( !ps->GetSelectedTemplate()->CreateProject( newProjectName ) )
{
wxMessageBox( _( "Problem whilst creating new project from template!" ),
_( "Template Error" ),
wxOK | wxICON_ERROR,
this );
}
}
}
// Init project filename
SetProjectFileName( newProjectName.GetFullPath() );
// Write settings to project file
// was: wxGetApp().WriteProjectConfig( aPrjFullFileName, GeneralGroupName, s_KicadManagerParams );
Prj().ConfigSave( Pgm().SysSearch(), GeneralGroupName, s_KicadManagerParams );
// Ensure a "stub" for a schematic root sheet and a board exist.
// It will avoid messages from the schematic editor or the board editor to create a new file
// And forces the user to create main files under the right name for the project manager
wxFileName fn( newProjectName.GetFullPath() );
fn.SetExt( SchematicFileExtension );
// If a <project>.sch file does not exist, create a "stub" file
if( !fn.FileExists() )
{
wxFile file( fn.GetFullPath(), wxFile::write );
if( file.IsOpened() )
file.Write( wxT( "EESchema Schematic File Version 2\n" ) );
// wxFile dtor will close the file
}
// If a <project>.kicad_pcb or <project>.brd file does not exist,
// create a .kicad_pcb "stub" file
fn.SetExt( KiCadPcbFileExtension );
wxFileName leg_fn( fn );
leg_fn.SetExt( LegacyPcbFileExtension );
if( !fn.FileExists() && !leg_fn.FileExists() )
{
wxFile file( fn.GetFullPath(), wxFile::write );
if( file.IsOpened() )
file.Write( wxT( "(kicad_pcb (version 4) (host kicad \"dummy file\") )\n" ) );
// wxFile dtor will close the file
}
// Enable the toolbar and menubar buttons and clear the help text.
m_active_project = true;
m_MessagesBox->Clear();
}
int I_StartSound(sfxinfo_t *sound, int vol, int sep, int pitch, int pri)
{
int channel=0;
// proff 07/04/98: Added for CYGWIN32 compatibility
#ifdef HAVE_LIBDSOUND
HRESULT error;
char *snddata;
int sndlength;
if (noDSound == true)
return channel;
// load sound data if we have not already
I_CacheSound(sound);
// find a free channel
channel = I_GetFreeChannel();
// proff 07/26/98: Added volume check
// proff 10/31/98: Added Stop before updating sound-data
error = IDirectSoundBuffer_Stop(lpSecondaryDSB[channel]);
ChannelInfo[channel].playing = false;
if (vol==0)
return channel;
snddata = sound->data;
ChannelInfo[channel].samplerate = (snddata[3] << 8) + snddata[2];
// proff 10/31/98: Use accurate time for this one
ChannelInfo[channel].endtime =
I_GetTime_RealTime() +
(sound->length * 35) / ChannelInfo[channel].samplerate + 1;
// skip past header
snddata += 8;
sndlength = sound->length - 8;
error = IDirectSoundBuffer_SetCurrentPosition(lpSecondaryDSB[channel],0);
// proff 11/09/98: Added for a slight speedup
if (sound != ChannelInfo[channel].sfx)
{
DWORD *hand1,*hand2;
DWORD len1,len2;
ChannelInfo[channel].sfx = sound;
error = IDirectSoundBuffer_Lock(lpSecondaryDSB[channel],0,65535,
&hand1,&len1,&hand2,&len2,
DSBLOCK_FROMWRITECURSOR);
if (len1 >= sndlength)
{
memset(hand1, 128, len1);
memcpy(hand1, snddata , sndlength);
memset(hand2, 128, len2);
}
else
{
memcpy(hand1, snddata, len1);
memcpy(hand2, &((char *)snddata)[len1], sndlength-len1);
}
error = IDirectSoundBuffer_Unlock
(lpSecondaryDSB[channel], hand1, len1, hand2, len2);
}
IDirectSoundBuffer_SetVolume(lpSecondaryDSB[channel], VOL(vol));
IDirectSoundBuffer_SetPan(lpSecondaryDSB[channel], SEP(sep));
IDirectSoundBuffer_SetFrequency(lpSecondaryDSB[channel],
ChannelInfo[channel].samplerate+PITCH(pitch));
error = IDirectSoundBuffer_Play(lpSecondaryDSB[channel], 0, 0, 0);
ChannelInfo[channel].playing = true;
#endif // HAVE_LIBDSOUND
return channel;
}
/* Subroutine */ int ztrsna_(char *job, char *howmny, logical *select,
integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s,
doublereal *sep, integer *mm, integer *m, doublecomplex *work,
integer *ldwork, doublereal *rwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZTRSNA estimates reciprocal condition numbers for specified
eigenvalues and/or right eigenvectors of a complex upper triangular
matrix T (or of any matrix Q*T*Q**H with Q unitary).
Arguments
=========
JOB (input) CHARACTER*1
Specifies whether condition numbers are required for
eigenvalues (S) or eigenvectors (SEP):
= 'E': for eigenvalues only (S);
= 'V': for eigenvectors only (SEP);
= 'B': for both eigenvalues and eigenvectors (S and SEP).
HOWMNY (input) CHARACTER*1
= 'A': compute condition numbers for all eigenpairs;
= 'S': compute condition numbers for selected eigenpairs
specified by the array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY = 'S', SELECT specifies the eigenpairs for which
condition numbers are required. To select condition numbers
for the j-th eigenpair, SELECT(j) must be set to .TRUE..
If HOWMNY = 'A', SELECT is not referenced.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input) COMPLEX*16 array, dimension (LDT,N)
The upper triangular matrix T.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
VL (input) COMPLEX*16 array, dimension (LDVL,M)
If JOB = 'E' or 'B', VL must contain left eigenvectors of T
(or of any Q*T*Q**H with Q unitary), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VL, as returned by
ZHSEIN or ZTREVC.
If JOB = 'V', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of the array VL.
LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
VR (input) COMPLEX*16 array, dimension (LDVR,M)
If JOB = 'E' or 'B', VR must contain right eigenvectors of T
(or of any Q*T*Q**H with Q unitary), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VR, as returned by
ZHSEIN or ZTREVC.
If JOB = 'V', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR.
LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
S (output) DOUBLE PRECISION array, dimension (MM)
If JOB = 'E' or 'B', the reciprocal condition numbers of the
selected eigenvalues, stored in consecutive elements of the
array. Thus S(j), SEP(j), and the j-th columns of VL and VR
all correspond to the same eigenpair (but not in general the
j-th eigenpair, unless all eigenpairs are selected).
If JOB = 'V', S is not referenced.
SEP (output) DOUBLE PRECISION array, dimension (MM)
If JOB = 'V' or 'B', the estimated reciprocal condition
numbers of the selected eigenvectors, stored in consecutive
elements of the array.
If JOB = 'E', SEP is not referenced.
MM (input) INTEGER
The number of elements in the arrays S (if JOB = 'E' or 'B')
and/or SEP (if JOB = 'V' or 'B'). MM >= M.
M (output) INTEGER
The number of elements of the arrays S and/or SEP actually
used to store the estimated condition numbers.
If HOWMNY = 'A', M is set to N.
WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N+1)
If JOB = 'E', WORK is not referenced.
LDWORK (input) INTEGER
The leading dimension of the array WORK.
LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
If JOB = 'E', RWORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The reciprocal of the condition number of an eigenvalue lambda is
defined as
S(lambda) = |v'*u| / (norm(u)*norm(v))
where u and v are the right and left eigenvectors of T corresponding
to lambda; v' denotes the conjugate transpose of v, and norm(u)
denotes the Euclidean norm. These reciprocal condition numbers always
lie between zero (very badly conditioned) and one (very well
conditioned). If n = 1, S(lambda) is defined to be 1.
An approximate error bound for a computed eigenvalue W(i) is given by
EPS * norm(T) / S(i)
where EPS is the machine precision.
The reciprocal of the condition number of the right eigenvector u
corresponding to lambda is defined as follows. Suppose
T = ( lambda c )
( 0 T22 )
Then the reciprocal condition number is
SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
where sigma-min denotes the smallest singular value. We approximate
the smallest singular value by the reciprocal of an estimate of the
one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
defined to be abs(T(1,1)).
An approximate error bound for a computed right eigenvector VR(i)
is given by
EPS * norm(T) / SEP(i)
=====================================================================
Decode and test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *), d_imag(doublecomplex *);
/* Local variables */
static integer kase, ierr;
static doublecomplex prod;
static doublereal lnrm, rnrm;
static integer i, j, k;
static doublereal scale;
extern logical lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublecomplex dummy[1];
static logical wants;
static doublereal xnorm;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *);
static integer ks, ix;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
static logical wantbh;
extern /* Subroutine */ int zlacon_(integer *, doublecomplex *,
doublecomplex *, doublereal *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
static logical somcon;
extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
doublecomplex *, integer *);
static char normin[1];
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal smlnum;
static logical wantsp;
extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *, integer *), ztrexc_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, integer *);
static doublereal eps, est;
#define DUMMY(I) dummy[(I)]
#define SELECT(I) select[(I)-1]
#define S(I) s[(I)-1]
#define SEP(I) sep[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define T(I,J) t[(I)-1 + ((J)-1)* ( *ldt)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]
#define WORK(I,J) work[(I)-1 + ((J)-1)* ( *ldwork)]
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantsp = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
/* Set M to the number of eigenpairs for which condition numbers are
to be computed. */
if (somcon) {
*m = 0;
i__1 = *n;
for (j = 1; j <= *n; ++j) {
if (SELECT(j)) {
++(*m);
}
/* L10: */
}
} else {
*m = *n;
}
*info = 0;
if (! wants && ! wantsp) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || wants && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || wants && *ldvr < *n) {
*info = -10;
} else if (*mm < *m) {
*info = -13;
} else if (*ldwork < 1 || wantsp && *ldwork < *n) {
*info = -16;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTRSNA", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (somcon) {
if (! SELECT(1)) {
return 0;
}
}
if (wants) {
S(1) = 1.;
}
if (wantsp) {
SEP(1) = z_abs(&T(1,1));
}
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
ks = 1;
i__1 = *n;
for (k = 1; k <= *n; ++k) {
if (somcon) {
if (! SELECT(k)) {
goto L50;
}
}
if (wants) {
/* Compute the reciprocal condition number of the k-th
eigenvalue. */
zdotc_(&z__1, n, &VR(1,ks), &c__1, &VL(1,ks), &c__1);
prod.r = z__1.r, prod.i = z__1.i;
rnrm = dznrm2_(n, &VR(1,ks), &c__1);
lnrm = dznrm2_(n, &VL(1,ks), &c__1);
S(ks) = z_abs(&prod) / (rnrm * lnrm);
}
if (wantsp) {
/* Estimate the reciprocal condition number of the k-th
eigenvector.
Copy the matrix T to the array WORK and swap the k-th
diagonal element to the (1,1) position. */
zlacpy_("Full", n, n, &T(1,1), ldt, &WORK(1,1),
ldwork);
ztrexc_("No Q", n, &WORK(1,1), ldwork, dummy, &c__1, &k, &
c__1, &ierr);
/* Form C = T22 - lambda*I in WORK(2:N,2:N). */
i__2 = *n;
for (i = 2; i <= *n; ++i) {
i__3 = i + i * work_dim1;
i__4 = i + i * work_dim1;
i__5 = work_dim1 + 1;
z__1.r = WORK(i,i).r - WORK(1,1).r, z__1.i = WORK(i,i).i -
WORK(1,1).i;
WORK(i,i).r = z__1.r, WORK(i,i).i = z__1.i;
/* L20: */
}
/* Estimate a lower bound for the 1-norm of inv(C'). The
1st
and (N+1)th columns of WORK are used to store work ve
ctors. */
SEP(ks) = 0.;
est = 0.;
kase = 0;
*(unsigned char *)normin = 'N';
L30:
i__2 = *n - 1;
zlacon_(&i__2, &WORK(1,*n+1), &WORK(1,1)
, &est, &kase);
if (kase != 0) {
if (kase == 1) {
/* Solve C'*x = scale*b */
i__2 = *n - 1;
zlatrs_("Upper", "Conjugate transpose", "Nonunit", normin,
&i__2, &WORK(2,2), ldwork, &
WORK(1,1), &scale, &RWORK(1), &ierr);
} else {
/* Solve C*x = scale*b */
i__2 = *n - 1;
zlatrs_("Upper", "No transpose", "Nonunit", normin, &i__2,
&WORK(2,2), ldwork, &WORK(1,1), &scale, &RWORK(1), &ierr);
}
*(unsigned char *)normin = 'Y';
if (scale != 1.) {
/* Multiply by 1/SCALE if doing so will no
t cause
overflow. */
i__2 = *n - 1;
ix = izamax_(&i__2, &WORK(1,1), &c__1);
i__2 = ix + work_dim1;
xnorm = (d__1 = WORK(ix,1).r, abs(d__1)) + (d__2 = d_imag(
&WORK(ix,1)), abs(d__2));
if (scale < xnorm * smlnum || scale == 0.) {
goto L40;
}
zdrscl_(n, &scale, &WORK(1,1), &c__1);
}
goto L30;
}
SEP(ks) = 1. / max(est,smlnum);
}
L40:
++ks;
L50:
;
}
return 0;
/* End of ZTRSNA */
} /* ztrsna_ */
gboolean
node_needs_dot (Node *node)
{
Wire *wire1, *wire2;
Coords start_pos1, length1, end_pos1;
Coords start_pos2, length2, end_pos2;
NG_DEBUG ("\nnode: %p --- pins: %i --- wires: %i", node, node->pin_count, node->wire_count);
// always display a black dot if a part hits a wire
if (node->pin_count >= 1 && node->wire_count >= 1) {
NG_DEBUG (" TRUE (pins>=1 && wires>=1)");
return TRUE;
// FIXME this can create sparse knots, because of overlaying wires o===xxxx===o
// TODO can be fixed by optimizing away/fuzing duplicate/overlaying wires
} else if ((node->pin_count + node->wire_count) > 2) {
NG_DEBUG (" TRUE (pins+wires>2)");
return TRUE;
} else if (node->wire_count == 2) {
// Check that we don't have two wire endpoints.
wire1 = node->wires->data;
wire2 = node->wires->next->data;
wire_get_pos_and_length (wire1, &start_pos1, &length1);
wire_get_pos_and_length (wire2, &start_pos2, &length2);
end_pos1.x = start_pos1.x + length1.x;
end_pos1.y = start_pos1.y + length1.y;
end_pos2.x = start_pos2.x + length2.x;
end_pos2.y = start_pos2.y + length2.y;
if (!(SEP (start_pos1, start_pos2) ||
SEP (start_pos1, end_pos2) ||
SEP (end_pos1, end_pos2) ||
SEP (end_pos1, start_pos2))) {
// The dot is only needed when the end/start-point of
// one of the wires in on the other wire.
if (ON_THE_WIRE (start_pos1, start_pos2, end_pos2) ||
ON_THE_WIRE ( end_pos1, start_pos2, end_pos2) ||
ON_THE_WIRE (start_pos2, start_pos1, end_pos1) ||
ON_THE_WIRE ( end_pos2, start_pos1, end_pos1)
) {
NG_DEBUG (" TRUE (wires>2 && endpoint on wire)");
return TRUE;
} else {
NG_DEBUG (" FALSE (wires>2 && crossing)");
return FALSE;
}
}
return FALSE;
} else if (node->pin_count == 1 && node->wire_count == 1) {
// TODO this is most likely obsolete and is never entered
// Check if we have one wire with a pin in the 'middle'.
wire1 = node->wires->data;
wire_get_pos_and_length (wire1, &start_pos1, &length1);
end_pos1.x = start_pos1.x + length1.x;
end_pos1.y = start_pos1.y + length1.y;
if (!SEP (node->key, start_pos1) && !SEP (node->key, end_pos1)) {
NG_DEBUG (" FALSE (pins==1 && wires==1) pin in the middle of a wire");
return TRUE;
}
}
NG_DEBUG (" FALSE (else)");
return FALSE;
}
void ex_RealArray::DumpNumbers_Single()
{
INFO("ex_RealArray - Single Precision");
// Create the XL book
xlBook = Utils::xl::createBook();
INFO("xlBook created : " + CATS(xlBookName_Single));
SEP();
if(xlBook)
{
/**********************************************************
* 1D Case
**********************************************************/
xlSheet = Utils::xl::addSheetToBook("1D", xlBook);
if (xlSheet)
{
INFO("** 1D Case");
size_N = size_X;
// Allocation
floatArray_1D = MEM_ALLOC_1D(float, size_N);
INFO("Array allocation done");
// Filling array (Sequential)
Array::fillArray_1D_float(floatArray_1D, size_N, 1);
INFO("Filing array done - Sequential");
// Headers
xlSheet->writeStr(1, 0, "Seq");
// Filling column with data
for (int j = 0; j < size_N; j++)
xlSheet->writeNum(j + 2, 0, floatArray_1D[j]);
// Filling array (Random)
Array::fillArray_1D_float(floatArray_1D, size_N, 0);
INFO("Filing array done - Random");
// Headers
xlSheet->writeStr(1, 1, "Rnd");
// Filling column with data
for (int j = 0; j < size_N; j++)
xlSheet->writeNum(j + 2, 1, floatArray_1D[j]);
// Freeing memory
FREE_MEM_1D(floatArray_1D);
INFO("Freeing memory");
}
else
{
INFO("No valid xlSheet was created, EXITTING ...");
EXIT(0);
}
SEP();
/**********************************************************
* 2D Flat Case
**********************************************************/
xlSheet = Utils::xl::addSheetToBook("Flat_2D", xlBook);
if (xlSheet)
{
INFO("** 2D Flat Case");
size_N = size_X * size_Y;
// Allocation
floatArray_2D_flat = MEM_ALLOC_1D(float, size_N);
INFO("Array allocation done");
// Filling array (Sequential)
Array::fillArray_2D_flat_float(floatArray_2D_flat, size_X, size_Y, 1);
INFO("Filing array done - Sequential");
// Headers
xlSheet->writeStr(1, 0, "Seq");
// Filling column with data
for (int j = 0; j < size_N; j++)
xlSheet->writeNum(j + 2, 0, floatArray_2D_flat[j]);
// Filling array (Random)
Array::fillArray_2D_flat_float(floatArray_2D_flat, size_X, size_Y, 0);
INFO("Filing array done - Random");
// Headers
xlSheet->writeStr(1, 1, "Rnd");
// Filling column with data
for (int j = 0; j < size_N; j++)
xlSheet->writeNum(j + 2, 1, floatArray_2D_flat[j]);
// Freeing memory
FREE_MEM_1D(floatArray_2D_flat);
INFO("Freeing memory");
}
else
{
// Decides if two wires intersect. Note that wires that share an
// endpoint are considered intersecting each other. Intersection point
// is returned in pos.
static int
do_wires_intersect (double Ax, double Ay, double Bx, double By, double Cx,
double Cy, double Dx, double Dy, SheetPos *pos)
{
double r, s, d;
// Wires don't intersect if they share an endpoint. NOTE: they do here...
if (SEP (Ax, Ay, Cx, Cy)) { // same starting point
pos->x = Ax;
pos->y = Ay;
return TRUE;
}
else if (SEP (Ax, Ay, Dx, Dy)) { // 1st start == 2nd end
pos->x = Ax;
pos->y = Ay;
return TRUE;
}
else if (SEP (Bx, By, Cx, Cy)) { // 1st end == 2nd start
pos->x = Bx;
pos->y = By;
return TRUE;
}
else if (SEP (Bx, By, Dx, Dy)) { // 1st end == 2nd end
pos->x = Bx;
pos->y = By;
return TRUE;
}
// Calculate the denominator.
d = ((Bx - Ax) * (Dy - Cy) - (By - Ay) * (Dx - Cx));
// We have two parallell wires if d = 0.
if (fabs (d) < NODE_EPSILON) {
return FALSE;
}
r = ((Ay - Cy) * (Dx - Cx) - (Ax - Cx) * (Dy - Cy));
r = r / d;
s = ((Ay - Cy) * (Bx - Ax) - (Ax - Cx) * (By - Ay)) / d;
// Check for intersection, which we have for values of
// r and s in [0, 1].
if (r >= 0 &&
(r - 1.0) < NODE_EPSILON &&
s >= 0 &&
(s - 1.0) < NODE_EPSILON) {
// Calculate the intersection point.
pos->x = Ax + r * (Bx - Ax);
pos->y = Ay + r * (By - Ay);
// to be accepted only if it coincides with the start or end
// of any of the wires
if ( SEP (pos->x,pos->y,Ax,Ay) ||
SEP (pos->x,pos->y,Bx,By) ||
SEP (pos->x,pos->y,Cx,Cy) ||
SEP (pos->x,pos->y,Dx,Dy) )
return TRUE;
else
return FALSE;
}
return FALSE;
}
int CSVExpression::toRPN(const string &szExpr, string &rpn)
{
std::stack<string> st;
string token, topToken;
char token1;
int tokenLen, topPrecedence, idx, precedence;
string SEP(" "), EMPTY("");
rpn = "";
for (int i = 0; i < static_cast<int>(szExpr.length()); i++)
{
token1 = szExpr[i];
// skip white space
if (isspace(token1))
continue;
// push left parenthesis
else if (token1 == '(')
{
st.push(EMPTY+token1);
continue;
}
// flush all stack till matching the left-parenthesis
else if (token1 == ')')
{
for (;;)
{
// could not match left-parenthesis
if (st.empty())
return eval_unbalanced;
topToken = st.top();
st.pop();
if (topToken == "(")
break;
rpn.append(SEP + topToken);
}
continue;
}
// is this an operator?
idx = isOperator(szExpr.substr(i));
// an operand
if (idx < 0)
{
tokenLen = getToken(szExpr.substr(i));
if (tokenLen == 0)
return eval_invalidoperand;
token = szExpr.substr(i, tokenLen);
rpn.append(SEP + token);
i += tokenLen - 1;
continue;
}
// is an operator
else
{
// expression is empty or last operand an operator
if (rpn.empty() || (isOperator(token) > 0))
{
rpn.append(SEP + "0");
}
// get precedence
precedence = operators[idx].nPrecedence;
topPrecedence = 0;
// get current operator
tokenLen = static_cast<int>(strlen(operators[idx].pcszOp));
token = szExpr.substr(i, tokenLen);
i += tokenLen - 1;
for (;;)
{
// get top's precedence
if (!st.empty())
{
topToken = st.top();
idx = isOperator(topToken.c_str());
if (idx < 0)
topPrecedence = 1; // give a low priority if operator not ok!
else
topPrecedence = operators[idx].nPrecedence;
}
if (st.empty() || st.top() == "(" ||
precedence > topPrecedence
)
{
st.push(token);
break;
}
// operator has lower precedence then pop it
else
{
st.pop();
rpn.append(SEP + topToken);
}
}
continue;
}
}
for (;;)
{
if (st.empty())
break;
topToken = st.top();
st.pop();
if (topToken != "(")
rpn.append(SEP + topToken);
else
{
return eval_unbalanced;
}
}
return eval_ok;
}
/* Subroutine */ int dtrsna_(char *job, char *howmny, logical *select,
integer *n, doublereal *t, integer *ldt, doublereal *vl, integer *
ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *sep,
integer *mm, integer *m, doublereal *work, integer *ldwork, integer *
iwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DTRSNA estimates reciprocal condition numbers for specified
eigenvalues and/or right eigenvectors of a real upper
quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
orthogonal).
T must be in Schur canonical form (as returned by DHSEQR), that is,
block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
2-by-2 diagonal block has its diagonal elements equal and its
off-diagonal elements of opposite sign.
Arguments
=========
JOB (input) CHARACTER*1
Specifies whether condition numbers are required for
eigenvalues (S) or eigenvectors (SEP):
= 'E': for eigenvalues only (S);
= 'V': for eigenvectors only (SEP);
= 'B': for both eigenvalues and eigenvectors (S and SEP).
HOWMNY (input) CHARACTER*1
= 'A': compute condition numbers for all eigenpairs;
= 'S': compute condition numbers for selected eigenpairs
specified by the array SELECT.
SELECT (input) LOGICAL array, dimension (N)
If HOWMNY = 'S', SELECT specifies the eigenpairs for which
condition numbers are required. To select condition numbers
for the eigenpair corresponding to a real eigenvalue w(j),
SELECT(j) must be set to .TRUE.. To select condition numbers
corresponding to a complex conjugate pair of eigenvalues w(j)
and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
set to .TRUE..
If HOWMNY = 'A', SELECT is not referenced.
N (input) INTEGER
The order of the matrix T. N >= 0.
T (input) DOUBLE PRECISION array, dimension (LDT,N)
The upper quasi-triangular matrix T, in Schur canonical form.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= max(1,N).
VL (input) DOUBLE PRECISION array, dimension (LDVL,M)
If JOB = 'E' or 'B', VL must contain left eigenvectors of T
(or of any Q*T*Q**T with Q orthogonal), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VL, as returned by
DHSEIN or DTREVC.
If JOB = 'V', VL is not referenced.
LDVL (input) INTEGER
The leading dimension of the array VL.
LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
VR (input) DOUBLE PRECISION array, dimension (LDVR,M)
If JOB = 'E' or 'B', VR must contain right eigenvectors of T
(or of any Q*T*Q**T with Q orthogonal), corresponding to the
eigenpairs specified by HOWMNY and SELECT. The eigenvectors
must be stored in consecutive columns of VR, as returned by
DHSEIN or DTREVC.
If JOB = 'V', VR is not referenced.
LDVR (input) INTEGER
The leading dimension of the array VR.
LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
S (output) DOUBLE PRECISION array, dimension (MM)
If JOB = 'E' or 'B', the reciprocal condition numbers of the
selected eigenvalues, stored in consecutive elements of the
array. For a complex conjugate pair of eigenvalues two
consecutive elements of S are set to the same value. Thus
S(j), SEP(j), and the j-th columns of VL and VR all
correspond to the same eigenpair (but not in general the
j-th eigenpair, unless all eigenpairs are selected).
If JOB = 'V', S is not referenced.
SEP (output) DOUBLE PRECISION array, dimension (MM)
If JOB = 'V' or 'B', the estimated reciprocal condition
numbers of the selected eigenvectors, stored in consecutive
elements of the array. For a complex eigenvector two
consecutive elements of SEP are set to the same value. If
the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
is set to 0; this can only occur when the true value would be
very small anyway.
If JOB = 'E', SEP is not referenced.
MM (input) INTEGER
The number of elements in the arrays S (if JOB = 'E' or 'B')
and/or SEP (if JOB = 'V' or 'B'). MM >= M.
M (output) INTEGER
The number of elements of the arrays S and/or SEP actually
used to store the estimated condition numbers.
If HOWMNY = 'A', M is set to N.
WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+1)
If JOB = 'E', WORK is not referenced.
LDWORK (input) INTEGER
The leading dimension of the array WORK.
LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
IWORK (workspace) INTEGER array, dimension (N)
If JOB = 'E', IWORK is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
The reciprocal of the condition number of an eigenvalue lambda is
defined as
S(lambda) = |v'*u| / (norm(u)*norm(v))
where u and v are the right and left eigenvectors of T corresponding
to lambda; v' denotes the conjugate-transpose of v, and norm(u)
denotes the Euclidean norm. These reciprocal condition numbers always
lie between zero (very badly conditioned) and one (very well
conditioned). If n = 1, S(lambda) is defined to be 1.
An approximate error bound for a computed eigenvalue W(i) is given by
EPS * norm(T) / S(i)
where EPS is the machine precision.
The reciprocal of the condition number of the right eigenvector u
corresponding to lambda is defined as follows. Suppose
T = ( lambda c )
( 0 T22 )
Then the reciprocal condition number is
SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
where sigma-min denotes the smallest singular value. We approximate
the smallest singular value by the reciprocal of an estimate of the
one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
defined to be abs(T(1,1)).
An approximate error bound for a computed right eigenvector VR(i)
is given by
EPS * norm(T) / SEP(i)
=====================================================================
Decode and test the input parameters
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static logical c_true = TRUE_;
static logical c_false = FALSE_;
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
work_dim1, work_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer kase;
static doublereal cond;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static logical pair;
static integer ierr;
static doublereal dumm, prod;
static integer ifst;
static doublereal lnrm;
static integer ilst;
static doublereal rnrm;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static doublereal prod1, prod2;
static integer i, j, k;
static doublereal scale, delta;
extern logical lsame_(char *, char *);
static logical wants;
static doublereal dummy[1];
static integer n2;
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
static doublereal cs;
extern doublereal dlamch_(char *);
static integer nn, ks;
extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static doublereal sn, mu;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal bignum;
static logical wantbh;
extern /* Subroutine */ int dlaqtr_(logical *, logical *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *), dtrexc_(char *, integer *
, doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, integer *);
static logical somcon;
static doublereal smlnum;
static logical wantsp;
static doublereal eps, est;
#define DUMMY(I) dummy[(I)]
#define SELECT(I) select[(I)-1]
#define S(I) s[(I)-1]
#define SEP(I) sep[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define T(I,J) t[(I)-1 + ((J)-1)* ( *ldt)]
#define VL(I,J) vl[(I)-1 + ((J)-1)* ( *ldvl)]
#define VR(I,J) vr[(I)-1 + ((J)-1)* ( *ldvr)]
#define WORK(I,J) work[(I)-1 + ((J)-1)* ( *ldwork)]
wantbh = lsame_(job, "B");
wants = lsame_(job, "E") || wantbh;
wantsp = lsame_(job, "V") || wantbh;
somcon = lsame_(howmny, "S");
*info = 0;
if (! wants && ! wantsp) {
*info = -1;
} else if (! lsame_(howmny, "A") && ! somcon) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || wants && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || wants && *ldvr < *n) {
*info = -10;
} else {
/* Set M to the number of eigenpairs for which condition number
s
are required, and test MM. */
if (somcon) {
*m = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= *n; ++k) {
if (pair) {
pair = FALSE_;
} else {
if (k < *n) {
if (T(k+1,k) == 0.) {
if (SELECT(k)) {
++(*m);
}
} else {
pair = TRUE_;
if (SELECT(k) || SELECT(k + 1)) {
*m += 2;
}
}
} else {
if (SELECT(*n)) {
++(*m);
}
}
}
/* L10: */
}
} else {
*m = *n;
}
if (*mm < *m) {
*info = -13;
} else if (*ldwork < 1 || wantsp && *ldwork < *n) {
*info = -16;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTRSNA", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (somcon) {
if (! SELECT(1)) {
return 0;
}
}
if (wants) {
S(1) = 1.;
}
if (wantsp) {
SEP(1) = (d__1 = T(1,1), abs(d__1));
}
return 0;
}
/* Get machine constants */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
ks = 0;
pair = FALSE_;
i__1 = *n;
for (k = 1; k <= *n; ++k) {
/* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */
if (pair) {
pair = FALSE_;
goto L60;
} else {
if (k < *n) {
pair = T(k+1,k) != 0.;
}
}
/* Determine whether condition numbers are required for the k-t
h
eigenpair. */
if (somcon) {
if (pair) {
if (! SELECT(k) && ! SELECT(k + 1)) {
goto L60;
}
} else {
if (! SELECT(k)) {
goto L60;
}
}
}
++ks;
if (wants) {
/* Compute the reciprocal condition number of the k-th
eigenvalue. */
if (! pair) {
/* Real eigenvalue. */
prod = ddot_(n, &VR(1,ks), &c__1, &VL(1,ks), &c__1);
rnrm = dnrm2_(n, &VR(1,ks), &c__1);
lnrm = dnrm2_(n, &VL(1,ks), &c__1);
S(ks) = abs(prod) / (rnrm * lnrm);
} else {
/* Complex eigenvalue. */
prod1 = ddot_(n, &VR(1,ks), &c__1, &VL(1,ks), &c__1);
prod1 += ddot_(n, &VR(1,ks+1), &c__1, &VL(1,ks+1), &c__1);
prod2 = ddot_(n, &VL(1,ks), &c__1, &VR(1,ks+1), &c__1);
prod2 -= ddot_(n, &VL(1,ks+1), &c__1, &VR(1,ks), &c__1);
d__1 = dnrm2_(n, &VR(1,ks), &c__1);
d__2 = dnrm2_(n, &VR(1,ks+1), &c__1);
rnrm = dlapy2_(&d__1, &d__2);
d__1 = dnrm2_(n, &VL(1,ks), &c__1);
d__2 = dnrm2_(n, &VL(1,ks+1), &c__1);
lnrm = dlapy2_(&d__1, &d__2);
cond = dlapy2_(&prod1, &prod2) / (rnrm * lnrm);
S(ks) = cond;
S(ks + 1) = cond;
}
}
if (wantsp) {
/* Estimate the reciprocal condition number of the k-th
eigenvector.
Copy the matrix T to the array WORK and swap the diag
onal
block beginning at T(k,k) to the (1,1) position. */
dlacpy_("Full", n, n, &T(1,1), ldt, &WORK(1,1),
ldwork);
ifst = k;
ilst = 1;
dtrexc_("No Q", n, &WORK(1,1), ldwork, dummy, &c__1, &
ifst, &ilst, &WORK(1,*n+1), &ierr);
if (ierr == 1 || ierr == 2) {
/* Could not swap because blocks not well separat
ed */
scale = 1.;
est = bignum;
} else {
/* Reordering successful */
if (WORK(2,1) == 0.) {
/* Form C = T22 - lambda*I in WORK(2:N,2:N
). */
i__2 = *n;
for (i = 2; i <= *n; ++i) {
WORK(i,i) -= WORK(1,1);
/* L20: */
}
n2 = 1;
nn = *n - 1;
} else {
/* Triangularize the 2 by 2 block by unita
ry
transformation U = [ cs i*ss ]
[ i*ss cs ].
such that the (1,1) position of WORK is
complex
eigenvalue lambda with positive imagina
ry part. (2,2)
position of WORK is the complex eigenva
lue lambda
with negative imaginary part. */
mu = sqrt((d__1 = WORK(1,2), abs(d__1)))
* sqrt((d__2 = WORK(2,1), abs(d__2)));
delta = dlapy2_(&mu, &WORK(2,1));
cs = mu / delta;
sn = -WORK(2,1) / delta;
/* Form
C' = WORK(2:N,2:N) + i*[rwork(1) .....
rwork(n-1) ]
[ mu
]
[ ..
]
[ ..
]
[
mu ]
where C' is conjugate transpose of comp
lex matrix C,
and RWORK is stored starting in the N+1
-st column of
WORK. */
i__2 = *n;
for (j = 3; j <= *n; ++j) {
WORK(2,j) = cs * WORK(2,j)
;
WORK(j,j) -= WORK(1,1);
/* L30: */
}
WORK(2,2) = 0.;
WORK(1,*n+1) = mu * 2.;
i__2 = *n - 1;
for (i = 2; i <= *n-1; ++i) {
WORK(i,*n+1) = sn * WORK(1,i+1);
/* L40: */
}
n2 = 2;
nn = *n - 1 << 1;
}
/* Estimate norm(inv(C')) */
est = 0.;
kase = 0;
L50:
dlacon_(&nn, &WORK(1,*n+2), &WORK(1,*n+4), &IWORK(1), &est, &kase);
if (kase != 0) {
if (kase == 1) {
if (n2 == 1) {
/* Real eigenvalue: solve C'
*x = scale*c. */
i__2 = *n - 1;
dlaqtr_(&c_true, &c_true, &i__2, &WORK(2,2), ldwork, dummy, &dumm, &scale,
&WORK(1,*n+4), &WORK(1,*n+6), &ierr);
} else {
/* Complex eigenvalue: solve
C'*(p+iq) = scale*(c+id)
in real arithmetic. */
i__2 = *n - 1;
dlaqtr_(&c_true, &c_false, &i__2, &WORK(2,2), ldwork, &WORK(1,*n+1), &mu, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &ierr);
}
} else {
if (n2 == 1) {
/* Real eigenvalue: solve C*
x = scale*c. */
i__2 = *n - 1;
dlaqtr_(&c_false, &c_true, &i__2, &WORK(2,2), ldwork, dummy, &
dumm, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &
ierr);
} else {
/* Complex eigenvalue: solve
C*(p+iq) = scale*(c+id) i
n real arithmetic. */
i__2 = *n - 1;
dlaqtr_(&c_false, &c_false, &i__2, &WORK(2,2), ldwork, &WORK(1,*n+1), &mu, &scale, &WORK(1,*n+4), &WORK(1,*n+6), &ierr);
}
}
goto L50;
}
}
SEP(ks) = scale / max(est,smlnum);
if (pair) {
SEP(ks + 1) = SEP(ks);
}
}
if (pair) {
++ks;
}
L60:
;
}
return 0;
/* End of DTRSNA */
} /* dtrsna_ */
