/*! \brief
* <pre>
* Purpose
* =======
* ilu_zdrop_row() - Drop some small rows from the previous
* supernode (L-part only).
* </pre>
*/
int ilu_zdrop_row(
superlu_options_t *options, /* options */
int first, /* index of the first column in the supernode */
int last, /* index of the last column in the supernode */
double drop_tol, /* dropping parameter */
int quota, /* maximum nonzero entries allowed */
int *nnzLj, /* in/out number of nonzeros in L(:, 1:last) */
double *fill_tol, /* in/out - on exit, fill_tol=-num_zero_pivots,
* does not change if options->ILU_MILU != SMILU1 */
GlobalLU_t *Glu, /* modified */
double dwork[], /* working space
* the length of dwork[] should be no less than
* the number of rows in the supernode */
double dwork2[], /* working space with the same size as dwork[],
* used only by the second dropping rule */
int lastc /* if lastc == 0, there is nothing after the
* working supernode [first:last];
* if lastc == 1, there is one more column after
* the working supernode. */ )
{
register int i, j, k, m1;
register int nzlc; /* number of nonzeros in column last+1 */
register int xlusup_first, xlsub_first;
int m, n; /* m x n is the size of the supernode */
int r = 0; /* number of dropped rows */
register double *temp;
register doublecomplex *lusup = Glu->lusup;
register int *lsub = Glu->lsub;
register int *xlsub = Glu->xlsub;
register int *xlusup = Glu->xlusup;
register double d_max = 0.0, d_min = 1.0;
int drop_rule = options->ILU_DropRule;
milu_t milu = options->ILU_MILU;
norm_t nrm = options->ILU_Norm;
doublecomplex zero = {0.0, 0.0};
doublecomplex one = {1.0, 0.0};
doublecomplex none = {-1.0, 0.0};
int i_1 = 1;
int inc_diag; /* inc_diag = m + 1 */
int nzp = 0; /* number of zero pivots */
double alpha = pow((double)(Glu->n), -1.0 / options->ILU_MILU_Dim);
xlusup_first = xlusup[first];
xlsub_first = xlsub[first];
m = xlusup[first + 1] - xlusup_first;
n = last - first + 1;
m1 = m - 1;
inc_diag = m + 1;
nzlc = lastc ? (xlusup[last + 2] - xlusup[last + 1]) : 0;
temp = dwork - n;
/* Quick return if nothing to do. */
if (m == 0 || m == n || drop_rule == NODROP)
{
*nnzLj += m * n;
return 0;
}
/* basic dropping: ILU(tau) */
for (i = n; i <= m1; )
{
/* the average abs value of ith row */
switch (nrm)
{
case ONE_NORM:
temp[i] = dzasum_(&n, &lusup[xlusup_first + i], &m) / (double)n;
break;
case TWO_NORM:
temp[i] = dznrm2_(&n, &lusup[xlusup_first + i], &m)
/ sqrt((double)n);
break;
case INF_NORM:
default:
k = izamax_(&n, &lusup[xlusup_first + i], &m) - 1;
temp[i] = z_abs1(&lusup[xlusup_first + i + m * k]);
break;
}
/* drop small entries due to drop_tol */
if (drop_rule & DROP_BASIC && temp[i] < drop_tol)
{
r++;
/* drop the current row and move the last undropped row here */
if (r > 1) /* add to last row */
{
/* accumulate the sum (for MILU) */
switch (milu)
{
case SMILU_1:
case SMILU_2:
zaxpy_(&n, &one, &lusup[xlusup_first + i], &m,
&lusup[xlusup_first + m - 1], &m);
break;
case SMILU_3:
for (j = 0; j < n; j++)
lusup[xlusup_first + (m - 1) + j * m].r +=
z_abs1(&lusup[xlusup_first + i + j * m]);
break;
case SILU:
default:
break;
}
zcopy_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
} /* if (r > 1) */
else /* move to last row */
{
zswap_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
if (milu == SMILU_3)
for (j = 0; j < n; j++) {
lusup[xlusup_first + m1 + j * m].r =
z_abs1(&lusup[xlusup_first + m1 + j * m]);
lusup[xlusup_first + m1 + j * m].i = 0.0;
}
}
lsub[xlsub_first + i] = lsub[xlsub_first + m1];
m1--;
continue;
} /* if dropping */
else
{
if (temp[i] > d_max) d_max = temp[i];
if (temp[i] < d_min) d_min = temp[i];
}
i++;
} /* for */
/* Secondary dropping: drop more rows according to the quota. */
quota = ceil((double)quota / (double)n);
if (drop_rule & DROP_SECONDARY && m - r > quota)
{
register double tol = d_max;
/* Calculate the second dropping tolerance */
if (quota > n)
{
if (drop_rule & DROP_INTERP) /* by interpolation */
{
d_max = 1.0 / d_max; d_min = 1.0 / d_min;
tol = 1.0 / (d_max + (d_min - d_max) * quota / (m - n - r));
}
else /* by quick select */
{
int len = m1 - n + 1;
dcopy_(&len, dwork, &i_1, dwork2, &i_1);
tol = dqselect(len, dwork2, quota - n);
#if 0
register int *itemp = iwork - n;
A = temp;
for (i = n; i <= m1; i++) itemp[i] = i;
qsort(iwork, m1 - n + 1, sizeof(int), _compare_);
tol = temp[itemp[quota]];
#endif
}
}
for (i = n; i <= m1; )
{
if (temp[i] <= tol)
{
register int j;
r++;
/* drop the current row and move the last undropped row here */
if (r > 1) /* add to last row */
{
/* accumulate the sum (for MILU) */
switch (milu)
{
case SMILU_1:
case SMILU_2:
zaxpy_(&n, &one, &lusup[xlusup_first + i], &m,
&lusup[xlusup_first + m - 1], &m);
break;
case SMILU_3:
for (j = 0; j < n; j++)
lusup[xlusup_first + (m - 1) + j * m].r +=
z_abs1(&lusup[xlusup_first + i + j * m]);
break;
case SILU:
default:
break;
}
zcopy_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
} /* if (r > 1) */
else /* move to last row */
{
zswap_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
if (milu == SMILU_3)
for (j = 0; j < n; j++) {
lusup[xlusup_first + m1 + j * m].r =
z_abs1(&lusup[xlusup_first + m1 + j * m]);
lusup[xlusup_first + m1 + j * m].i = 0.0;
}
}
lsub[xlsub_first + i] = lsub[xlsub_first + m1];
m1--;
temp[i] = temp[m1];
continue;
}
i++;
} /* for */
} /* if secondary dropping */
for (i = n; i < m; i++) temp[i] = 0.0;
if (r == 0)
{
*nnzLj += m * n;
return 0;
}
/* add dropped entries to the diagnal */
if (milu != SILU)
{
register int j;
doublecomplex t;
double omega;
for (j = 0; j < n; j++)
{
t = lusup[xlusup_first + (m - 1) + j * m];
if (t.r == 0.0 && t.i == 0.0) continue;
omega = SUPERLU_MIN(2.0 * (1.0 - alpha) / z_abs1(&t), 1.0);
zd_mult(&t, &t, omega);
switch (milu)
{
case SMILU_1:
if ( !(z_eq(&t, &none)) ) {
z_add(&t, &t, &one);
zz_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
&t);
}
else
{
zd_mult(
&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
*fill_tol);
#ifdef DEBUG
printf("[1] ZERO PIVOT: FILL col %d.\n", first + j);
fflush(stdout);
#endif
nzp++;
}
break;
case SMILU_2:
zd_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
1.0 + z_abs1(&t));
break;
case SMILU_3:
z_add(&t, &t, &one);
zz_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
&t);
break;
case SILU:
default:
break;
}
}
if (nzp > 0) *fill_tol = -nzp;
}
/* Remove dropped entries from the memory and fix the pointers. */
m1 = m - r;
for (j = 1; j < n; j++)
{
register int tmp1, tmp2;
tmp1 = xlusup_first + j * m1;
tmp2 = xlusup_first + j * m;
for (i = 0; i < m1; i++)
lusup[i + tmp1] = lusup[i + tmp2];
}
for (i = 0; i < nzlc; i++)
lusup[xlusup_first + i + n * m1] = lusup[xlusup_first + i + n * m];
for (i = 0; i < nzlc; i++)
lsub[xlsub[last + 1] - r + i] = lsub[xlsub[last + 1] + i];
for (i = first + 1; i <= last + 1; i++)
{
xlusup[i] -= r * (i - first);
xlsub[i] -= r;
}
if (lastc)
{
xlusup[last + 2] -= r * n;
xlsub[last + 2] -= r;
}
*nnzLj += (m - r) * n;
return r;
}
int actual_main(int argc, char* argv[])
{
double wtime_order;
double wtime_permute;
double wtime_factor;
double wtime_solve;
/*double wtime_precond_create; omer*/
double ctime_factor;
int i;/*,j omer*/
double NormErr;
taucs_ccs_matrix* A = NULL;
taucs_ccs_matrix* PAPT = NULL;
taucs_ccs_matrix* L = NULL;
double* Xd = NULL;
double* Bd = NULL;
double* PXd = NULL;
double* PBd = NULL;
double* NXd = NULL;
float* Xs = NULL;
float* Bs = NULL;
float* PXs = NULL;
float* PBs = NULL;
float* NXs = NULL;
taucs_dcomplex* Xz = NULL;
taucs_dcomplex* Bz = NULL;
taucs_dcomplex* PXz = NULL;
taucs_dcomplex* PBz = NULL;
taucs_dcomplex* NXz = NULL;
char* ordering = "metis";
char* mat_type = "neumann";
int* perm;
int* invperm;
int precision = TAUCS_DOUBLE;
int ldlt_flag = 0;
int snmf_flag = 0;
int snll_flag = 0;
int symb_flag = 0;
int mesh2d_flag = 0,mesh2d_size = 0;
int ooc_flag = 0;
int panelize = 0;
double memory_mb = -1.0;
char* matrixfile = "/tmp/taucs.L";
taucs_io_handle* oocL = NULL;
int (*precond_fn)(void*,void* x,void* b);
void* precond_args;
/***********************************************************/
/* Read arguments: log file, matrix, memory size, ooc name */
/***********************************************************/
if ((argc == 1) ||((argc == 2) && !strncmp(argv[1],"-h",2)))
usage(argc,argv);
A = NULL;
for (i=1; i<argc; i++) {
if (!strcmp(argv[i],"-single")) precision = TAUCS_SINGLE;
if (!strcmp(argv[i],"-dcomplex")) precision = TAUCS_DCOMPLEX;
if (!strcmp(argv[i],"-ldlt")) ldlt_flag = 1;
if (!strcmp(argv[i],"-snmf")) snmf_flag = 1;
if (!strcmp(argv[i],"-snll")) snll_flag = 1;
if (!strcmp(argv[i],"-symb")) symb_flag = 1;
if (!strcmp(argv[i],"-ooc")) ooc_flag = 1;
if (!strcmp(argv[i],"-log") && i <= argc-1 ) {
i++;
taucs_logfile(argv[i]);
}
if (!strcmp(argv[i],"-panelize") && i <= argc-1) {
i++;
if (sscanf(argv[i],"%d",&panelize) != 1) {
taucs_printf("0 (smart), 1 (in-core), or 2 (single supernode) follow -panelize argument\n");
exit(1);
}
}
if (!strcmp(argv[i],"-memory") && i <= argc-1) {
i++;
if (sscanf(argv[i],"%lf",&memory_mb) != 1) {
taucs_printf("memory size in MB must follow -memory argument\n");
exit(1);
}
}
if (!strcmp(argv[i],"-matrixfile") && i <= argc-1 ) {
i++;
matrixfile = argv[i];
}
if (!strcmp(argv[i],"-ordering") && i <= argc-1 ) {
i++;
ordering = argv[i];
}
if (!strcmp(argv[i],"-mat_type") && i <= argc-1 ) {
i++;
mat_type = argv[i];
}
#if 0
if (!strcmp(argv[i],"-hb") && i <= argc-1 ) {
int nrows,ncols,nnz,j;
char fname[256];
char type[3];
i++;
for (j=0; j<256; j++) fname[j] = ' ';
strcpy(fname,argv[i]);
taucs_printf("main: reading HB matrix %s\n",argv[i]);
ireadhb_(fname,type,&nrows,&ncols,&nnz);
A = taucs_dccs_creagte(nrows,ncols,nnz);
if (type[1] == 's' || type[1] == 'S')
A->flags |= TAUCS_SYMMETRIC | TAUCS_LOWER;
dreadhb_(fname,&nrows,&ncols,&nnz,
A->colptr,A->rowind,A->values);
/* make indices 0-based */
for (j=0; j<=ncols; j++) ((A->colptr)[j])--;
for (j=0; j<nnz; j++) ((A->rowind)[j])--;
taucs_printf("main: done reading\n");
}
#endif
if (!strcmp(argv[i],"-hb") && i <= argc-1) {
i++;
taucs_printf("main: reading hb matrix %s\n",argv[i]);
switch (precision) {
case TAUCS_SINGLE:
A = taucs_ccs_read_hb (argv[i], TAUCS_SINGLE); break;
case TAUCS_DOUBLE:
A = taucs_ccs_read_hb (argv[i], TAUCS_DOUBLE); break;
case TAUCS_DCOMPLEX:
A = taucs_ccs_read_hb (argv[i], TAUCS_DCOMPLEX); break;
default:
taucs_printf("main: unknown precision\n");
exit(1);
}
taucs_printf("main: done reading\n");
}
if (!strcmp(argv[i],"-mtx") && i <= argc-1) {
i++;
taucs_printf("main: reading mtx matrix %s\n",argv[i]);
A = taucs_ccs_read_mtx (argv[i],TAUCS_SYMMETRIC | TAUCS_PATTERN);
taucs_printf("main: done reading\n");
}
if (!strcmp(argv[i],"-ijv") && i <= argc-1) {
printf(">>> ijv\n");
i++;
taucs_printf("main: reading ijv matrix %s\n",argv[i]);
switch (precision) {
case TAUCS_SINGLE:
A = taucs_ccs_read_ijv (argv[i],TAUCS_SYMMETRIC | TAUCS_SINGLE); break;
case TAUCS_DOUBLE:
A = taucs_ccs_read_ijv (argv[i],TAUCS_SYMMETRIC | TAUCS_DOUBLE); break;
case TAUCS_DCOMPLEX:
A = taucs_ccs_read_ijv (argv[i],TAUCS_HERMITIAN | TAUCS_DCOMPLEX); break;
default:
taucs_printf("main: unknown precision\n");
exit(1);
}
taucs_printf("main: done reading\n");
}
if (!strcmp(argv[i],"-ccs") && i <= argc-1) {
i++;
taucs_printf("main: reading ccs matrix %s\n",argv[i]);
A = taucs_ccs_read_ccs (argv[i],TAUCS_SYMMETRIC);
taucs_printf("main: done reading\n");
}
if (!strcmp(argv[i],"-mesh2d") && i <= argc-1) {
mesh2d_flag = 1;
taucs_printf("A is a mesh2d\n");
i++;
if (sscanf(argv[i],"%d",&mesh2d_size) != 1) {
taucs_printf("mesh size (n, where the mesh is n-by-n) must follow -mesh2d argument\n");
exit(1);
}
}
if (!strcmp(argv[i],"-mesh3d") && i <= argc-3) {
int X,Y,Z;
taucs_printf("A is a mesh3d\n");
if (sscanf(argv[i+1],"%d",&X) != 1
|| sscanf(argv[i+2],"%d",&Y) != 1
|| sscanf(argv[i+3],"%d",&Z) != 1) {
taucs_printf("mesh size (X Y Z must follow -mesh3d argument\n");
exit(1);
}
i += 3;
taucs_printf("main: creating mesh\n");
A = taucs_ccs_generate_mesh3d(X,Y,Z);
}
if (!strcmp(argv[i],"-n+rhs") && i <= argc-1) {
FILE* f;
int n,j,nnz;
i++;
taucs_printf("main: reading right-hand side %s\n",argv[i]);
f=fopen(argv[i],"r");
assert(f);
fscanf(f,"%d",&n);
Bd=(double*) malloc(n*sizeof(double));
nnz = 0;
for (j=0; j<n; j++) {
fscanf(f,"%lg",(Bd)+j);
if (Bd[j]) nnz++;
}
fclose(f);
taucs_printf("main: done reading rhs, %d nonzeros\n",nnz);
}
}
taucs_printf("Chosen Ordering: %s\n",ordering);
if (mesh2d_flag)
{
taucs_printf("Matrix type is %s\n",mat_type);
taucs_printf("Grid Size is %d\n",mesh2d_size);
A = taucs_ccs_generate_mesh2d(mesh2d_size,mat_type);
}
if (!A) {
taucs_printf("matrix argument not given or matrix file not found\n");
usage(argc,argv);
}
N = M = A->n;
/*taucs_maximize_stacksize();*/
/***********************************************************/
/* Create exact solution, compute right-hand-side */
/***********************************************************/
if (A->flags & TAUCS_SINGLE) {
if (! (Xs)) {
Xs = (float*)malloc(N*sizeof(float));
/*for(i=0; i<N; i++) (Xs)[i]=(double)random()/RAND_MAX; omer*/
for(i=0; i<N; i++) (Xs)[i]=(float)((double)rand()/RAND_MAX);
} else
taucs_printf("iter: not using a random X, already allocated\n");
if (!(Bs)) {
Bs = (float*)malloc(N*sizeof(float));
taucs_ccs_times_vec(A,Xs,Bs);
} else {
/*double zero1 = 0.0;
double nan = zero1 / zero1; omer*/
double nan = taucs_get_nan();
for(i=0; i<N; i++) Xs[i]= (float)nan;
}
NXs=(float*)malloc(N*sizeof(float));
PXs=(float*)malloc(N*sizeof(float));
PBs=(float*)malloc(N*sizeof(float));
}
if (A->flags & TAUCS_DOUBLE) {
if (! (Xd)) {
Xd =(double*)malloc(N*sizeof(double));
/*for(i=0; i<N; i++) (Xd)[i]=(double)rand()/RAND_MAX; omer*/
for(i=0; i<N; i++) (Xd)[i]=(float)((double)rand()/RAND_MAX);
} else
taucs_printf("iter: not using a random X, already allocated\n");
if (!(Bd)) {
Bd =(double*)malloc(N*sizeof(double));
taucs_ccs_times_vec(A,Xd,Bd);
} else {
/*double zero1 = 0.0;
double nan = zero1 / zero1; omer*/
double nan = taucs_get_nan();
for(i=0; i<N; i++) Xd[i]= (float)nan;
}
NXd=(double*)malloc(N*sizeof(double));
PXd=(double*)malloc(N*sizeof(double));
PBd=(double*)malloc(N*sizeof(double));
}
if (A->flags & TAUCS_DCOMPLEX) {
if (!(Xz)) {
double* p;
taucs_printf("direct: creating a random dcomplex X\n");
Xz =(taucs_dcomplex*)malloc(N*sizeof(taucs_dcomplex));
p = (double*) Xz;
for(i=0; i<2*N; i++) p[i] = (double)rand()/RAND_MAX;
} else
taucs_printf("iter: not using a random X, already allocated\n");
if (!(Bz)) {
Bz =(taucs_dcomplex*)malloc(N*sizeof(taucs_dcomplex));
taucs_ccs_times_vec(A,Xz,Bz);
} else {
double* p;
/*double zero1 = 0.0;
double nan = zero1 / zero1; omer*/
double nan = taucs_get_nan();
p = (double*) Xz;
for(i=0; i<2*N; i++) p[i] = nan;
}
NXz=(taucs_dcomplex*)malloc(N*sizeof(taucs_dcomplex));
PXz=(taucs_dcomplex*)malloc(N*sizeof(taucs_dcomplex));
PBz=(taucs_dcomplex*)malloc(N*sizeof(taucs_dcomplex));
}
/***********************************************************/
/* Compute column ordering */
/***********************************************************/
/***********************************************************/
/* factor */
/***********************************************************/
{
int n;
double unit;
n = A->n;
unit = (n-1.)+n;
wtime_order = taucs_wtime();
taucs_ccs_order(A,&perm,&invperm,ordering);
wtime_order = taucs_wtime() - wtime_order;
taucs_printf("\tOrdering time = % 10.3f seconds\n",wtime_order);
if (!perm) {
taucs_printf("\tOrdering Failed\n");
exit(1);
}
if (0) {
int i;
FILE* f;
f=fopen("p.ijv","w");
for (i=0; i<n; i++) fprintf(f,"%d\n",perm[i]+1);
fclose(f);
}
if (A->flags & TAUCS_SYMMETRIC || A->flags & TAUCS_HERMITIAN) {
wtime_permute = taucs_wtime();
PAPT = taucs_ccs_permute_symmetrically(A,perm,invperm);
wtime_permute = taucs_wtime() - wtime_permute;
taucs_printf("\tPermute time = % 10.3f seconds\n",wtime_permute);
}
wtime_factor = taucs_wtime();
ctime_factor = taucs_ctime();
if (ldlt_flag) {
L = taucs_ccs_factor_ldlt(PAPT);
precond_args = L;
precond_fn = taucs_ccs_solve_ldlt;
} else if (snmf_flag) {
/*taucs_ccs_matrix* C;*/
L = taucs_ccs_factor_llt_mf(PAPT);
precond_args = L;
precond_fn = taucs_supernodal_solve_llt;
{
taucs_ccs_matrix* C;
C = taucs_supernodal_factor_to_ccs(L);
/*taucs_ccs_write_ijv(PAPT,"PAPT.ijv");*/
/*C->flags = TAUCS_DCOMPLEX | TAUCS_TRIANGULAR | TAUCS_LOWER;*/
precond_args = C;
precond_fn = taucs_ccs_solve_llt;
/*taucs_ccs_write_ijv(C,"L.ijv");*/
/*
{
int i;
double* diag = taucs_supernodal_factor_get_diag(L);
for (i=0; i<C->n; i++) {
printf("%.2le\n",diag[i]);
}
}
*/
}
} else if (ooc_flag) {
if (A->flags & TAUCS_SYMMETRIC || A->flags & TAUCS_HERMITIAN) {
#define TESTING
#ifdef TESTING
int taucs_ooc_factor_llt_panelchoice(taucs_ccs_matrix* A,
taucs_io_handle* handle,
double memory,
int panelization_method);
/*int c; omer*/
oocL = taucs_io_create_multifile(matrixfile);
assert(oocL);
if (memory_mb == -1.0) memory_mb = taucs_available_memory_size()/1048576.0;
taucs_ooc_factor_llt_panelchoice(PAPT, oocL, memory_mb*1048576.0,panelize);
precond_args = oocL;
precond_fn = taucs_ooc_solve_llt;
#else
/*int c;*/
oocL = taucs_io_create_multifile(matrixfile);
assert(oocL);
if (memory_mb == -1.0) memory_mb = taucs_available_memory_size()/1048576.0;
taucs_ooc_factor_llt(PAPT, oocL, memory_mb*1048576.0);
precond_args = oocL;
precond_fn = taucs_ooc_solve_llt;
#endif
} else {
if (memory_mb == -1.0) memory_mb = taucs_available_memory_size()/1048576.0;
oocL = taucs_io_create_multifile(matrixfile);
taucs_ooc_factor_lu(A, perm, oocL, memory_mb*1048576.0);
precond_args = matrixfile;
precond_fn = NULL;
}
} else if (snll_flag) {
L = taucs_ccs_factor_llt_ll(PAPT);
precond_args = L;
precond_fn = taucs_supernodal_solve_llt;
} else if (symb_flag) {
L = taucs_ccs_factor_llt_symbolic(PAPT);
taucs_ccs_factor_llt_numeric(PAPT,L); /* should check error code */
precond_args = L;
precond_fn = taucs_supernodal_solve_llt;
} else {
L = taucs_ccs_factor_llt(PAPT,0.0,0);
precond_args = L;
precond_fn = taucs_ccs_solve_llt;
}
wtime_factor = taucs_wtime() - wtime_factor;
ctime_factor = taucs_ctime() - ctime_factor;
taucs_printf("\tFactor time = % 10.3f seconds ",wtime_factor);
taucs_printf("(%.3f cpu time)\n",ctime_factor);
}
if (!L && !ooc_flag /* no L in ooc */) {
taucs_printf("\tFactorization Failed\n");
exit(1);
}
/*taucs_ccs_write_ijv(PAPT,"A.ijv",1);*/ /* 1 = complete the upper part */
/*taucs_ccs_write_ijv(L,"L.ijv",0);*/
/***********************************************************/
/* solve */
/***********************************************************/
if (!L) {
taucs_printf("FACTORIZATION FAILED!\n");
exit(1);
}
if (A->flags & TAUCS_SYMMETRIC || A->flags & TAUCS_HERMITIAN) {
if (A->flags & TAUCS_DOUBLE)
taucs_vec_permute(A->n,A->flags,Bd,PBd,perm);
if (A->flags & TAUCS_SINGLE)
taucs_vec_permute(A->n,A->flags,Bs,PBs,perm);
if (A->flags & TAUCS_DCOMPLEX)
taucs_vec_permute(A->n,A->flags,Bz,PBz,perm);
wtime_solve = taucs_wtime();
if (A->flags & TAUCS_DOUBLE)
precond_fn(precond_args,PXd,PBd); /* direct solver */
if (A->flags & TAUCS_SINGLE)
precond_fn(precond_args,PXs,PBs); /* direct solver */
if (A->flags & TAUCS_DCOMPLEX)
precond_fn(precond_args,PXz,PBz); /* direct solver */
#ifdef TAUCS_CONFIG_SINGLE
if (A->flags & TAUCS_SINGLE) {
taucs_sccs_times_vec_dacc(PAPT,PXs,NXs);
for(i=0; i<(A->n); i++) NXs[i] -= PBs[i];
precond_fn(precond_args,PBs,NXs); /* direct solver */
for(i=0; i<(A->n); i++) PXs[i] -= PBs[i];
}
#endif
wtime_solve = taucs_wtime() - wtime_solve;
taucs_printf("\tSolve time = % 10.3f seconds\n",wtime_solve);
if (A->flags & TAUCS_DOUBLE)
taucs_vec_ipermute(A->n,A->flags,PXd,NXd,perm);
if (A->flags & TAUCS_SINGLE)
taucs_vec_ipermute(A->n,A->flags,PXs,NXs,perm);
if (A->flags & TAUCS_DCOMPLEX)
taucs_vec_ipermute(A->n,A->flags,PXz,NXz,perm);
} else {
taucs_ooc_solve_lu(oocL, NXd, Bd);
}
/***********************************************************/
/* delete out-of-core matrices */
/***********************************************************/
if (ooc_flag) {
taucs_io_delete(oocL);
/*taucs_io_close(oocL);*/
}
/***********************************************************/
/* Compute norm of forward error */
/***********************************************************/
if (A->flags & TAUCS_SINGLE) {
float snrm2_();
int one = 1;
NormErr = 0.0;
for(i=0; i<N; i++) NormErr = max(NormErr,fabs((NXs[i]-Xs[i])/Xs[i]));
for(i=0; i<N; i++) PXs[i] = NXs[i]-Xs[i];
taucs_printf("main: max relative error = %1.6e, 2-norm relative error %.2e \n",
NormErr,
snrm2_(&(A->n),PXs,&one)/snrm2_(&(A->n),Xs,&one));
}
if (A->flags & TAUCS_DOUBLE) {
double dnrm2_();
int one = 1;
NormErr = 0.0;
for(i=0; i<N; i++) NormErr = max(NormErr,fabs((NXd[i]-Xd[i])/Xd[i]));
for(i=0; i<N; i++) PXd[i] = NXd[i]-Xd[i];
taucs_printf("main: max relative error = %1.6e, 2-norm relative error %.2e \n",
NormErr,
dnrm2_(&(A->n),PXd,&one)/dnrm2_(&(A->n),Xd,&one));
}
#ifdef TAUCS_CONFIG_DCOMPLEX
if (A->flags & TAUCS_DCOMPLEX) {
double dznrm2_();
int one = 1;
double* pX = (double*) Xz;
double* pNX = (double*) NXz;
double* pPX = (double*) PXz;
taucs_dcomplex zzero = taucs_zzero_const;
taucs_dcomplex zone = taucs_zone_const;
taucs_dcomplex zmone = taucs_zneg(taucs_zone_const);
NormErr = 0.0;
/*
for(i=0; i<N; i++) NormErr = max(NormErr,fabs((NXd[i]-Xd[i])/Xd[i]));
*/
/*for(i=0; i<N; i++) PXd[i] = NXd[i]-Xd[i];*/
/*for(i=0; i<N; i++) PXz[i] = taucs_add(NXz[i],taucs_neg(Xz[i]));*/
zscal_(&(A->n),&zzero,pPX,&one);
zaxpy_(&(A->n),&zone ,pNX,&one,pPX,&one);
zaxpy_(&(A->n),&zmone,pX ,&one,pPX,&one);
taucs_printf("main: max relative error = %1.6e, 2-norm relative error %.2e \n",
NormErr,
dznrm2_(&(A->n),PXz,&one)/dznrm2_(&(A->n),Xz,&one));
}
#endif
/***********************************************************/
/* Exit */
/***********************************************************/
taucs_printf("main: done\n");
return 0;
}
/* Subroutine */ int zgtt01_(integer *n, doublecomplex *dl, doublecomplex *
d__, doublecomplex *du, doublecomplex *dlf, doublecomplex *df,
doublecomplex *duf, doublecomplex *du2, integer *ipiv, doublecomplex *
work, integer *ldwork, doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer work_dim1, work_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
integer i__, j;
doublecomplex li;
integer ip;
doublereal eps, anorm;
integer lastj;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGTT01 reconstructs a tridiagonal matrix A from its LU factorization */
/* and computes the residual */
/* norm(L*U - A) / ( norm(A) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* N (input) INTEGTER */
/* The order of the matrix A. N >= 0. */
/* DL (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) sub-diagonal elements of A. */
/* D (input) COMPLEX*16 array, dimension (N) */
/* The diagonal elements of A. */
/* DU (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) super-diagonal elements of A. */
/* DLF (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) multipliers that define the matrix L from the */
/* LU factorization of A. */
/* DF (input) COMPLEX*16 array, dimension (N) */
/* The n diagonal elements of the upper triangular matrix U from */
/* the LU factorization of A. */
/* DUF (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) elements of the first super-diagonal of U. */
/* DU2 (input) COMPLEX*16 array, dimension (N-2) */
/* The (n-2) elements of the second super-diagonal of U. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
/* interchanged with row IPIV(i). IPIV(i) will always be either */
/* i or i+1; IPIV(i) = i indicates a row interchange was not */
/* required. */
/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* The scaled residual: norm(L*U - A) / (norm(A) * EPS) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--dl;
--d__;
--du;
--dlf;
--df;
--duf;
--du2;
--ipiv;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
eps = dlamch_("Epsilon");
/* Copy the matrix U to WORK. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * work_dim1;
work[i__3].r = 0., work[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == 1) {
i__2 = i__ + i__ * work_dim1;
i__3 = i__;
work[i__2].r = df[i__3].r, work[i__2].i = df[i__3].i;
if (*n >= 2) {
i__2 = i__ + (i__ + 1) * work_dim1;
i__3 = i__;
work[i__2].r = duf[i__3].r, work[i__2].i = duf[i__3].i;
}
if (*n >= 3) {
i__2 = i__ + (i__ + 2) * work_dim1;
i__3 = i__;
work[i__2].r = du2[i__3].r, work[i__2].i = du2[i__3].i;
}
} else if (i__ == *n) {
i__2 = i__ + i__ * work_dim1;
i__3 = i__;
work[i__2].r = df[i__3].r, work[i__2].i = df[i__3].i;
} else {
i__2 = i__ + i__ * work_dim1;
i__3 = i__;
work[i__2].r = df[i__3].r, work[i__2].i = df[i__3].i;
i__2 = i__ + (i__ + 1) * work_dim1;
i__3 = i__;
work[i__2].r = duf[i__3].r, work[i__2].i = duf[i__3].i;
if (i__ < *n - 1) {
i__2 = i__ + (i__ + 2) * work_dim1;
i__3 = i__;
work[i__2].r = du2[i__3].r, work[i__2].i = du2[i__3].i;
}
}
/* L30: */
}
/* Multiply on the left by L. */
lastj = *n;
for (i__ = *n - 1; i__ >= 1; --i__) {
i__1 = i__;
li.r = dlf[i__1].r, li.i = dlf[i__1].i;
i__1 = lastj - i__ + 1;
zaxpy_(&i__1, &li, &work[i__ + i__ * work_dim1], ldwork, &work[i__ +
1 + i__ * work_dim1], ldwork);
ip = ipiv[i__];
if (ip == i__) {
/* Computing MIN */
i__1 = i__ + 2;
lastj = min(i__1,*n);
} else {
i__1 = lastj - i__ + 1;
zswap_(&i__1, &work[i__ + i__ * work_dim1], ldwork, &work[i__ + 1
+ i__ * work_dim1], ldwork);
}
/* L40: */
}
/* Subtract the matrix A. */
i__1 = work_dim1 + 1;
i__2 = work_dim1 + 1;
z__1.r = work[i__2].r - d__[1].r, z__1.i = work[i__2].i - d__[1].i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
if (*n > 1) {
i__1 = (work_dim1 << 1) + 1;
i__2 = (work_dim1 << 1) + 1;
z__1.r = work[i__2].r - du[1].r, z__1.i = work[i__2].i - du[1].i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n + (*n - 1) * work_dim1;
i__2 = *n + (*n - 1) * work_dim1;
i__3 = *n - 1;
z__1.r = work[i__2].r - dl[i__3].r, z__1.i = work[i__2].i - dl[i__3]
.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n + *n * work_dim1;
i__2 = *n + *n * work_dim1;
i__3 = *n;
z__1.r = work[i__2].r - d__[i__3].r, z__1.i = work[i__2].i - d__[i__3]
.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ + (i__ - 1) * work_dim1;
i__3 = i__ + (i__ - 1) * work_dim1;
i__4 = i__ - 1;
z__1.r = work[i__3].r - dl[i__4].r, z__1.i = work[i__3].i - dl[
i__4].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = i__ + i__ * work_dim1;
i__3 = i__ + i__ * work_dim1;
i__4 = i__;
z__1.r = work[i__3].r - d__[i__4].r, z__1.i = work[i__3].i - d__[
i__4].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = i__ + (i__ + 1) * work_dim1;
i__3 = i__ + (i__ + 1) * work_dim1;
i__4 = i__;
z__1.r = work[i__3].r - du[i__4].r, z__1.i = work[i__3].i - du[
i__4].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L50: */
}
}
/* Compute the 1-norm of the tridiagonal matrix A. */
anorm = zlangt_("1", n, &dl[1], &d__[1], &du[1]);
/* Compute the 1-norm of WORK, which is only guaranteed to be */
/* upper Hessenberg. */
*resid = zlanhs_("1", n, &work[work_offset], ldwork, &rwork[1])
;
/* Compute norm(L*U - A) / (norm(A) * EPS) */
if (anorm <= 0.) {
if (*resid != 0.) {
*resid = 1. / eps;
}
} else {
*resid = *resid / anorm / eps;
}
return 0;
/* End of ZGTT01 */
} /* zgtt01_ */
int zlahrd_(int *n, int *k, int *nb,
doublecomplex *a, int *lda, doublecomplex *tau, doublecomplex *t,
int *ldt, doublecomplex *y, int *ldy)
{
/* System generated locals */
int a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublecomplex z__1;
/* Local variables */
int i__;
doublecomplex ei;
extern int zscal_(int *, doublecomplex *,
doublecomplex *, int *), zgemv_(char *, int *, int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *, doublecomplex *, doublecomplex *, int *),
zcopy_(int *, doublecomplex *, int *, doublecomplex *,
int *), zaxpy_(int *, doublecomplex *, doublecomplex *,
int *, doublecomplex *, int *), ztrmv_(char *, char *,
char *, int *, doublecomplex *, int *, doublecomplex *,
int *), zlarfg_(int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *),
zlacgv_(int *, doublecomplex *, int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by a unitary similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an OBSOLETE auxiliary routine. */
/* This routine will be 'deprecated' in a future release. */
/* Please use the new routine ZLAHR2 instead. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* TAU (output) COMPLEX*16 array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) COMPLEX*16 array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) COMPLEX*16 array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= MAX(1,N). */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a h a a a ) */
/* ( a h a a a ) */
/* ( a h a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(1:n,i) */
/* Compute i-th column of A - Y * V' */
i__2 = i__ - 1;
zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
i__2 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &a[*k
+ i__ - 1 + a_dim1], lda, &c_b2, &a[i__ * a_dim1 + 1], &
c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
zcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
ztrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &a[*k + 1 +
a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
t[*nb * t_dim1 + 1], &c__1);
/* w := T'*w */
i__2 = i__ - 1;
ztrmv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ +
i__ * a_dim1], &c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
ztrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zaxpy_(&i__2, &z__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
a[i__2].r = ei.r, a[i__2].i = ei.i;
}
/* Generate the elementary reflector H(i) to annihilate */
/* A(k+i+1:n,i) */
i__2 = *k + i__ + i__ * a_dim1;
ei.r = a[i__2].r, ei.i = a[i__2].i;
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
zlarfg_(&i__2, &ei, &a[MIN(i__3, *n)+ i__ * a_dim1], &c__1, &tau[i__])
;
i__2 = *k + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute Y(1:n,i) */
i__2 = *n - *k - i__ + 1;
zgemv_("No transpose", n, &i__2, &c_b2, &a[(i__ + 1) * a_dim1 + 1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[i__ *
y_dim1 + 1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &t[i__ *
t_dim1 + 1], &c__1, &c_b2, &y[i__ * y_dim1 + 1], &c__1);
zscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
/* Compute T(1:i,i) */
i__2 = i__ - 1;
i__3 = i__;
z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
zscal_(&i__2, &z__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1)
;
i__2 = i__ + i__ * t_dim1;
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
/* L10: */
}
i__1 = *k + *nb + *nb * a_dim1;
a[i__1].r = ei.r, a[i__1].i = ei.i;
return 0;
/* End of ZLAHRD */
} /* zlahrd_ */
/* Subroutine */ int zhpt21_(integer *itype, char *uplo, integer *n, integer *
kband, doublecomplex *ap, doublereal *d__, doublereal *e,
doublecomplex *u, integer *ldu, doublecomplex *vp, doublecomplex *tau,
doublecomplex *work, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
static doublereal unfl;
static doublecomplex temp;
extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *), zhpr2_(char
*, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *);
static integer j;
extern logical lsame_(char *, char *);
static integer iinfo;
static doublereal anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static char cuplo[1];
static doublecomplex vsave;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static logical lower;
static doublereal wnorm;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zhpmv_(char *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *), zaxpy_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
static integer jp, jr;
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *), zlanhp_(char *, char *, integer
*, doublecomplex *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *);
static integer jp1;
extern /* Subroutine */ int zupmtr_(char *, char *, char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *);
static integer lap;
static doublereal ulp;
#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZHPT21 generally checks a decomposition of the form
A = U S U*
where * means conjugate transpose, A is hermitian, U is
unitary, and S is diagonal (if KBAND=0) or (real) symmetric
tridiagonal (if KBAND=1). If ITYPE=1, then U is represented as
a dense matrix, otherwise the U is expressed as a product of
Householder transformations, whose vectors are stored in the
array "V" and whose scaling constants are in "TAU"; we shall
use the letter "V" to refer to the product of Householder
transformations (which should be equal to U).
Specifically, if ITYPE=1, then:
RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and*
RESULT(2) = | I - UU* | / ( n ulp )
If ITYPE=2, then:
RESULT(1) = | A - V S V* | / ( |A| n ulp )
If ITYPE=3, then:
RESULT(1) = | I - UV* | / ( n ulp )
Packed storage means that, for example, if UPLO='U', then the columns
of the upper triangle of A are stored one after another, so that
A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if
UPLO='L', then the columns of the lower triangle of A are stored one
after another in AP, so that A(j+1,j+1) immediately follows A(n,j)
in the array AP. This means that A(i,j) is stored in:
AP( i + j*(j-1)/2 ) if UPLO='U'
AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L'
The array VP bears the same relation to the matrix V that A does to
AP.
For ITYPE > 1, the transformation U is expressed as a product
of Householder transformations:
If UPLO='U', then V = H(n-1)...H(1), where
H(j) = I - tau(j) v(j) v(j)*
and the first j-1 elements of v(j) are stored in V(1:j-1,j+1),
(i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ),
the j-th element is 1, and the last n-j elements are 0.
If UPLO='L', then V = H(1)...H(n-1), where
H(j) = I - tau(j) v(j) v(j)*
and the first j elements of v(j) are 0, the (j+1)-st is 1, and the
(j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e.,
in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .)
Arguments
=========
ITYPE (input) INTEGER
Specifies the type of tests to be performed.
1: U expressed as a dense unitary matrix:
RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and*
RESULT(2) = | I - UU* | / ( n ulp )
2: U expressed as a product V of Housholder transformations:
RESULT(1) = | A - V S V* | / ( |A| n ulp )
3: U expressed both as a dense unitary matrix and
as a product of Housholder transformations:
RESULT(1) = | I - UV* | / ( n ulp )
UPLO (input) CHARACTER
If UPLO='U', the upper triangle of A and V will be used and
the (strictly) lower triangle will not be referenced.
If UPLO='L', the lower triangle of A and V will be used and
the (strictly) upper triangle will not be referenced.
N (input) INTEGER
The size of the matrix. If it is zero, ZHPT21 does nothing.
It must be at least zero.
KBAND (input) INTEGER
The bandwidth of the matrix. It may only be zero or one.
If zero, then S is diagonal, and E is not referenced. If
one, then S is symmetric tri-diagonal.
AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The original (unfactored) matrix. It is assumed to be
hermitian, and contains the columns of just the upper
triangle (UPLO='U') or only the lower triangle (UPLO='L'),
packed one after another.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal of the (symmetric tri-) diagonal matrix.
E (input) DOUBLE PRECISION array, dimension (N)
The off-diagonal of the (symmetric tri-) diagonal matrix.
E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
(3,2) element, etc.
Not referenced if KBAND=0.
U (input) COMPLEX*16 array, dimension (LDU, N)
If ITYPE=1 or 3, this contains the unitary matrix in
the decomposition, expressed as a dense matrix. If ITYPE=2,
then it is not referenced.
LDU (input) INTEGER
The leading dimension of U. LDU must be at least N and
at least 1.
VP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
If ITYPE=2 or 3, the columns of this array contain the
Householder vectors used to describe the unitary matrix
in the decomposition, as described in purpose.
*NOTE* If ITYPE=2 or 3, V is modified and restored. The
subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
is set to one, and later reset to its original value, during
the course of the calculation.
If ITYPE=1, then it is neither referenced nor modified.
TAU (input) COMPLEX*16 array, dimension (N)
If ITYPE >= 2, then TAU(j) is the scalar factor of
v(j) v(j)* in the Householder transformation H(j) of
the product U = H(1)...H(n-2)
If ITYPE < 2, then TAU is not referenced.
WORK (workspace) COMPLEX*16 array, dimension (N**2)
Workspace.
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
Workspace.
RESULT (output) DOUBLE PRECISION array, dimension (2)
The values computed by the two tests described above. The
values are currently limited to 1/ulp, to avoid overflow.
RESULT(1) is always modified. RESULT(2) is modified only
if ITYPE=1.
=====================================================================
Constants
Parameter adjustments */
--ap;
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--vp;
--tau;
--work;
--rwork;
--result;
/* Function Body */
result[1] = 0.;
if (*itype == 1) {
result[2] = 0.;
}
if (*n <= 0) {
return 0;
}
lap = *n * (*n + 1) / 2;
if (lsame_(uplo, "U")) {
lower = FALSE_;
*(unsigned char *)cuplo = 'U';
} else {
lower = TRUE_;
*(unsigned char *)cuplo = 'L';
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
/* Some Error Checks */
if (*itype < 1 || *itype > 3) {
result[1] = 10. / ulp;
return 0;
}
/* Do Test 1
Norm of A: */
if (*itype == 3) {
anorm = 1.;
} else {
/* Computing MAX */
d__1 = zlanhp_("1", cuplo, n, &ap[1], &rwork[1])
;
anorm = max(d__1,unfl);
}
/* Compute error matrix: */
if (*itype == 1) {
/* ITYPE=1: error = A - U S U* */
zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
zcopy_(&lap, &ap[1], &c__1, &work[1], &c__1);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = -d__[j];
zhpr_(cuplo, n, &d__1, &u_ref(1, j), &c__1, &work[1]);
/* L10: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__2.r = e[i__2], z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
zhpr2_(cuplo, n, &z__1, &u_ref(1, j), &c__1, &u_ref(1, j - 1),
&c__1, &work[1]);
/* L20: */
}
}
wnorm = zlanhp_("1", cuplo, n, &work[1], &rwork[1]);
} else if (*itype == 2) {
/* ITYPE=2: error = V S V* - A */
zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
if (lower) {
i__1 = lap;
i__2 = *n;
work[i__1].r = d__[i__2], work[i__1].i = 0.;
for (j = *n - 1; j >= 1; --j) {
jp = ((*n << 1) - j) * (j - 1) / 2;
jp1 = jp + *n - j;
if (*kband == 1) {
i__1 = jp + j + 1;
i__2 = j;
z__2.r = 1. - tau[i__2].r, z__2.i = 0. - tau[i__2].i;
i__3 = j;
z__1.r = e[i__3] * z__2.r, z__1.i = e[i__3] * z__2.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n;
for (jr = j + 2; jr <= i__1; ++jr) {
i__2 = jp + jr;
i__3 = j;
z__3.r = -tau[i__3].r, z__3.i = -tau[i__3].i;
i__4 = j;
z__2.r = e[i__4] * z__3.r, z__2.i = e[i__4] * z__3.i;
i__5 = jp + jr;
z__1.r = z__2.r * vp[i__5].r - z__2.i * vp[i__5].i,
z__1.i = z__2.r * vp[i__5].i + z__2.i * vp[
i__5].r;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L30: */
}
}
i__1 = j;
if (tau[i__1].r != 0. || tau[i__1].i != 0.) {
i__1 = jp + j + 1;
vsave.r = vp[i__1].r, vsave.i = vp[i__1].i;
i__1 = jp + j + 1;
vp[i__1].r = 1., vp[i__1].i = 0.;
i__1 = *n - j;
zhpmv_("L", &i__1, &c_b2, &work[jp1 + j + 1], &vp[jp + j
+ 1], &c__1, &c_b1, &work[lap + 1], &c__1);
i__1 = j;
z__2.r = tau[i__1].r * -.5, z__2.i = tau[i__1].i * -.5;
i__2 = *n - j;
zdotc_(&z__3, &i__2, &work[lap + 1], &c__1, &vp[jp + j +
1], &c__1);
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
temp.r = z__1.r, temp.i = z__1.i;
i__1 = *n - j;
zaxpy_(&i__1, &temp, &vp[jp + j + 1], &c__1, &work[lap +
1], &c__1);
i__1 = *n - j;
i__2 = j;
z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
zhpr2_("L", &i__1, &z__1, &vp[jp + j + 1], &c__1, &work[
lap + 1], &c__1, &work[jp1 + j + 1]);
i__1 = jp + j + 1;
vp[i__1].r = vsave.r, vp[i__1].i = vsave.i;
}
i__1 = jp + j;
i__2 = j;
work[i__1].r = d__[i__2], work[i__1].i = 0.;
/* L40: */
}
} else {
work[1].r = d__[1], work[1].i = 0.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
jp = j * (j - 1) / 2;
jp1 = jp + j;
if (*kband == 1) {
i__2 = jp1 + j;
i__3 = j;
z__2.r = 1. - tau[i__3].r, z__2.i = 0. - tau[i__3].i;
i__4 = j;
z__1.r = e[i__4] * z__2.r, z__1.i = e[i__4] * z__2.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = j - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = jp1 + jr;
i__4 = j;
z__3.r = -tau[i__4].r, z__3.i = -tau[i__4].i;
i__5 = j;
z__2.r = e[i__5] * z__3.r, z__2.i = e[i__5] * z__3.i;
i__6 = jp1 + jr;
z__1.r = z__2.r * vp[i__6].r - z__2.i * vp[i__6].i,
z__1.i = z__2.r * vp[i__6].i + z__2.i * vp[
i__6].r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L50: */
}
}
i__2 = j;
if (tau[i__2].r != 0. || tau[i__2].i != 0.) {
i__2 = jp1 + j;
vsave.r = vp[i__2].r, vsave.i = vp[i__2].i;
i__2 = jp1 + j;
vp[i__2].r = 1., vp[i__2].i = 0.;
zhpmv_("U", &j, &c_b2, &work[1], &vp[jp1 + 1], &c__1, &
c_b1, &work[lap + 1], &c__1);
i__2 = j;
z__2.r = tau[i__2].r * -.5, z__2.i = tau[i__2].i * -.5;
zdotc_(&z__3, &j, &work[lap + 1], &c__1, &vp[jp1 + 1], &
c__1);
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
z__2.r * z__3.i + z__2.i * z__3.r;
temp.r = z__1.r, temp.i = z__1.i;
zaxpy_(&j, &temp, &vp[jp1 + 1], &c__1, &work[lap + 1], &
c__1);
i__2 = j;
z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
zhpr2_("U", &j, &z__1, &vp[jp1 + 1], &c__1, &work[lap + 1]
, &c__1, &work[1]);
i__2 = jp1 + j;
vp[i__2].r = vsave.r, vp[i__2].i = vsave.i;
}
i__2 = jp1 + j + 1;
i__3 = j + 1;
work[i__2].r = d__[i__3], work[i__2].i = 0.;
/* L60: */
}
}
i__1 = lap;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
i__3 = j;
i__4 = j;
z__1.r = work[i__3].r - ap[i__4].r, z__1.i = work[i__3].i - ap[
i__4].i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L70: */
}
wnorm = zlanhp_("1", cuplo, n, &work[1], &rwork[1]);
} else if (*itype == 3) {
/* ITYPE=3: error = U V* - I */
if (*n < 2) {
return 0;
}
zlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
/* Computing 2nd power */
i__1 = *n;
zupmtr_("R", cuplo, "C", n, n, &vp[1], &tau[1], &work[1], n, &work[
i__1 * i__1 + 1], &iinfo);
if (iinfo != 0) {
result[1] = 10. / ulp;
return 0;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 1) + 1;
z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i + 0.;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L80: */
}
wnorm = zlange_("1", n, n, &work[1], n, &rwork[1]);
}
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.) {
/* Computing MIN */
d__1 = wnorm, d__2 = *n * anorm;
result[1] = min(d__1,d__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
result[1] = min(d__1,d__2) / (*n * ulp);
}
}
/* Do Test 2
Compute UU* - I */
if (*itype == 1) {
zgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
&c_b1, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 1) + 1;
z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i + 0.;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L90: */
}
/* Computing MIN */
d__1 = zlange_("1", n, n, &work[1], n, &rwork[1]), d__2 = (
doublereal) (*n);
result[2] = min(d__1,d__2) / (*n * ulp);
}
return 0;
/* End of ZHPT21 */
} /* zhpt21_ */
/*< subroutine zqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) >*/
/* Subroutine */ int zqrsl_(doublecomplex *x, integer *ldx, integer *n,
integer *k, doublecomplex *qraux, doublecomplex *y, doublecomplex *qy,
doublecomplex *qty, doublecomplex *b, doublecomplex *rsd,
doublecomplex *xb, integer *job, integer *info)
{
/* System generated locals */
integer x_dim1, x_offset, i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
doublecomplex t;
logical cb;
integer jj;
logical cr;
integer ju, kp1;
logical cxb, cqy;
doublecomplex temp;
logical cqty;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
/*< integer ldx,n,k,job,info >*/
/*< complex*16 x(ldx,1),qraux(1),y(1),qy(1),qty(1),b(1),rsd(1),xb(1) >*/
/* zqrsl applies the output of zqrdc to compute coordinate */
/* transformations, projections, and least squares solutions. */
/* for k .le. min(n,p), let xk be the matrix */
/* xk = (x(jpvt(1)),x(jpvt(2)), ... ,x(jpvt(k))) */
/* formed from columns jpvt(1), ... ,jpvt(k) of the original */
/* n x p matrix x that was input to zqrdc (if no pivoting was */
/* done, xk consists of the first k columns of x in their */
/* original order). zqrdc produces a factored unitary matrix q */
/* and an upper triangular matrix r such that */
/* xk = q * (r) */
/* (0) */
/* this information is contained in coded form in the arrays */
/* x and qraux. */
/* on entry */
/* x complex*16(ldx,p). */
/* x contains the output of zqrdc. */
/* ldx integer. */
/* ldx is the leading dimension of the array x. */
/* n integer. */
/* n is the number of rows of the matrix xk. it must */
/* have the same value as n in zqrdc. */
/* k integer. */
/* k is the number of columns of the matrix xk. k */
/* must nnot be greater than min(n,p), where p is the */
/* same as in the calling sequence to zqrdc. */
/* qraux complex*16(p). */
/* qraux contains the auxiliary output from zqrdc. */
/* y complex*16(n) */
/* y contains an n-vector that is to be manipulated */
/* by zqrsl. */
/* job integer. */
/* job specifies what is to be computed. job has */
/* the decimal expansion abcde, with the following */
/* meaning. */
/* if a.ne.0, compute qy. */
/* if b,c,d, or e .ne. 0, compute qty. */
/* if c.ne.0, compute b. */
/* if d.ne.0, compute rsd. */
/* if e.ne.0, compute xb. */
/* note that a request to compute b, rsd, or xb */
/* automatically triggers the computation of qty, for */
/* which an array must be provided in the calling */
/* sequence. */
/* on return */
/* qy complex*16(n). */
/* qy conntains q*y, if its computation has been */
/* requested. */
/* qty complex*16(n). */
/* qty contains ctrans(q)*y, if its computation has */
/* been requested. here ctrans(q) is the conjugate */
/* transpose of the matrix q. */
/* b complex*16(k) */
/* b contains the solution of the least squares problem */
/* minimize norm2(y - xk*b), */
/* if its computation has been requested. (note that */
/* if pivoting was requested in zqrdc, the j-th */
/* component of b will be associated with column jpvt(j) */
/* of the original matrix x that was input into zqrdc.) */
/* rsd complex*16(n). */
/* rsd contains the least squares residual y - xk*b, */
/* if its computation has been requested. rsd is */
/* also the orthogonal projection of y onto the */
/* orthogonal complement of the column space of xk. */
/* xb complex*16(n). */
/* xb contains the least squares approximation xk*b, */
/* if its computation has been requested. xb is also */
/* the orthogonal projection of y onto the column space */
/* of x. */
/* info integer. */
/* info is zero unless the computation of b has */
/* been requested and r is exactly singular. in */
/* this case, info is the index of the first zero */
/* diagonal element of r and b is left unaltered. */
/* the parameters qy, qty, b, rsd, and xb are not referenced */
/* if their computation is not requested and in this case */
/* can be replaced by dummy variables in the calling program. */
/* to save storage, the user may in some cases use the same */
/* array for different parameters in the calling sequence. a */
/* frequently occurring example is when one wishes to compute */
/* any of b, rsd, or xb and does not need y or qty. in this */
/* case one may identify y, qty, and one of b, rsd, or xb, while */
/* providing separate arrays for anything else that is to be */
/* computed. thus the calling sequence */
/* call zqrsl(x,ldx,n,k,qraux,y,dum,y,b,y,dum,110,info) */
/* will result in the computation of b and rsd, with rsd */
/* overwriting y. more generally, each item in the following */
/* list contains groups of permissible identifications for */
/* a single callinng sequence. */
/* 1. (y,qty,b) (rsd) (xb) (qy) */
/* 2. (y,qty,rsd) (b) (xb) (qy) */
/* 3. (y,qty,xb) (b) (rsd) (qy) */
/* 4. (y,qy) (qty,b) (rsd) (xb) */
/* 5. (y,qy) (qty,rsd) (b) (xb) */
/* 6. (y,qy) (qty,xb) (b) (rsd) */
/* in any group the value returned in the array allocated to */
/* the group corresponds to the last member of the group. */
/* linpack. this version dated 08/14/78 . */
/* g.w. stewart, university of maryland, argonne national lab. */
/* zqrsl uses the following functions and subprograms. */
/* blas zaxpy,zcopy,zdotc */
/* fortran dabs,min0,mod */
/* internal variables */
/*< integer i,j,jj,ju,kp1 >*/
/*< complex*16 zdotc,t,temp >*/
/*< logical cb,cqy,cqty,cr,cxb >*/
/*< complex*16 zdum >*/
/*< double precision cabs1 >*/
/*< double precision dreal,dimag >*/
/*< complex*16 zdumr,zdumi >*/
/*< dreal(zdumr) = zdumr >*/
/*< dimag(zdumi) = (0.0d0,-1.0d0)*zdumi >*/
/*< cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) >*/
/* set info flag. */
/*< info = 0 >*/
/* Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--qraux;
--y;
--qy;
--qty;
--b;
--rsd;
--xb;
/* Function Body */
*info = 0;
/* determine what is to be computed. */
/*< cqy = job/10000 .ne. 0 >*/
cqy = *job / 10000 != 0;
/*< cqty = mod(job,10000) .ne. 0 >*/
cqty = *job % 10000 != 0;
/*< cb = mod(job,1000)/100 .ne. 0 >*/
cb = *job % 1000 / 100 != 0;
/*< cr = mod(job,100)/10 .ne. 0 >*/
cr = *job % 100 / 10 != 0;
/*< cxb = mod(job,10) .ne. 0 >*/
cxb = *job % 10 != 0;
/*< ju = min0(k,n-1) >*/
/* Computing MIN */
i__1 = *k, i__2 = *n - 1;
ju = min(i__1,i__2);
/* special action when n=1. */
/*< if (ju .ne. 0) go to 40 >*/
if (ju != 0) {
goto L40;
}
/*< if (cqy) qy(1) = y(1) >*/
if (cqy) {
qy[1].r = y[1].r, qy[1].i = y[1].i;
}
/*< if (cqty) qty(1) = y(1) >*/
if (cqty) {
qty[1].r = y[1].r, qty[1].i = y[1].i;
}
/*< if (cxb) xb(1) = y(1) >*/
if (cxb) {
xb[1].r = y[1].r, xb[1].i = y[1].i;
}
/*< if (.not.cb) go to 30 >*/
if (! cb) {
goto L30;
}
/*< if (cabs1(x(1,1)) .ne. 0.0d0) go to 10 >*/
i__1 = x_dim1 + 1;
i__2 = x_dim1 + 1;
z__1.r = x[i__2].r * 0. - x[i__2].i * -1., z__1.i = x[i__2].i * 0. + x[
i__2].r * -1.;
if ((d__1 = x[i__1].r, abs(d__1)) + (d__2 = z__1.r, abs(d__2)) != 0.) {
goto L10;
}
/*< info = 1 >*/
*info = 1;
/*< go to 20 >*/
goto L20;
/*< 10 continue >*/
L10:
/*< b(1) = y(1)/x(1,1) >*/
z_div(&z__1, &y[1], &x[x_dim1 + 1]);
b[1].r = z__1.r, b[1].i = z__1.i;
/*< 20 continue >*/
L20:
/*< 30 continue >*/
L30:
/*< if (cr) rsd(1) = (0.0d0,0.0d0) >*/
if (cr) {
rsd[1].r = 0., rsd[1].i = 0.;
}
/*< go to 250 >*/
goto L250;
/*< 40 continue >*/
L40:
/* set up to compute qy or qty. */
/*< if (cqy) call zcopy(n,y,1,qy,1) >*/
if (cqy) {
zcopy_(n, &y[1], &c__1, &qy[1], &c__1);
}
/*< if (cqty) call zcopy(n,y,1,qty,1) >*/
if (cqty) {
zcopy_(n, &y[1], &c__1, &qty[1], &c__1);
}
/*< if (.not.cqy) go to 70 >*/
if (! cqy) {
goto L70;
}
/* compute qy. */
/*< do 60 jj = 1, ju >*/
i__1 = ju;
for (jj = 1; jj <= i__1; ++jj) {
/*< j = ju - jj + 1 >*/
j = ju - jj + 1;
/*< if (cabs1(qraux(j)) .eq. 0.0d0) go to 50 >*/
i__2 = j;
i__3 = j;
z__1.r = qraux[i__3].r * 0. - qraux[i__3].i * -1., z__1.i = qraux[
i__3].i * 0. + qraux[i__3].r * -1.;
if ((d__1 = qraux[i__2].r, abs(d__1)) + (d__2 = z__1.r, abs(d__2)) ==
0.) {
goto L50;
}
/*< temp = x(j,j) >*/
i__2 = j + j * x_dim1;
temp.r = x[i__2].r, temp.i = x[i__2].i;
/*< x(j,j) = qraux(j) >*/
i__2 = j + j * x_dim1;
i__3 = j;
x[i__2].r = qraux[i__3].r, x[i__2].i = qraux[i__3].i;
/*< t = -zdotc(n-j+1,x(j,j),1,qy(j),1)/x(j,j) >*/
i__2 = *n - j + 1;
zdotc_(&z__3, &i__2, &x[j + j * x_dim1], &c__1, &qy[j], &c__1);
z__2.r = -z__3.r, z__2.i = -z__3.i;
z_div(&z__1, &z__2, &x[j + j * x_dim1]);
t.r = z__1.r, t.i = z__1.i;
/*< call zaxpy(n-j+1,t,x(j,j),1,qy(j),1) >*/
i__2 = *n - j + 1;
zaxpy_(&i__2, &t, &x[j + j * x_dim1], &c__1, &qy[j], &c__1);
/*< x(j,j) = temp >*/
i__2 = j + j * x_dim1;
x[i__2].r = temp.r, x[i__2].i = temp.i;
/*< 50 continue >*/
L50:
/*< 60 continue >*/
/* L60: */
;
}
/*< 70 continue >*/
L70:
/*< if (.not.cqty) go to 100 >*/
if (! cqty) {
goto L100;
}
/* compute ctrans(q)*y. */
/*< do 90 j = 1, ju >*/
i__1 = ju;
for (j = 1; j <= i__1; ++j) {
/*< if (cabs1(qraux(j)) .eq. 0.0d0) go to 80 >*/
i__2 = j;
i__3 = j;
z__1.r = qraux[i__3].r * 0. - qraux[i__3].i * -1., z__1.i = qraux[
i__3].i * 0. + qraux[i__3].r * -1.;
if ((d__1 = qraux[i__2].r, abs(d__1)) + (d__2 = z__1.r, abs(d__2)) ==
0.) {
goto L80;
}
/*< temp = x(j,j) >*/
i__2 = j + j * x_dim1;
temp.r = x[i__2].r, temp.i = x[i__2].i;
/*< x(j,j) = qraux(j) >*/
i__2 = j + j * x_dim1;
i__3 = j;
x[i__2].r = qraux[i__3].r, x[i__2].i = qraux[i__3].i;
/*< t = -zdotc(n-j+1,x(j,j),1,qty(j),1)/x(j,j) >*/
i__2 = *n - j + 1;
zdotc_(&z__3, &i__2, &x[j + j * x_dim1], &c__1, &qty[j], &c__1);
z__2.r = -z__3.r, z__2.i = -z__3.i;
z_div(&z__1, &z__2, &x[j + j * x_dim1]);
t.r = z__1.r, t.i = z__1.i;
/*< call zaxpy(n-j+1,t,x(j,j),1,qty(j),1) >*/
i__2 = *n - j + 1;
zaxpy_(&i__2, &t, &x[j + j * x_dim1], &c__1, &qty[j], &c__1);
/*< x(j,j) = temp >*/
i__2 = j + j * x_dim1;
x[i__2].r = temp.r, x[i__2].i = temp.i;
/*< 80 continue >*/
L80:
/*< 90 continue >*/
/* L90: */
;
}
/*< 100 continue >*/
L100:
/* set up to compute b, rsd, or xb. */
/*< if (cb) call zcopy(k,qty,1,b,1) >*/
if (cb) {
zcopy_(k, &qty[1], &c__1, &b[1], &c__1);
}
/*< kp1 = k + 1 >*/
kp1 = *k + 1;
/*< if (cxb) call zcopy(k,qty,1,xb,1) >*/
if (cxb) {
zcopy_(k, &qty[1], &c__1, &xb[1], &c__1);
}
/*< if (cr .and. k .lt. n) call zcopy(n-k,qty(kp1),1,rsd(kp1),1) >*/
if (cr && *k < *n) {
i__1 = *n - *k;
zcopy_(&i__1, &qty[kp1], &c__1, &rsd[kp1], &c__1);
}
/*< if (.not.cxb .or. kp1 .gt. n) go to 120 >*/
if (! cxb || kp1 > *n) {
goto L120;
}
/*< do 110 i = kp1, n >*/
i__1 = *n;
for (i__ = kp1; i__ <= i__1; ++i__) {
/*< xb(i) = (0.0d0,0.0d0) >*/
i__2 = i__;
xb[i__2].r = 0., xb[i__2].i = 0.;
/*< 110 continue >*/
/* L110: */
}
/*< 120 continue >*/
L120:
/*< if (.not.cr) go to 140 >*/
if (! cr) {
goto L140;
}
/*< do 130 i = 1, k >*/
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< rsd(i) = (0.0d0,0.0d0) >*/
i__2 = i__;
rsd[i__2].r = 0., rsd[i__2].i = 0.;
/*< 130 continue >*/
/* L130: */
}
/*< 140 continue >*/
L140:
/*< if (.not.cb) go to 190 >*/
if (! cb) {
goto L190;
}
/* compute b. */
/*< do 170 jj = 1, k >*/
i__1 = *k;
for (jj = 1; jj <= i__1; ++jj) {
/*< j = k - jj + 1 >*/
j = *k - jj + 1;
/*< if (cabs1(x(j,j)) .ne. 0.0d0) go to 150 >*/
i__2 = j + j * x_dim1;
i__3 = j + j * x_dim1;
z__1.r = x[i__3].r * 0. - x[i__3].i * -1., z__1.i = x[i__3].i * 0. +
x[i__3].r * -1.;
if ((d__1 = x[i__2].r, abs(d__1)) + (d__2 = z__1.r, abs(d__2)) != 0.)
{
goto L150;
}
/*< info = j >*/
*info = j;
/* ......exit */
/*< go to 180 >*/
goto L180;
/*< 150 continue >*/
L150:
/*< b(j) = b(j)/x(j,j) >*/
i__2 = j;
z_div(&z__1, &b[j], &x[j + j * x_dim1]);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/*< if (j .eq. 1) go to 160 >*/
if (j == 1) {
goto L160;
}
/*< t = -b(j) >*/
i__2 = j;
z__1.r = -b[i__2].r, z__1.i = -b[i__2].i;
t.r = z__1.r, t.i = z__1.i;
/*< call zaxpy(j-1,t,x(1,j),1,b,1) >*/
i__2 = j - 1;
zaxpy_(&i__2, &t, &x[j * x_dim1 + 1], &c__1, &b[1], &c__1);
/*< 160 continue >*/
L160:
/*< 170 continue >*/
/* L170: */
;
}
/*< 180 continue >*/
L180:
/*< 190 continue >*/
L190:
/*< if (.not.cr .and. .not.cxb) go to 240 >*/
if (! cr && ! cxb) {
goto L240;
}
/* compute rsd or xb as required. */
/*< do 230 jj = 1, ju >*/
i__1 = ju;
for (jj = 1; jj <= i__1; ++jj) {
/*< j = ju - jj + 1 >*/
j = ju - jj + 1;
/*< if (cabs1(qraux(j)) .eq. 0.0d0) go to 220 >*/
i__2 = j;
i__3 = j;
z__1.r = qraux[i__3].r * 0. - qraux[i__3].i * -1., z__1.i = qraux[
i__3].i * 0. + qraux[i__3].r * -1.;
if ((d__1 = qraux[i__2].r, abs(d__1)) + (d__2 = z__1.r, abs(d__2)) ==
0.) {
goto L220;
}
/*< temp = x(j,j) >*/
i__2 = j + j * x_dim1;
temp.r = x[i__2].r, temp.i = x[i__2].i;
/*< x(j,j) = qraux(j) >*/
i__2 = j + j * x_dim1;
i__3 = j;
x[i__2].r = qraux[i__3].r, x[i__2].i = qraux[i__3].i;
/*< if (.not.cr) go to 200 >*/
if (! cr) {
goto L200;
}
/*< t = -zdotc(n-j+1,x(j,j),1,rsd(j),1)/x(j,j) >*/
i__2 = *n - j + 1;
zdotc_(&z__3, &i__2, &x[j + j * x_dim1], &c__1, &rsd[j], &c__1);
z__2.r = -z__3.r, z__2.i = -z__3.i;
z_div(&z__1, &z__2, &x[j + j * x_dim1]);
t.r = z__1.r, t.i = z__1.i;
/*< call zaxpy(n-j+1,t,x(j,j),1,rsd(j),1) >*/
i__2 = *n - j + 1;
zaxpy_(&i__2, &t, &x[j + j * x_dim1], &c__1, &rsd[j], &c__1);
/*< 200 continue >*/
L200:
/*< if (.not.cxb) go to 210 >*/
if (! cxb) {
goto L210;
}
/*< t = -zdotc(n-j+1,x(j,j),1,xb(j),1)/x(j,j) >*/
i__2 = *n - j + 1;
zdotc_(&z__3, &i__2, &x[j + j * x_dim1], &c__1, &xb[j], &c__1);
z__2.r = -z__3.r, z__2.i = -z__3.i;
z_div(&z__1, &z__2, &x[j + j * x_dim1]);
t.r = z__1.r, t.i = z__1.i;
/*< call zaxpy(n-j+1,t,x(j,j),1,xb(j),1) >*/
i__2 = *n - j + 1;
zaxpy_(&i__2, &t, &x[j + j * x_dim1], &c__1, &xb[j], &c__1);
/*< 210 continue >*/
L210:
/*< x(j,j) = temp >*/
i__2 = j + j * x_dim1;
x[i__2].r = temp.r, x[i__2].i = temp.i;
/*< 220 continue >*/
L220:
/*< 230 continue >*/
/* L230: */
;
}
/*< 240 continue >*/
L240:
/*< 250 continue >*/
L250:
/*< return >*/
return 0;
/*< end >*/
} /* zqrsl_ */
/* Subroutine */ int zlaghe_(integer *n, integer *k, doublereal *d__,
doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double z_abs(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j;
doublecomplex wa, wb;
doublereal wn;
doublecomplex tau;
extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublecomplex alpha;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zhemv_(char *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zlarnv_(
integer *, integer *, integer *, doublecomplex *);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAGHE generates a complex hermitian matrix A, by pre- and post- */
/* multiplying a real diagonal matrix D with a random unitary matrix: */
/* A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */
/* unitary transformations. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* K (input) INTEGER */
/* The number of nonzero subdiagonals within the band of A. */
/* 0 <= K <= N-1. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of the diagonal matrix D. */
/* A (output) COMPLEX*16 array, dimension (LDA,N) */
/* The generated n by n hermitian matrix A (the full matrix is */
/* stored). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= N. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
--d__;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("ZLAGHE", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.;
/* L30: */
}
/* Generate lower triangle of hermitian matrix */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* generate random reflection */
i__1 = *n - i__ + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *n - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply random reflection to A(i:n,i:n) from the left */
/* and the right */
/* compute y := tau * A * u */
i__1 = *n - i__ + 1;
zhemv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
c__1, &c_b1, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = -0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__1 = *n - i__ + 1;
zdotc_(&z__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__1 = *n - i__ + 1;
zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
i__1 = *n - i__ + 1;
z__1.r = -1., z__1.i = -0.;
zher2_("Lower", &i__1, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, &
a[i__ + i__ * a_dim1], lda);
/* L40: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i__ + 1;
wn = dznrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*k + i__ + i__ * a_dim1]);
i__2 = *k + i__ + i__ * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *k + i__ + i__ * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *k - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
i__2 = *k + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i__ + 1;
i__3 = *k - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__
+ 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
c_b1, &work[1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = *k - 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the right */
/* compute y := tau * A * u */
i__2 = *n - *k - i__ + 1;
zhemv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda,
&a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = -0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__2 = *n - *k - i__ + 1;
zdotc_(&z__4, &i__2, &work[1], &c__1, &a[*k + i__ + i__ * a_dim1], &
c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - *k - i__ + 1;
zaxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
c__1);
/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i__ + 1;
z__1.r = -1., z__1.i = -0.;
zher2_("Lower", &i__2, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &
work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda);
i__2 = *k + i__ + i__ * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = *n;
for (j = *k + i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
/* L60: */
}
/* Store full hermitian matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * a_dim1;
d_cnjg(&z__1, &a[i__ + j * a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of ZLAGHE */
} /* zlaghe_ */
/* Subroutine */ int ztzrqf_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, k, m1;
doublecomplex alpha;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *), zlarfp_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine ZTZRZF. */
/* ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */
/* to upper triangular form by means of unitary transformations. */
/* The upper trapezoidal matrix A is factored as */
/* A = ( R 0 ) * Z, */
/* where Z is an N-by-N unitary matrix and R is an M-by-M upper */
/* triangular matrix. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= M. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the leading M-by-N upper trapezoidal part of the */
/* array A must contain the matrix to be factorized. */
/* On exit, the leading M-by-M upper triangular part of A */
/* contains the upper triangular matrix R, and elements M+1 to */
/* N of the first M rows of A, with the array TAU, represent the */
/* unitary matrix Z as a product of M elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX*16 array, dimension (M) */
/* The scalar factors of the elementary reflectors. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The factorization is obtained by Householder's method. The kth */
/* transformation matrix, Z( k ), whose conjugate transpose is used to */
/* introduce zeros into the (m - k + 1)th row of A, is given in the form */
/* Z( k ) = ( I 0 ), */
/* ( 0 T( k ) ) */
/* where */
/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
/* ( 0 ) */
/* ( z( k ) ) */
/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
/* tau and z( k ) are chosen to annihilate the elements of the kth row */
/* of X. */
/* The scalar tau is returned in the kth element of TAU and the vector */
/* u( k ) in the kth row of A, such that the elements of z( k ) are */
/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
/* the upper triangular part of A. */
/* Z is given by */
/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTZRQF", &i__1);
return 0;
}
/* Perform the factorization. */
if (*m == 0) {
return 0;
}
if (*m == *n) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/* L10: */
}
} else {
/* Computing MIN */
i__1 = *m + 1;
m1 = min(i__1,*n);
for (k = *m; k >= 1; --k) {
/* Use a Householder reflection to zero the kth row of A. */
/* First set up the reflection. */
i__1 = k + k * a_dim1;
d_cnjg(&z__1, &a[k + k * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = *n - *m;
zlacgv_(&i__1, &a[k + m1 * a_dim1], lda);
i__1 = k + k * a_dim1;
alpha.r = a[i__1].r, alpha.i = a[i__1].i;
i__1 = *n - *m + 1;
zlarfp_(&i__1, &alpha, &a[k + m1 * a_dim1], lda, &tau[k]);
i__1 = k + k * a_dim1;
a[i__1].r = alpha.r, a[i__1].i = alpha.i;
i__1 = k;
d_cnjg(&z__1, &tau[k]);
tau[i__1].r = z__1.r, tau[i__1].i = z__1.i;
i__1 = k;
if ((tau[i__1].r != 0. || tau[i__1].i != 0.) && k > 1) {
/* We now perform the operation A := A*P( k )'. */
/* Use the first ( k - 1 ) elements of TAU to store a( k ), */
/* where a( k ) consists of the first ( k - 1 ) elements of */
/* the kth column of A. Also let B denote the first */
/* ( k - 1 ) rows of the last ( n - m ) columns of A. */
i__1 = k - 1;
zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
/* Form w = a( k ) + B*z( k ) in TAU. */
i__1 = k - 1;
i__2 = *n - *m;
zgemv_("No transpose", &i__1, &i__2, &c_b1, &a[m1 * a_dim1 +
1], lda, &a[k + m1 * a_dim1], lda, &c_b1, &tau[1], &
c__1);
/* Now form a( k ) := a( k ) - conjg(tau)*w */
/* and B := B - conjg(tau)*w*z( k )'. */
i__1 = k - 1;
d_cnjg(&z__2, &tau[k]);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zaxpy_(&i__1, &z__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
c__1);
i__1 = k - 1;
i__2 = *n - *m;
d_cnjg(&z__2, &tau[k]);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(&i__1, &i__2, &z__1, &tau[1], &c__1, &a[k + m1 *
a_dim1], lda, &a[m1 * a_dim1 + 1], lda);
}
/* L20: */
}
}
return 0;
/* End of ZTZRQF */
} /* ztzrqf_ */
/* Subroutine */ int ztgsy2_(char *trans, integer *ijob, integer *m, integer *
n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublecomplex *c__, integer *ldc, doublecomplex *d__, integer *ldd,
doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf,
doublereal *scale, doublereal *rdsum, doublereal *rdscal, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
i__4;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Local variables */
integer i__, j, k;
doublecomplex z__[4] /* was [2][2] */, rhs[2];
integer ierr, ipiv[2], jpiv[2];
doublecomplex alpha;
doublereal scaloc;
logical notran;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZTGSY2 solves the generalized Sylvester equation */
/* A * R - L * B = scale * C (1) */
/* D * R - L * E = scale * F */
/* using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices, */
/* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */
/* N-by-N and M-by-N, respectively. A, B, D and E are upper triangular */
/* (i.e., (A,D) and (B,E) in generalized Schur form). */
/* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */
/* scaling factor chosen to avoid overflow. */
/* In matrix notation solving equation (1) corresponds to solve */
/* Zx = scale * b, where Z is defined as */
/* Z = [ kron(In, A) -kron(B', Im) ] (2) */
/* [ kron(In, D) -kron(E', Im) ], */
/* Ik is the identity matrix of size k and X' is the transpose of X. */
/* kron(X, Y) is the Kronecker product between the matrices X and Y. */
/* If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b */
/* is solved for, which is equivalent to solve for R and L in */
/* A' * R + D' * L = scale * C (3) */
/* R * B' + L * E' = scale * -F */
/* This case is used to compute an estimate of Dif[(A, D), (B, E)] = */
/* = sigma_min(Z) using reverse communicaton with ZLACON. */
/* ZTGSY2 also (IJOB >= 1) contributes to the computation in ZTGSYL */
/* of an upper bound on the separation between to matrix pairs. Then */
/* the input (A, D), (B, E) are sub-pencils of two matrix pairs in */
/* ZTGSYL. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* = 'N', solve the generalized Sylvester equation (1). */
/* = 'T': solve the 'transposed' system (3). */
/* IJOB (input) INTEGER */
/* Specifies what kind of functionality to be performed. */
/* =0: solve (1) only. */
/* =1: A contribution from this subsystem to a Frobenius */
/* norm-based estimate of the separation between two matrix */
/* pairs is computed. (look ahead strategy is used). */
/* =2: A contribution from this subsystem to a Frobenius */
/* norm-based estimate of the separation between two matrix */
/* pairs is computed. (DGECON on sub-systems is used.) */
/* Not referenced if TRANS = 'T'. */
/* M (input) INTEGER */
/* On entry, M specifies the order of A and D, and the row */
/* dimension of C, F, R and L. */
/* N (input) INTEGER */
/* On entry, N specifies the order of B and E, and the column */
/* dimension of C, F, R and L. */
/* A (input) COMPLEX*16 array, dimension (LDA, M) */
/* On entry, A contains an upper triangular matrix. */
/* LDA (input) INTEGER */
/* The leading dimension of the matrix A. LDA >= max(1, M). */
/* B (input) COMPLEX*16 array, dimension (LDB, N) */
/* On entry, B contains an upper triangular matrix. */
/* LDB (input) INTEGER */
/* The leading dimension of the matrix B. LDB >= max(1, N). */
/* C (input/output) COMPLEX*16 array, dimension (LDC, N) */
/* On entry, C contains the right-hand-side of the first matrix */
/* equation in (1). */
/* On exit, if IJOB = 0, C has been overwritten by the solution */
/* R. */
/* LDC (input) INTEGER */
/* The leading dimension of the matrix C. LDC >= max(1, M). */
/* D (input) COMPLEX*16 array, dimension (LDD, M) */
/* On entry, D contains an upper triangular matrix. */
/* LDD (input) INTEGER */
/* The leading dimension of the matrix D. LDD >= max(1, M). */
/* E (input) COMPLEX*16 array, dimension (LDE, N) */
/* On entry, E contains an upper triangular matrix. */
/* LDE (input) INTEGER */
/* The leading dimension of the matrix E. LDE >= max(1, N). */
/* F (input/output) COMPLEX*16 array, dimension (LDF, N) */
/* On entry, F contains the right-hand-side of the second matrix */
/* equation in (1). */
/* On exit, if IJOB = 0, F has been overwritten by the solution */
/* L. */
/* LDF (input) INTEGER */
/* The leading dimension of the matrix F. LDF >= max(1, M). */
/* SCALE (output) DOUBLE PRECISION */
/* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */
/* R and L (C and F on entry) will hold the solutions to a */
/* slightly perturbed system but the input matrices A, B, D and */
/* E have not been changed. If SCALE = 0, R and L will hold the */
/* solutions to the homogeneous system with C = F = 0. */
/* Normally, SCALE = 1. */
/* RDSUM (input/output) DOUBLE PRECISION */
/* On entry, the sum of squares of computed contributions to */
/* the Dif-estimate under computation by ZTGSYL, where the */
/* scaling factor RDSCAL (see below) has been factored out. */
/* On exit, the corresponding sum of squares updated with the */
/* contributions from the current sub-system. */
/* If TRANS = 'T' RDSUM is not touched. */
/* NOTE: RDSUM only makes sense when ZTGSY2 is called by */
/* ZTGSYL. */
/* RDSCAL (input/output) DOUBLE PRECISION */
/* On entry, scaling factor used to prevent overflow in RDSUM. */
/* On exit, RDSCAL is updated w.r.t. the current contributions */
/* in RDSUM. */
/* If TRANS = 'T', RDSCAL is not touched. */
/* NOTE: RDSCAL only makes sense when ZTGSY2 is called by */
/* ZTGSYL. */
/* INFO (output) INTEGER */
/* On exit, if INFO is set to */
/* =0: Successful exit */
/* <0: If INFO = -i, input argument number i is illegal. */
/* >0: The matrix pairs (A, D) and (B, E) have common or very */
/* close eigenvalues. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* ===================================================================== */
/* Decode and test input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
d_dim1 = *ldd;
d_offset = 1 + d_dim1;
d__ -= d_offset;
e_dim1 = *lde;
e_offset = 1 + e_dim1;
e -= e_offset;
f_dim1 = *ldf;
f_offset = 1 + f_dim1;
f -= f_offset;
/* Function Body */
*info = 0;
ierr = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "C")) {
*info = -1;
} else if (notran) {
if (*ijob < 0 || *ijob > 2) {
*info = -2;
}
}
if (*info == 0) {
if (*m <= 0) {
*info = -3;
} else if (*n <= 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*ldd < max(1,*m)) {
*info = -12;
} else if (*lde < max(1,*n)) {
*info = -14;
} else if (*ldf < max(1,*m)) {
*info = -16;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTGSY2", &i__1);
return 0;
}
if (notran) {
/* Solve (I, J) - system */
/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
*scale = 1.;
scaloc = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
for (i__ = *m; i__ >= 1; --i__) {
/* Build 2 by 2 system */
i__2 = i__ + i__ * a_dim1;
z__[0].r = a[i__2].r, z__[0].i = a[i__2].i;
i__2 = i__ + i__ * d_dim1;
z__[1].r = d__[i__2].r, z__[1].i = d__[i__2].i;
i__2 = j + j * b_dim1;
z__1.r = -b[i__2].r, z__1.i = -b[i__2].i;
z__[2].r = z__1.r, z__[2].i = z__1.i;
i__2 = j + j * e_dim1;
z__1.r = -e[i__2].r, z__1.i = -e[i__2].i;
z__[3].r = z__1.r, z__[3].i = z__1.i;
/* Set up right hand side(s) */
i__2 = i__ + j * c_dim1;
rhs[0].r = c__[i__2].r, rhs[0].i = c__[i__2].i;
i__2 = i__ + j * f_dim1;
rhs[1].r = f[i__2].r, rhs[1].i = f[i__2].i;
/* Solve Z * x = RHS */
zgetc2_(&c__2, z__, &c__2, ipiv, jpiv, &ierr);
if (ierr > 0) {
*info = ierr;
}
if (*ijob == 0) {
zgesc2_(&c__2, z__, &c__2, rhs, ipiv, jpiv, &scaloc);
if (scaloc != 1.) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
z__1.r = scaloc, z__1.i = 0.;
zscal_(m, &z__1, &c__[k * c_dim1 + 1], &c__1);
z__1.r = scaloc, z__1.i = 0.;
zscal_(m, &z__1, &f[k * f_dim1 + 1], &c__1);
}
*scale *= scaloc;
}
} else {
zlatdf_(ijob, &c__2, z__, &c__2, rhs, rdsum, rdscal, ipiv,
jpiv);
}
/* Unpack solution vector(s) */
i__2 = i__ + j * c_dim1;
c__[i__2].r = rhs[0].r, c__[i__2].i = rhs[0].i;
i__2 = i__ + j * f_dim1;
f[i__2].r = rhs[1].r, f[i__2].i = rhs[1].i;
/* Substitute R(I, J) and L(I, J) into remaining equation. */
if (i__ > 1) {
z__1.r = -rhs[0].r, z__1.i = -rhs[0].i;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = i__ - 1;
zaxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &c__[j
* c_dim1 + 1], &c__1);
i__2 = i__ - 1;
zaxpy_(&i__2, &alpha, &d__[i__ * d_dim1 + 1], &c__1, &f[j
* f_dim1 + 1], &c__1);
}
if (j < *n) {
i__2 = *n - j;
zaxpy_(&i__2, &rhs[1], &b[j + (j + 1) * b_dim1], ldb, &
c__[i__ + (j + 1) * c_dim1], ldc);
i__2 = *n - j;
zaxpy_(&i__2, &rhs[1], &e[j + (j + 1) * e_dim1], lde, &f[
i__ + (j + 1) * f_dim1], ldf);
}
}
}
} else {
/* Solve transposed (I, J) - system: */
/* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) */
/* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */
*scale = 1.;
scaloc = 1.;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = *n; j >= 1; --j) {
/* Build 2 by 2 system Z' */
d_cnjg(&z__1, &a[i__ + i__ * a_dim1]);
z__[0].r = z__1.r, z__[0].i = z__1.i;
d_cnjg(&z__2, &b[j + j * b_dim1]);
z__1.r = -z__2.r, z__1.i = -z__2.i;
z__[1].r = z__1.r, z__[1].i = z__1.i;
d_cnjg(&z__1, &d__[i__ + i__ * d_dim1]);
z__[2].r = z__1.r, z__[2].i = z__1.i;
d_cnjg(&z__2, &e[j + j * e_dim1]);
z__1.r = -z__2.r, z__1.i = -z__2.i;
z__[3].r = z__1.r, z__[3].i = z__1.i;
/* Set up right hand side(s) */
i__2 = i__ + j * c_dim1;
rhs[0].r = c__[i__2].r, rhs[0].i = c__[i__2].i;
i__2 = i__ + j * f_dim1;
rhs[1].r = f[i__2].r, rhs[1].i = f[i__2].i;
/* Solve Z' * x = RHS */
zgetc2_(&c__2, z__, &c__2, ipiv, jpiv, &ierr);
if (ierr > 0) {
*info = ierr;
}
zgesc2_(&c__2, z__, &c__2, rhs, ipiv, jpiv, &scaloc);
if (scaloc != 1.) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
z__1.r = scaloc, z__1.i = 0.;
zscal_(m, &z__1, &c__[k * c_dim1 + 1], &c__1);
z__1.r = scaloc, z__1.i = 0.;
zscal_(m, &z__1, &f[k * f_dim1 + 1], &c__1);
}
*scale *= scaloc;
}
/* Unpack solution vector(s) */
i__2 = i__ + j * c_dim1;
c__[i__2].r = rhs[0].r, c__[i__2].i = rhs[0].i;
i__2 = i__ + j * f_dim1;
f[i__2].r = rhs[1].r, f[i__2].i = rhs[1].i;
/* Substitute R(I, J) and L(I, J) into remaining equation. */
i__2 = j - 1;
for (k = 1; k <= i__2; ++k) {
i__3 = i__ + k * f_dim1;
i__4 = i__ + k * f_dim1;
d_cnjg(&z__4, &b[k + j * b_dim1]);
z__3.r = rhs[0].r * z__4.r - rhs[0].i * z__4.i, z__3.i =
rhs[0].r * z__4.i + rhs[0].i * z__4.r;
z__2.r = f[i__4].r + z__3.r, z__2.i = f[i__4].i + z__3.i;
d_cnjg(&z__6, &e[k + j * e_dim1]);
z__5.r = rhs[1].r * z__6.r - rhs[1].i * z__6.i, z__5.i =
rhs[1].r * z__6.i + rhs[1].i * z__6.r;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
f[i__3].r = z__1.r, f[i__3].i = z__1.i;
}
i__2 = *m;
for (k = i__ + 1; k <= i__2; ++k) {
i__3 = k + j * c_dim1;
i__4 = k + j * c_dim1;
d_cnjg(&z__4, &a[i__ + k * a_dim1]);
z__3.r = z__4.r * rhs[0].r - z__4.i * rhs[0].i, z__3.i =
z__4.r * rhs[0].i + z__4.i * rhs[0].r;
z__2.r = c__[i__4].r - z__3.r, z__2.i = c__[i__4].i -
z__3.i;
d_cnjg(&z__6, &d__[i__ + k * d_dim1]);
z__5.r = z__6.r * rhs[1].r - z__6.i * rhs[1].i, z__5.i =
z__6.r * rhs[1].i + z__6.i * rhs[1].r;
z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
}
}
}
return 0;
/* End of ZTGSY2 */
} /* ztgsy2_ */
int zhpgst_(int *itype, char *uplo, int *n,
doublecomplex *ap, doublecomplex *bp, int *info)
{
/* System generated locals */
int i__1, i__2, i__3, i__4;
double d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
int j, k, j1, k1, jj, kk;
doublecomplex ct;
double ajj;
int j1j1;
double akk;
int k1k1;
double bjj, bkk;
extern int zhpr2_(char *, int *, doublecomplex *,
doublecomplex *, int *, doublecomplex *, int *,
doublecomplex *);
extern int lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, int *);
int upper;
extern int zhpmv_(char *, int *, doublecomplex *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
doublecomplex *, int *), zaxpy_(int *,
doublecomplex *, doublecomplex *, int *, doublecomplex *,
int *), ztpmv_(char *, char *, char *, int *,
doublecomplex *, doublecomplex *, int *), ztpsv_(char *, char *, char *, int *, doublecomplex *
, doublecomplex *, int *), xerbla_(
char *, int *), zdscal_(int *, double *,
doublecomplex *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPGST reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form, using packed storage. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */
/* B must have been previously factorized as U**H*U or L*L**H by ZPPTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored and B is factored as */
/* U**H*U; */
/* = 'L': Lower triangle of A is stored and B is factored as */
/* L*L**H. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* BP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* The triangular factor from the Cholesky factorization of B, */
/* stored in the same format as A, as returned by ZPPTRF. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--bp;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPGST", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
/* J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
i__2 = jj;
i__3 = jj;
d__1 = ap[i__3].r;
ap[i__2].r = d__1, ap[i__2].i = 0.;
i__2 = jj;
bjj = bp[i__2].r;
ztpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], &
ap[j1], &c__1);
i__2 = j - 1;
z__1.r = -1., z__1.i = -0.;
zhpmv_(uplo, &i__2, &z__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[
j1], &c__1);
i__2 = j - 1;
d__1 = 1. / bjj;
zdscal_(&i__2, &d__1, &ap[j1], &c__1);
i__2 = jj;
i__3 = jj;
i__4 = j - 1;
zdotc_(&z__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
z__2.r = ap[i__3].r - z__3.r, z__2.i = ap[i__3].i - z__3.i;
z__1.r = z__2.r / bjj, z__1.i = z__2.i / bjj;
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = kk;
ap[i__2].r = akk, ap[i__2].i = 0.;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &ap[kk + 1], &c__1);
d__1 = akk * -.5;
ct.r = d__1, ct.i = 0.;
i__2 = *n - k;
zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
z__1.r = -1., z__1.i = -0.;
zhpr2_(uplo, &i__2, &z__1, &ap[kk + 1], &c__1, &bp[kk + 1]
, &c__1, &ap[k1k1]);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
ztpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
&ap[kk + 1], &c__1);
}
kk = k1k1;
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
/* K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
i__2 = k - 1;
ztpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
k1], &c__1);
d__1 = akk * .5;
ct.r = d__1, ct.i = 0.;
i__2 = k - 1;
zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
zhpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, &
ap[1]);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &ap[k1], &c__1);
i__2 = kk;
/* Computing 2nd power */
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
ap[i__2].r = d__1, ap[i__2].i = 0.;
/* L30: */
}
} else {
/* Compute L'*A*L */
/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
i__2 = jj;
ajj = ap[i__2].r;
i__2 = jj;
bjj = bp[i__2].r;
i__2 = jj;
d__1 = ajj * bjj;
i__3 = *n - j;
zdotc_(&z__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
i__2 = *n - j;
zdscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
zhpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, &
c_b1, &ap[jj + 1], &c__1);
i__2 = *n - j + 1;
ztpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj]
, &ap[jj], &c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of ZHPGST */
} /* zhpgst_ */
int zhetd2_(char *uplo, int *n, doublecomplex *a,
int *lda, double *d__, double *e, doublecomplex *tau,
int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3;
double d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
int i__;
doublecomplex taui;
extern int zher2_(char *, int *, doublecomplex *,
doublecomplex *, int *, doublecomplex *, int *,
doublecomplex *, int *);
doublecomplex alpha;
extern int lsame_(char *, char *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, int *);
extern int zhemv_(char *, int *, doublecomplex *,
doublecomplex *, int *, doublecomplex *, int *,
doublecomplex *, doublecomplex *, int *);
int upper;
extern int zaxpy_(int *, doublecomplex *,
doublecomplex *, int *, doublecomplex *, int *), xerbla_(
char *, int *), zlarfg_(int *, doublecomplex *,
doublecomplex *, int *, doublecomplex *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHETD2 reduces a complex Hermitian matrix A to float symmetric */
/* tridiagonal form T by a unitary similarity transformation: */
/* Q' * A * Q = T. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* n-by-n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n-by-n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
/* of A are overwritten by the corresponding elements of the */
/* tridiagonal matrix T, and the elements above the first */
/* superdiagonal, with the array TAU, represent the unitary */
/* matrix Q as a product of elementary reflectors; if UPLO */
/* = 'L', the diagonal and first subdiagonal of A are over- */
/* written by the corresponding elements of the tridiagonal */
/* matrix T, and the elements below the first subdiagonal, with */
/* the array TAU, represent the unitary matrix Q as a product */
/* of elementary reflectors. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* D (output) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of the tridiagonal matrix T: */
/* D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (N-1) */
/* The off-diagonal elements of the tridiagonal matrix T: */
/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
/* TAU (output) COMPLEX*16 array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n-1) . . . H(2) H(1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
/* A(1:i-1,i+1), and tau in TAU(i). */
/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(1) H(2) . . . H(n-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
/* and tau in TAU(i). */
/* The contents of A on exit are illustrated by the following examples */
/* with n = 5: */
/* if UPLO = 'U': if UPLO = 'L': */
/* ( d e v2 v3 v4 ) ( d ) */
/* ( d e v3 v4 ) ( e d ) */
/* ( d e v4 ) ( v1 e d ) */
/* ( d e ) ( v1 v2 e d ) */
/* ( d ) ( v1 v2 v3 e d ) */
/* where d and e denote diagonal and off-diagonal elements of T, and vi */
/* denotes an element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tau;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHETD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A */
i__1 = *n + *n * a_dim1;
i__2 = *n + *n * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(1:i-1,i+1) */
i__1 = i__ + (i__ + 1) * a_dim1;
alpha.r = a[i__1].r, alpha.i = a[i__1].i;
zlarfg_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui);
i__1 = i__;
e[i__1] = alpha.r;
if (taui.r != 0. || taui.i != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
i__1 = i__ + (i__ + 1) * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
/* Compute x := tau * A * v storing x in TAU(1:i) */
zhemv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) *
a_dim1 + 1], &c__1, &c_b2, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
z__3.r = -.5, z__3.i = -0.;
z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
taui.i + z__3.i * taui.r;
zdotc_(&z__4, &i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1]
, &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
zaxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[
1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
z__1.r = -1., z__1.i = -0.;
zher2_(uplo, &i__, &z__1, &a[(i__ + 1) * a_dim1 + 1], &c__1, &
tau[1], &c__1, &a[a_offset], lda);
} else {
i__1 = i__ + i__ * a_dim1;
i__2 = i__ + i__ * a_dim1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
}
i__1 = i__ + (i__ + 1) * a_dim1;
i__2 = i__;
a[i__1].r = e[i__2], a[i__1].i = 0.;
i__1 = i__ + 1;
i__2 = i__ + 1 + (i__ + 1) * a_dim1;
d__[i__1] = a[i__2].r;
i__1 = i__;
tau[i__1].r = taui.r, tau[i__1].i = taui.i;
/* L10: */
}
i__1 = a_dim1 + 1;
d__[1] = a[i__1].r;
} else {
/* Reduce the lower triangle of A */
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
d__1 = a[i__2].r;
a[i__1].r = d__1, a[i__1].i = 0.;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) = I - tau * v * v' */
/* to annihilate A(i+2:n,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[MIN(i__3, *n)+ i__ * a_dim1], &c__1, &
taui);
i__2 = i__;
e[i__2] = alpha.r;
if (taui.r != 0. || taui.i != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
zhemv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b2, &tau[
i__], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
z__3.r = -.5, z__3.i = -0.;
z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
taui.i + z__3.i * taui.r;
i__2 = *n - i__;
zdotc_(&z__4, &i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ *
a_dim1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
z__4.i + z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - i__;
zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w' - w * v' */
i__2 = *n - i__;
z__1.r = -1., z__1.i = -0.;
zher2_(uplo, &i__2, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1,
&tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1],
lda);
} else {
i__2 = i__ + 1 + (i__ + 1) * a_dim1;
i__3 = i__ + 1 + (i__ + 1) * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
}
i__2 = i__ + 1 + i__ * a_dim1;
i__3 = i__;
a[i__2].r = e[i__3], a[i__2].i = 0.;
i__2 = i__;
i__3 = i__ + i__ * a_dim1;
d__[i__2] = a[i__3].r;
i__2 = i__;
tau[i__2].r = taui.r, tau[i__2].i = taui.i;
/* L20: */
}
i__1 = *n;
i__2 = *n + *n * a_dim1;
d__[i__1] = a[i__2].r;
}
return 0;
/* End of ZHETD2 */
} /* zhetd2_ */
/* Subroutine */ int zlatzm_(char *side, integer *m, integer *n,
doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
c1, doublecomplex *c2, integer *ldc, doublecomplex *work)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
This routine is deprecated and has been replaced by routine ZUNMRZ.
ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix.
Let P = I - tau*u*u', u = ( 1 ),
( v )
where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if
SIDE = 'R'.
If SIDE equals 'L', let
C = [ C1 ] 1
[ C2 ] m-1
n
Then C is overwritten by P*C.
If SIDE equals 'R', let
C = [ C1, C2 ] m
1 n-1
Then C is overwritten by C*P.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': form P * C
= 'R': form C * P
M (input) INTEGER
The number of rows of the matrix C.
N (input) INTEGER
The number of columns of the matrix C.
V (input) COMPLEX*16 array, dimension
(1 + (M-1)*abs(INCV)) if SIDE = 'L'
(1 + (N-1)*abs(INCV)) if SIDE = 'R'
The vector v in the representation of P. V is not used
if TAU = 0.
INCV (input) INTEGER
The increment between elements of v. INCV <> 0
TAU (input) COMPLEX*16
The value tau in the representation of P.
C1 (input/output) COMPLEX*16 array, dimension
(LDC,N) if SIDE = 'L'
(M,1) if SIDE = 'R'
On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1
if SIDE = 'R'.
On exit, the first row of P*C if SIDE = 'L', or the first
column of C*P if SIDE = 'R'.
C2 (input/output) COMPLEX*16 array, dimension
(LDC, N) if SIDE = 'L'
(LDC, N-1) if SIDE = 'R'
On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the
m x (n - 1) matrix C2 if SIDE = 'R'.
On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P
if SIDE = 'R'.
LDC (input) INTEGER
The leading dimension of the arrays C1 and C2.
LDC >= max(1,M).
WORK (workspace) COMPLEX*16 array, dimension
(N) if SIDE = 'L'
(M) if SIDE = 'R'
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
doublecomplex z__1;
/* Local variables */
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
, zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), zlacgv_(integer *,
doublecomplex *, integer *);
--v;
c2_dim1 = *ldc;
c2_offset = 1 + c2_dim1 * 1;
c2 -= c2_offset;
c1_dim1 = *ldc;
c1_offset = 1 + c1_dim1 * 1;
c1 -= c1_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0 || tau->r == 0. && tau->i == 0.) {
return 0;
}
if (lsame_(side, "L")) {
/* w := conjg( C1 + v' * C2 ) */
zcopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
zlacgv_(n, &work[1], &c__1);
i__1 = *m - 1;
zgemv_("Conjugate transpose", &i__1, n, &c_b1, &c2[c2_offset], ldc, &
v[1], incv, &c_b1, &work[1], &c__1);
/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
[ C2 ] [ C2 ] [ v ] */
zlacgv_(n, &work[1], &c__1);
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(n, &z__1, &work[1], &c__1, &c1[c1_offset], ldc);
i__1 = *m - 1;
z__1.r = -tau->r, z__1.i = -tau->i;
zgeru_(&i__1, n, &z__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset],
ldc);
} else if (lsame_(side, "R")) {
/* w := C1 + C2 * v */
zcopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
i__1 = *n - 1;
zgemv_("No transpose", m, &i__1, &c_b1, &c2[c2_offset], ldc, &v[1],
incv, &c_b1, &work[1], &c__1);
/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(m, &z__1, &work[1], &c__1, &c1[c1_offset], &c__1);
i__1 = *n - 1;
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, &i__1, &z__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset],
ldc);
}
return 0;
/* End of ZLATZM */
} /* zlatzm_ */
int zgehrd_(int *n, int *ilo, int *ihi,
doublecomplex *a, int *lda, doublecomplex *tau, doublecomplex *
work, int *lwork, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublecomplex z__1;
/* Local variables */
int i__, j;
doublecomplex t[4160] /* was [65][64] */;
int ib;
doublecomplex ei;
int nb, nh, nx, iws, nbmin, iinfo;
extern int zgemm_(char *, char *, int *, int *,
int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, doublecomplex *,
int *), ztrmm_(char *, char *, char *, char *,
int *, int *, doublecomplex *, doublecomplex *, int *
, doublecomplex *, int *),
zaxpy_(int *, doublecomplex *, doublecomplex *, int *,
doublecomplex *, int *), zgehd2_(int *, int *,
int *, doublecomplex *, int *, doublecomplex *,
doublecomplex *, int *), zlahr2_(int *, int *,
int *, doublecomplex *, int *, doublecomplex *,
doublecomplex *, int *, doublecomplex *, int *), xerbla_(
char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
extern int zlarfb_(char *, char *, char *, char *,
int *, int *, int *, doublecomplex *, int *,
doublecomplex *, int *, doublecomplex *, int *,
doublecomplex *, int *);
int ldwork, lwkopt;
int lquery;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by */
/* an unitary similarity transformation: Q' * A * Q = H . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that A is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to ZGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the N-by-N general matrix to be reduced. */
/* On exit, the upper triangle and the first subdiagonal of A */
/* are overwritten with the upper Hessenberg matrix H, and the */
/* elements below the first subdiagonal, with the array TAU, */
/* represent the unitary matrix Q as a product of elementary */
/* reflectors. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* TAU (output) COMPLEX*16 array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */
/* zero. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= MAX(1,N). */
/* For optimum performance LWORK >= N*NB, where NB is the */
/* optimal blocksize. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of (ihi-ilo) elementary */
/* reflectors */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
/* exit in A(i+2:ihi,i), and tau in TAU(i). */
/* The contents of A are illustrated by the following example, with */
/* n = 7, ilo = 2 and ihi = 6: */
/* on entry, on exit, */
/* ( a a a a a a a ) ( a a h h h h a ) */
/* ( a a a a a a ) ( a h h h h a ) */
/* ( a a a a a a ) ( h h h h h h ) */
/* ( a a a a a a ) ( v2 h h h h h ) */
/* ( a a a a a a ) ( v2 v3 h h h h ) */
/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
/* ( a ) ( a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* This file is a slight modification of LAPACK-3.0's ZGEHRD */
/* subroutine incorporating improvements proposed by Quintana-Orti and */
/* Van de Geijn (2005). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
/* Computing MIN */
i__1 = 64, i__2 = ilaenv_(&c__1, "ZGEHRD", " ", n, ilo, ihi, &c_n1);
nb = MIN(i__1,i__2);
lwkopt = *n * nb;
work[1].r = (double) lwkopt, work[1].i = 0.;
lquery = *lwork == -1;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > MAX(1,*n)) {
*info = -2;
} else if (*ihi < MIN(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < MAX(1,*n)) {
*info = -5;
} else if (*lwork < MAX(1,*n) && ! lquery) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGEHRD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/* L10: */
}
i__1 = *n - 1;
for (i__ = MAX(1,*ihi); i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/* L20: */
}
/* Quick return if possible */
nh = *ihi - *ilo + 1;
if (nh <= 1) {
work[1].r = 1., work[1].i = 0.;
return 0;
}
/* Determine the block size */
/* Computing MIN */
i__1 = 64, i__2 = ilaenv_(&c__1, "ZGEHRD", " ", n, ilo, ihi, &c_n1);
nb = MIN(i__1,i__2);
nbmin = 2;
iws = 1;
if (nb > 1 && nb < nh) {
/* Determine when to cross over from blocked to unblocked code */
/* (last block is always handled by unblocked code) */
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEHRD", " ", n, ilo, ihi, &c_n1);
nx = MAX(i__1,i__2);
if (nx < nh) {
/* Determine if workspace is large enough for blocked code */
iws = *n * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: determine the */
/* minimum value of NB, and reduce NB or force use of */
/* unblocked code */
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEHRD", " ", n, ilo, ihi, &
c_n1);
nbmin = MAX(i__1,i__2);
if (*lwork >= *n * nbmin) {
nb = *lwork / *n;
} else {
nb = 1;
}
}
}
}
ldwork = *n;
if (nb < nbmin || nb >= nh) {
/* Use unblocked code below */
i__ = *ilo;
} else {
/* Use blocked code */
i__1 = *ihi - 1 - nx;
i__2 = nb;
for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *ihi - i__;
ib = MIN(i__3,i__4);
/* Reduce columns i:i+ib-1 to Hessenberg form, returning the */
/* matrices V and T of the block reflector H = I - V*T*V' */
/* which performs the reduction, and also the matrix Y = A*V*T */
zlahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, &
c__65, &work[1], &ldwork);
/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */
/* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set */
/* to 1 */
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
ei.r = a[i__3].r, ei.i = a[i__3].i;
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
a[i__3].r = 1., a[i__3].i = 0.;
i__3 = *ihi - i__ - ib + 1;
z__1.r = -1., z__1.i = -0.;
zgemm_("No transpose", "Conjugate transpose", ihi, &i__3, &ib, &
z__1, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda,
&c_b2, &a[(i__ + ib) * a_dim1 + 1], lda);
i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
a[i__3].r = ei.r, a[i__3].i = ei.i;
/* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the */
/* right */
i__3 = ib - 1;
ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &i__, &
i__3, &c_b2, &a[i__ + 1 + i__ * a_dim1], lda, &work[1], &
ldwork);
i__3 = ib - 2;
for (j = 0; j <= i__3; ++j) {
z__1.r = -1., z__1.i = -0.;
zaxpy_(&i__, &z__1, &work[ldwork * j + 1], &c__1, &a[(i__ + j
+ 1) * a_dim1 + 1], &c__1);
/* L30: */
}
/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */
/* left */
i__3 = *ihi - i__;
i__4 = *n - i__ - ib + 1;
zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise", &
i__3, &i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, &
c__65, &a[i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &
ldwork);
/* L40: */
}
}
/* Use unblocked code to reduce the rest of the matrix */
zgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
work[1].r = (double) iws, work[1].i = 0.;
return 0;
/* End of ZGEHRD */
} /* zgehrd_ */
int zgtrfs_(char *trans, int *n, int *nrhs,
doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
doublecomplex *dlf, doublecomplex *df, doublecomplex *duf,
doublecomplex *du2, int *ipiv, doublecomplex *b, int *ldb,
doublecomplex *x, int *ldx, double *ferr, double *berr,
doublecomplex *work, double *rwork, int *info)
{
/* System generated locals */
int b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
i__6, i__7, i__8, i__9;
double d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
d__11, d__12, d__13, d__14;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
int i__, j;
double s;
int nz;
double eps;
int kase;
double safe1, safe2;
extern int lsame_(char *, char *);
int isave[3], count;
extern int zcopy_(int *, doublecomplex *, int *,
doublecomplex *, int *), zaxpy_(int *, doublecomplex *,
doublecomplex *, int *, doublecomplex *, int *), zlacn2_(
int *, doublecomplex *, doublecomplex *, double *,
int *, int *);
extern double dlamch_(char *);
double safmin;
extern int xerbla_(char *, int *), zlagtm_(
char *, int *, int *, double *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, int *,
double *, doublecomplex *, int *);
int notran;
char transn[1], transt[1];
double lstres;
extern int zgttrs_(char *, int *, int *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, int *, doublecomplex *, int *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGTRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is tridiagonal, and provides */
/* error bounds and backward error estimates for the solution. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* DL (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) subdiagonal elements of A. */
/* D (input) COMPLEX*16 array, dimension (N) */
/* The diagonal elements of A. */
/* DU (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) superdiagonal elements of A. */
/* DLF (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) multipliers that define the matrix L from the */
/* LU factorization of A as computed by ZGTTRF. */
/* DF (input) COMPLEX*16 array, dimension (N) */
/* The n diagonal elements of the upper triangular matrix U from */
/* the LU factorization of A. */
/* DUF (input) COMPLEX*16 array, dimension (N-1) */
/* The (n-1) elements of the first superdiagonal of U. */
/* DU2 (input) COMPLEX*16 array, dimension (N-2) */
/* The (n-2) elements of the second superdiagonal of U. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
/* interchanged with row IPIV(i). IPIV(i) will always be either */
/* i or i+1; IPIV(i) = i indicates a row interchange was not */
/* required. */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by ZGTTRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= MAX(1,N). */
/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--dl;
--d__;
--du;
--dlf;
--df;
--duf;
--du2;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < MAX(1,*n)) {
*info = -13;
} else if (*ldx < MAX(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGTRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = 4;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A, A**T, or A**H, depending on TRANS. */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
zlagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x[j *
x_dim1 + 1], ldx, &c_b19, &work[1], n);
/* Compute ABS(op(A))*ABS(x) + ABS(b) for use in the backward */
/* error bound. */
if (notran) {
if (*n == 1) {
i__2 = j * b_dim1 + 1;
i__3 = j * x_dim1 + 1;
rwork[1] = (d__1 = b[i__2].r, ABS(d__1)) + (d__2 = d_imag(&b[
j * b_dim1 + 1]), ABS(d__2)) + ((d__3 = d__[1].r, ABS(
d__3)) + (d__4 = d_imag(&d__[1]), ABS(d__4))) * ((
d__5 = x[i__3].r, ABS(d__5)) + (d__6 = d_imag(&x[j *
x_dim1 + 1]), ABS(d__6)));
} else {
i__2 = j * b_dim1 + 1;
i__3 = j * x_dim1 + 1;
i__4 = j * x_dim1 + 2;
rwork[1] = (d__1 = b[i__2].r, ABS(d__1)) + (d__2 = d_imag(&b[
j * b_dim1 + 1]), ABS(d__2)) + ((d__3 = d__[1].r, ABS(
d__3)) + (d__4 = d_imag(&d__[1]), ABS(d__4))) * ((
d__5 = x[i__3].r, ABS(d__5)) + (d__6 = d_imag(&x[j *
x_dim1 + 1]), ABS(d__6))) + ((d__7 = du[1].r, ABS(
d__7)) + (d__8 = d_imag(&du[1]), ABS(d__8))) * ((d__9
= x[i__4].r, ABS(d__9)) + (d__10 = d_imag(&x[j *
x_dim1 + 2]), ABS(d__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__ - 1;
i__5 = i__ - 1 + j * x_dim1;
i__6 = i__;
i__7 = i__ + j * x_dim1;
i__8 = i__;
i__9 = i__ + 1 + j * x_dim1;
rwork[i__] = (d__1 = b[i__3].r, ABS(d__1)) + (d__2 =
d_imag(&b[i__ + j * b_dim1]), ABS(d__2)) + ((d__3
= dl[i__4].r, ABS(d__3)) + (d__4 = d_imag(&dl[i__
- 1]), ABS(d__4))) * ((d__5 = x[i__5].r, ABS(d__5)
) + (d__6 = d_imag(&x[i__ - 1 + j * x_dim1]), ABS(
d__6))) + ((d__7 = d__[i__6].r, ABS(d__7)) + (
d__8 = d_imag(&d__[i__]), ABS(d__8))) * ((d__9 =
x[i__7].r, ABS(d__9)) + (d__10 = d_imag(&x[i__ +
j * x_dim1]), ABS(d__10))) + ((d__11 = du[i__8].r,
ABS(d__11)) + (d__12 = d_imag(&du[i__]), ABS(
d__12))) * ((d__13 = x[i__9].r, ABS(d__13)) + (
d__14 = d_imag(&x[i__ + 1 + j * x_dim1]), ABS(
d__14)));
/* L30: */
}
i__2 = *n + j * b_dim1;
i__3 = *n - 1;
i__4 = *n - 1 + j * x_dim1;
i__5 = *n;
i__6 = *n + j * x_dim1;
rwork[*n] = (d__1 = b[i__2].r, ABS(d__1)) + (d__2 = d_imag(&b[
*n + j * b_dim1]), ABS(d__2)) + ((d__3 = dl[i__3].r,
ABS(d__3)) + (d__4 = d_imag(&dl[*n - 1]), ABS(d__4)))
* ((d__5 = x[i__4].r, ABS(d__5)) + (d__6 = d_imag(&x[*
n - 1 + j * x_dim1]), ABS(d__6))) + ((d__7 = d__[i__5]
.r, ABS(d__7)) + (d__8 = d_imag(&d__[*n]), ABS(d__8)))
* ((d__9 = x[i__6].r, ABS(d__9)) + (d__10 = d_imag(&
x[*n + j * x_dim1]), ABS(d__10)));
}
} else {
if (*n == 1) {
i__2 = j * b_dim1 + 1;
i__3 = j * x_dim1 + 1;
rwork[1] = (d__1 = b[i__2].r, ABS(d__1)) + (d__2 = d_imag(&b[
j * b_dim1 + 1]), ABS(d__2)) + ((d__3 = d__[1].r, ABS(
d__3)) + (d__4 = d_imag(&d__[1]), ABS(d__4))) * ((
d__5 = x[i__3].r, ABS(d__5)) + (d__6 = d_imag(&x[j *
x_dim1 + 1]), ABS(d__6)));
} else {
i__2 = j * b_dim1 + 1;
i__3 = j * x_dim1 + 1;
i__4 = j * x_dim1 + 2;
rwork[1] = (d__1 = b[i__2].r, ABS(d__1)) + (d__2 = d_imag(&b[
j * b_dim1 + 1]), ABS(d__2)) + ((d__3 = d__[1].r, ABS(
d__3)) + (d__4 = d_imag(&d__[1]), ABS(d__4))) * ((
d__5 = x[i__3].r, ABS(d__5)) + (d__6 = d_imag(&x[j *
x_dim1 + 1]), ABS(d__6))) + ((d__7 = dl[1].r, ABS(
d__7)) + (d__8 = d_imag(&dl[1]), ABS(d__8))) * ((d__9
= x[i__4].r, ABS(d__9)) + (d__10 = d_imag(&x[j *
x_dim1 + 2]), ABS(d__10)));
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__ - 1;
i__5 = i__ - 1 + j * x_dim1;
i__6 = i__;
i__7 = i__ + j * x_dim1;
i__8 = i__;
i__9 = i__ + 1 + j * x_dim1;
rwork[i__] = (d__1 = b[i__3].r, ABS(d__1)) + (d__2 =
d_imag(&b[i__ + j * b_dim1]), ABS(d__2)) + ((d__3
= du[i__4].r, ABS(d__3)) + (d__4 = d_imag(&du[i__
- 1]), ABS(d__4))) * ((d__5 = x[i__5].r, ABS(d__5)
) + (d__6 = d_imag(&x[i__ - 1 + j * x_dim1]), ABS(
d__6))) + ((d__7 = d__[i__6].r, ABS(d__7)) + (
d__8 = d_imag(&d__[i__]), ABS(d__8))) * ((d__9 =
x[i__7].r, ABS(d__9)) + (d__10 = d_imag(&x[i__ +
j * x_dim1]), ABS(d__10))) + ((d__11 = dl[i__8].r,
ABS(d__11)) + (d__12 = d_imag(&dl[i__]), ABS(
d__12))) * ((d__13 = x[i__9].r, ABS(d__13)) + (
d__14 = d_imag(&x[i__ + 1 + j * x_dim1]), ABS(
d__14)));
/* L40: */
}
i__2 = *n + j * b_dim1;
i__3 = *n - 1;
i__4 = *n - 1 + j * x_dim1;
i__5 = *n;
i__6 = *n + j * x_dim1;
rwork[*n] = (d__1 = b[i__2].r, ABS(d__1)) + (d__2 = d_imag(&b[
*n + j * b_dim1]), ABS(d__2)) + ((d__3 = du[i__3].r,
ABS(d__3)) + (d__4 = d_imag(&du[*n - 1]), ABS(d__4)))
* ((d__5 = x[i__4].r, ABS(d__5)) + (d__6 = d_imag(&x[*
n - 1 + j * x_dim1]), ABS(d__6))) + ((d__7 = d__[i__5]
.r, ABS(d__7)) + (d__8 = d_imag(&d__[*n]), ABS(d__8)))
* ((d__9 = x[i__6].r, ABS(d__9)) + (d__10 = d_imag(&
x[*n + j * x_dim1]), ABS(d__10)));
}
}
/* Compute componentwise relative backward error from formula */
/* MAX(i) ( ABS(R(i)) / ( ABS(op(A))*ABS(X) + ABS(B) )(i) ) */
/* where ABS(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, ABS(d__1)) + (d__2 =
d_imag(&work[i__]), ABS(d__2))) / rwork[i__];
s = MAX(d__3,d__4);
} else {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, ABS(d__1)) + (d__2 =
d_imag(&work[i__]), ABS(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = MAX(d__3,d__4);
}
/* L50: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
zgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[
1], &work[1], n, info);
zaxpy_(n, &c_b26, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( ABS(inv(op(A)))* */
/* ( ABS(R) + NZ*EPS*( ABS(op(A))*ABS(X)+ABS(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* ABS(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of ABS(R)+NZ*EPS*(ABS(op(A))*ABS(X)+ABS(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* ABS(op(A))*ABS(X) + ABS(B) is less than SAFE2. */
/* Use ZLACN2 to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = ABS(R) + NZ*EPS*( ABS(op(A))*ABS(X)+ABS(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, ABS(d__1)) + (d__2 =
d_imag(&work[i__]), ABS(d__2)) + nz * eps * rwork[i__]
;
} else {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, ABS(d__1)) + (d__2 =
d_imag(&work[i__]), ABS(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
/* L60: */
}
kase = 0;
L70:
zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
zgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
ipiv[1], &work[1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L80: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L90: */
}
zgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
ipiv[1], &work[1], n, info);
}
goto L70;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = x[i__3].r, ABS(d__1)) + (d__2 =
d_imag(&x[i__ + j * x_dim1]), ABS(d__2));
lstres = MAX(d__3,d__4);
/* L100: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L110: */
}
return 0;
/* End of ZGTRFS */
} /* zgtrfs_ */
void test03 ( void )
/******************************************************************************/
/*
Purpose:
TEST03 tests ZAXPY.
Modified:
01 April 2007
Author:
John Burkardt
*/
{
# define N 5
int i;
int inc1;
int inc2;
int ncopy;
doublecomplex s;
doublecomplex x[N] = {
{ 2.0, - 1.0 },
{-4.0, - 2.0 },
{ 3.0, + 1.0 },
{ 2.0, + 2.0 },
{-1.0, - 1.0 }
};
doublecomplex y[N] = {
{-1.0, + 0.0 },
{ 0.0, - 3.0 },
{ 4.0, + 0.0 },
{-3.0, + 4.0 },
{-2.0, + 0.0 }
};
printf ( "\n" );
printf ( "TEST03\n" );
printf ( " ZAXPY adds a multiple of one complex vector to another.\n" );
printf ( "\n" );
printf ( " X =\n" );
printf ( "\n" );
for ( i = 0; i < N; i++ )
{
printf ( " %6d %6f %6f\n", i, x[i].r, x[i].i );
}
printf ( "\n" );
printf ( " Y =\n" );
printf ( "\n" );
for ( i = 0; i < N; i++ )
{
printf ( " %6d %6f %6f\n", i, y[i].r, y[i].i );
}
s.r = 0.50;
s.i = - 1.00;
printf ( "\n" );
printf ( " The scalar multiplier is: %f %f\n", s.r, s.i );
ncopy = N;
inc1 = 1;
inc2 = 1;
zaxpy_ ( &ncopy, &s, x, &inc1, y, &inc2 );
printf ( "\n" );
printf ( " A * X + Y =\n" );
printf ( "\n" );
for ( i = 0; i < N; i++ )
{
printf ( " %6d %6f %6f\n", i, y[i].r, y[i].i );
}
return;
# undef N
}
/* Subroutine */ int zhegs2_(integer *itype, char *uplo, integer *n,
doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
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
=======
ZHEGS2 reduces a complex Hermitian-definite generalized
eigenproblem to standard form.
If ITYPE = 1, the problem is A*x = lambda*B*x,
and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
B must have been previously factorized as U'*U or L*L' by ZPOTRF.
Arguments
=========
ITYPE (input) INTEGER
= 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
= 2 or 3: compute U*A*U' or L'*A*L.
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored, and how B has been factorized.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
n by n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n by n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the transformed matrix, stored in the
same format as A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input) COMPLEX*16 array, dimension (LDB,N)
The triangular factor from the Cholesky factorization of B,
as returned by ZPOTRF.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer k;
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), ztrmv_(
char *, char *, char *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrsv_(char *
, char *, char *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static doublecomplex ct;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
static doublereal akk, bkk;
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= *n; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = A(k,k).r;
i__2 = k + k * b_dim1;
bkk = B(k,k).r;
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = k + k * a_dim1;
A(k,k).r = akk, A(k,k).i = 0.;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &A(k,k+1), lda);
d__1 = akk * -.5;
ct.r = d__1, ct.i = 0.;
i__2 = *n - k;
zlacgv_(&i__2, &A(k,k+1), lda);
i__2 = *n - k;
zlacgv_(&i__2, &B(k,k+1), ldb);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &B(k,k+1), ldb, &A(k,k+1), lda);
i__2 = *n - k;
z__1.r = -1., z__1.i = 0.;
zher2_(uplo, &i__2, &z__1, &A(k,k+1), lda,
&B(k,k+1), ldb, &A(k+1,k+1), lda);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &B(k,k+1), ldb, &A(k,k+1), lda);
i__2 = *n - k;
zlacgv_(&i__2, &B(k,k+1), ldb);
i__2 = *n - k;
ztrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &B(k+1,k+1), ldb, &A(k,k+1), lda);
i__2 = *n - k;
zlacgv_(&i__2, &A(k,k+1), lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= *n; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = A(k,k).r;
i__2 = k + k * b_dim1;
bkk = B(k,k).r;
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = k + k * a_dim1;
A(k,k).r = akk, A(k,k).i = 0.;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &A(k+1,k), &c__1);
d__1 = akk * -.5;
ct.r = d__1, ct.i = 0.;
i__2 = *n - k;
zaxpy_(&i__2, &ct, &B(k+1,k), &c__1, &A(k+1,k), &c__1);
i__2 = *n - k;
z__1.r = -1., z__1.i = 0.;
zher2_(uplo, &i__2, &z__1, &A(k+1,k), &c__1,
&B(k+1,k), &c__1, &A(k+1,k+1), lda);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &B(k+1,k), &c__1, &A(k+1,k), &c__1);
i__2 = *n - k;
ztrsv_(uplo, "No transpose", "Non-unit", &i__2, &B(k+1,k+1), ldb, &A(k+1,k),
&c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= *n; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = A(k,k).r;
i__2 = k + k * b_dim1;
bkk = B(k,k).r;
i__2 = k - 1;
ztrmv_(uplo, "No transpose", "Non-unit", &i__2, &B(1,1),
ldb, &A(1,k), &c__1);
d__1 = akk * .5;
ct.r = d__1, ct.i = 0.;
i__2 = k - 1;
zaxpy_(&i__2, &ct, &B(1,k), &c__1, &A(1,k), &c__1);
i__2 = k - 1;
zher2_(uplo, &i__2, &c_b1, &A(1,k), &c__1, &B(1,k), &c__1, &A(1,1), lda);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &B(1,k), &c__1, &A(1,k), &c__1);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &A(1,k), &c__1);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
A(k,k).r = d__1, A(k,k).i = 0.;
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= *n; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = A(k,k).r;
i__2 = k + k * b_dim1;
bkk = B(k,k).r;
i__2 = k - 1;
zlacgv_(&i__2, &A(k,1), lda);
i__2 = k - 1;
ztrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &B(1,1), ldb, &A(k,1), lda);
d__1 = akk * .5;
ct.r = d__1, ct.i = 0.;
i__2 = k - 1;
zlacgv_(&i__2, &B(k,1), ldb);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &B(k,1), ldb, &A(k,1), lda);
i__2 = k - 1;
zher2_(uplo, &i__2, &c_b1, &A(k,1), lda, &B(k,1)
, ldb, &A(1,1), lda);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &B(k,1), ldb, &A(k,1), lda);
i__2 = k - 1;
zlacgv_(&i__2, &B(k,1), ldb);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &A(k,1), lda);
i__2 = k - 1;
zlacgv_(&i__2, &A(k,1), lda);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
A(k,k).r = d__1, A(k,k).i = 0.;
/* L40: */
}
}
}
return 0;
/* End of ZHEGS2 */
} /* zhegs2_ */
/* Subroutine */ int zlatps_(char *uplo, char *trans, char *diag, char *
normin, integer *n, doublecomplex *ap, doublecomplex *x, doublereal *
scale, doublereal *cnorm, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double d_imag(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, ip;
doublereal xj, rec, tjj;
integer jinc, jlen;
doublereal xbnd;
integer imax;
doublereal tmax;
doublecomplex tjjs;
doublereal xmax, grow;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
doublereal tscal;
doublecomplex uscal;
integer jlast;
doublecomplex csumj;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
logical upper;
extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), ztpsv_(
char *, char *, char *, integer *, doublecomplex *, doublecomplex
*, integer *), dlabad_(doublereal *,
doublereal *);
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
doublereal bignum;
extern integer izamax_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
doublecomplex *);
logical notran;
integer jfirst;
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
doublereal smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATPS solves one of the triangular systems */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
/* with scaling to prevent overflow, where A is an upper or lower */
/* triangular matrix stored in packed form. Here A**T denotes the */
/* transpose of A, A**H denotes the conjugate transpose of A, x and b */
/* are n-element vectors, and s is a scaling factor, usually less than */
/* or equal to 1, chosen so that the components of x will be less than */
/* the overflow threshold. If the unscaled problem will not cause */
/* overflow, the Level 2 BLAS routine ZTPSV is called. If the matrix A */
/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */
/* non-trivial solution to A*x = 0 is returned. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A**T * x = s*b (Transpose) */
/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* The upper or lower triangular matrix A, packed columnwise in */
/* a linear array. The j-th column of A is stored in the array */
/* AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* X (input/output) COMPLEX*16 array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) DOUBLE PRECISION */
/* The scaling factor s for the triangular system */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0. */
/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column */
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column */
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, ZTPSV */
/* is called, otherwise, specific code is used which checks for possible */
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* for j = 1, ..., n */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop: */
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTPSV if the */
/* reciprocal of the largest M(j), j=1,..,n, is larger than */
/* max(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
/* A**H *x = b. The basic algorithm for A upper triangular is */
/* for j = 1, ..., n */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call ZTPSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--cnorm;
--x;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATPS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum /= dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
ip = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = dzasum_(&i__2, &ap[ip], &c__1);
ip += j;
/* L10: */
}
} else {
/* A is lower triangular. */
ip = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = dzasum_(&i__2, &ap[ip + 1], &c__1);
ip = ip + *n - j + 1;
/* L20: */
}
cnorm[*n] = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = idamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5) {
tscal = 1.;
} else {
tscal = .5 / (smlnum * tmax);
dscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine ZTPSV can be used. */
xmax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 =
d_imag(&x[j]) / 2., abs(d__2));
xmax = max(d__3,d__4);
/* L30: */
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.) {
grow = 0.;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{x(i), i=1,...,n}. */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = *n;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
i__3 = ip;
tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
d__1 = xbnd, d__2 = min(1.,tjj) * grow;
xbnd = min(d__1,d__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.;
}
ip += jinc * jlen;
--jlen;
/* L40: */
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (cnorm[j] + 1.);
/* L50: */
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.) {
grow = 0.;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{x(i), i=1,...,n}. */
grow = .5 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = min(d__1,d__2);
i__3 = ip;
tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.;
}
++jlen;
ip += jinc * jlen;
/* L70: */
}
grow = min(grow,xbnd);
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ztpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5 / xmax;
zdscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.;
}
if (notran) {
/* Solve A * x = b */
ip = jfirst * (jfirst + 1) / 2;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
if (nounit) {
i__3 = ip;
z__1.r = tscal * ap[i__3].r, z__1.i = tscal * ap[i__3].i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L110;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
/* L100: */
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L110:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
zdscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &ap[ip - j + 1], &c__1, &x[1], &
c__1);
i__3 = j - 1;
i__ = izamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__2));
}
ip -= j;
} else {
if (j < *n) {
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
zaxpy_(&i__3, &z__1, &ap[ip + 1], &c__1, &x[j + 1], &
c__1);
i__3 = *n - j;
i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
&x[i__]), abs(d__2));
}
ip = ip + *n - j + 1;
}
/* L120: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
i__3 = ip;
z__1.r = tscal * ap[i__3].r, z__1.i = tscal * ap[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
zdotu_(&z__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotu_(&z__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ip - j + i__;
z__3.r = ap[i__4].r * uscal.r - ap[i__4].i *
uscal.i, z__3.i = ap[i__4].r * uscal.i +
ap[i__4].i * uscal.r;
i__5 = i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L130: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ip + i__;
z__3.r = ap[i__4].r * uscal.r - ap[i__4].i *
uscal.i, z__3.i = ap[i__4].r * uscal.i +
ap[i__4].i * uscal.r;
i__5 = j + i__;
z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
z__2.i = z__3.r * x[i__5].i + z__3.i * x[
i__5].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L140: */
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
i__3 = ip;
z__1.r = tscal * ap[i__3].r, z__1.i = tscal * ap[i__3]
.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L160;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
/* L150: */
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L160:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L170: */
}
} else {
/* Solve A**H * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
abs(d__2));
uscal.r = tscal, uscal.i = 0.;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
d_cnjg(&z__2, &ap[ip]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
zladiv_(&z__1, &uscal, &tjjs);
uscal.r = z__1.r, uscal.i = z__1.i;
}
if (rec < 1.) {
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0., csumj.i = 0.;
if (uscal.r == 1. && uscal.i == 0.) {
/* If the scaling needed for A in the dot product is 1, */
/* call ZDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
zdotc_(&z__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
} else if (j < *n) {
i__3 = *n - j;
zdotc_(&z__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
c__1);
csumj.r = z__1.r, csumj.i = z__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d_cnjg(&z__4, &ap[ip - j + i__]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L180: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i__ = 1; i__ <= i__3; ++i__) {
d_cnjg(&z__4, &ap[ip + i__]);
z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
z__3.i = z__4.r * uscal.i + z__4.i *
uscal.r;
i__4 = j + i__;
z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
z__2.i = z__3.r * x[i__4].i + z__3.i * x[
i__4].r;
z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
z__2.i;
csumj.r = z__1.r, csumj.i = z__1.i;
/* L190: */
}
}
}
z__1.r = tscal, z__1.i = 0.;
if (uscal.r == z__1.r && uscal.i == z__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
i__3 = j;
xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
, abs(d__2));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
d_cnjg(&z__2, &ap[ip]);
z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
tjjs.r = z__1.r, tjjs.i = z__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.;
if (tscal == 1.) {
goto L210;
}
}
tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
abs(d__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
zdscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
zladiv_(&z__1, &x[j], &tjjs);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0., x[i__4].i = 0.;
/* L200: */
}
i__3 = j;
x[i__3].r = 1., x[i__3].i = 0.;
*scale = 0.;
xmax = 0.;
}
L210:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
zladiv_(&z__2, &x[j], &tjjs);
z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
}
/* Computing MAX */
i__3 = j;
d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[j]), abs(d__2));
xmax = max(d__3,d__4);
++jlen;
ip += jinc * jlen;
/* L220: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &cnorm[1], &c__1);
}
return 0;
/* End of ZLATPS */
} /* zlatps_ */
/* Subroutine */
int zlatrd_(char *uplo, integer *n, integer *nb, doublecomplex *a, integer *lda, doublereal *e, doublecomplex *tau, doublecomplex *w, integer *ldw)
{
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, iw;
doublecomplex alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int zscal_(integer *, doublecomplex *, doublecomplex *, integer *);
extern /* Double Complex */
VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */
int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zhemv_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *, doublecomplex *, integer *);
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*n <= 0)
{
return 0;
}
if (lsame_(uplo, "U"))
{
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n;
i__ >= i__1;
--i__)
{
iw = i__ - *n + *nb;
if (i__ < *n)
{
/* Update A(1:i,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1;
a[i__2].i = 0.; // , expr subst
i__2 = *n - i__;
zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__, &i__2, &z__1, &a[(i__ + 1) * a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = *n - i__;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__, &i__2, &z__1, &w[(iw + 1) * w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1;
a[i__2].i = 0.; // , expr subst
}
if (i__ > 1)
{
/* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */
i__2 = i__ - 1 + i__ * a_dim1;
alpha.r = a[i__2].r;
alpha.i = a[i__2].i; // , expr subst
i__2 = i__ - 1;
zlarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__ - 1]);
i__2 = i__ - 1;
e[i__2] = alpha.r;
i__2 = i__ - 1 + i__ * a_dim1;
a[i__2].r = 1.;
a[i__2].i = 0.; // , expr subst
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
zhemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ * a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1);
if (i__ < *n)
{
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw + 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], & c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[(i__ + 1) * a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[( i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[(iw + 1) * w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
}
i__2 = i__ - 1;
zscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
z__3.r = -.5;
z__3.i = -0.; // , expr subst
i__2 = i__ - 1;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i;
z__2.i = z__3.r * tau[i__2].i + z__3.i * tau[i__2].r; // , expr subst
i__3 = i__ - 1;
zdotc_f2c_(&z__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i;
z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst
alpha.r = z__1.r;
alpha.i = z__1.i; // , expr subst
i__2 = i__ - 1;
zaxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * w_dim1 + 1], &c__1);
}
/* L10: */
}
}
else
{
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Update A(i:n,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1;
a[i__2].i = 0.; // , expr subst
i__2 = i__ - 1;
zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda, &w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], & c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + w_dim1], ldw, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], & c__1);
i__2 = i__ - 1;
zlacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
d__1 = a[i__3].r;
a[i__2].r = d__1;
a[i__2].i = 0.; // , expr subst
if (i__ < *n)
{
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:n,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r;
alpha.i = a[i__2].i; // , expr subst
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
zlarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, &tau[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1.;
a[i__2].i = 0.; // , expr subst
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
zhemv_("Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1] , lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[ i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1 + w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, & c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 + a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + 1 + w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
zscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
z__3.r = -.5;
z__3.i = -0.; // , expr subst
i__2 = i__;
z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i;
z__2.i = z__3.r * tau[i__2].i + z__3.i * tau[i__2].r; // , expr subst
i__3 = *n - i__;
zdotc_f2c_(&z__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[ i__ + 1 + i__ * a_dim1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i;
z__1.i = z__2.r * z__4.i + z__2.i * z__4.r; // , expr subst
alpha.r = z__1.r;
alpha.i = z__1.i; // , expr subst
i__2 = *n - i__;
zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ i__ + 1 + i__ * w_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of ZLATRD */
}
/* Subroutine */ int zla_syrfsx_extended__(integer *prec_type__, char *uplo,
integer *n, integer *nrhs, doublecomplex *a, integer *lda,
doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ,
doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *y,
integer *ldy, doublereal *berr_out__, integer *n_norms__, doublereal *
err_bnds_norm__, doublereal *err_bnds_comp__, doublecomplex *res,
doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail__,
doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *
dz_ub__, logical *ignore_cwise__, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
doublereal dxratmax, dzratmax;
integer i__, j;
logical incr_prec__;
doublereal prev_dz_z__;
extern /* Subroutine */ int zla_syamv__(integer *, integer *, doublereal *
, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, integer *);
doublereal yk, final_dx_x__, final_dz_z__;
extern /* Subroutine */ int zla_wwaddw__(integer *, doublecomplex *,
doublecomplex *, doublecomplex *);
doublereal prevnormdx;
integer cnt;
doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__, ymin;
extern /* Subroutine */ int zla_lin_berr__(integer *, integer *, integer *
, doublecomplex *, doublereal *, doublereal *);
integer y_prec_state__, uplo2;
extern /* Subroutine */ int blas_zsymv_x__(integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
;
extern logical lsame_(char *, char *);
doublereal dxrat, dzrat;
extern /* Subroutine */ int blas_zsymv2_x__(integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
doublereal normx, normy;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zsymv_(
char *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
extern doublereal dlamch_(char *);
doublereal normdx;
extern /* Subroutine */ int zsytrs_(char *, integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
integer *);
doublereal hugeval;
extern integer ilauplo_(char *);
integer x_state__, z_state__;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLA_SYRFSX_EXTENDED improves the computed solution to a system of */
/* linear equations by performing extra-precise iterative refinement */
/* and provides error bounds and backward error estimates for the solution. */
/* This subroutine is called by ZSYRFSX to perform iterative refinement. */
/* In addition to normwise error bound, the code provides maximum */
/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
/* subroutine is only resonsible for setting the second fields of */
/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
/* Arguments */
/* ========= */
/* PREC_TYPE (input) INTEGER */
/* Specifies the intermediate precision to be used in refinement. */
/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
/* P = 'S': Single */
/* = 'D': Double */
/* = 'I': Indigenous */
/* = 'X', 'E': Extra */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right-hand-sides, i.e., the number of columns of the */
/* matrix B. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by ZSYTRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by ZSYTRF. */
/* COLEQU (input) LOGICAL */
/* If .TRUE. then column equilibration was done to A before calling */
/* this routine. This is needed to compute the solution and error */
/* bounds correctly. */
/* C (input) DOUBLE PRECISION array, dimension (N) */
/* The column scale factors for A. If COLEQU = .FALSE., C */
/* is not accessed. If C is input, each element of C should be a power */
/* of the radix to ensure a reliable solution and error estimates. */
/* Scaling by powers of the radix does not cause rounding errors unless */
/* the result underflows or overflows. Rounding errors during scaling */
/* lead to refining with a matrix that is not equivalent to the */
/* input matrix, producing error estimates that may not be */
/* reliable. */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right-hand-side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* Y (input/output) COMPLEX*16 array, dimension */
/* (LDY,NRHS) */
/* On entry, the solution matrix X, as computed by ZSYTRS. */
/* On exit, the improved solution matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= max(1,N). */
/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
/* On exit, BERR_OUT(j) contains the componentwise relative backward */
/* error for right-hand-side j from the formula */
/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. This is computed by ZLA_LIN_BERR. */
/* N_NORMS (input) INTEGER */
/* Determines which error bounds to return (see ERR_BNDS_NORM */
/* and ERR_BNDS_COMP). */
/* If N_NORMS >= 1 return normwise error bounds. */
/* If N_NORMS >= 2 return componentwise error bounds. */
/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
/* (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* This subroutine is only responsible for setting the second field */
/* above. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
/* (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* This subroutine is only responsible for setting the second field */
/* above. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* RES (input) COMPLEX*16 array, dimension (N) */
/* Workspace to hold the intermediate residual. */
/* AYB (input) DOUBLE PRECISION array, dimension (N) */
/* Workspace. */
/* DY (input) COMPLEX*16 array, dimension (N) */
/* Workspace to hold the intermediate solution. */
/* Y_TAIL (input) COMPLEX*16 array, dimension (N) */
/* Workspace to hold the trailing bits of the intermediate solution. */
/* RCOND (input) DOUBLE PRECISION */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* ITHRESH (input) INTEGER */
/* The maximum number of residual computations allowed for */
/* refinement. The default is 10. For 'aggressive' set to 100 to */
/* permit convergence using approximate factorizations or */
/* factorizations other than LU. If the factorization uses a */
/* technique other than Gaussian elimination, the guarantees in */
/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
/* RTHRESH (input) DOUBLE PRECISION */
/* Determines when to stop refinement if the error estimate stops */
/* decreasing. Refinement will stop when the next solution no longer */
/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
/* for more details. */
/* DZ_UB (input) DOUBLE PRECISION */
/* Determines when to start considering componentwise convergence. */
/* Componentwise convergence is only considered after each component */
/* of the solution Y is stable, which we definte as the relative */
/* change in each component being less than DZ_UB. The default value */
/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
/* more details. */
/* IGNORE_CWISE (input) LOGICAL */
/* If .TRUE. then ignore componentwise convergence. Default value */
/* is .FALSE.. */
/* INFO (output) INTEGER */
/* = 0: Successful exit. */
/* < 0: if INFO = -i, the ith argument to ZSYTRS had an illegal */
/* value */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function Definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
--berr_out__;
--res;
--ayb;
--dy;
--y_tail__;
/* Function Body */
if (*info != 0) {
return 0;
}
eps = dlamch_("Epsilon");
hugeval = dlamch_("Overflow");
/* Force HUGEVAL to Inf */
hugeval *= hugeval;
/* Using HUGEVAL may lead to spurious underflows. */
incr_thresh__ = (doublereal) (*n) * eps;
if (lsame_(uplo, "L")) {
uplo2 = ilauplo_("L");
} else {
uplo2 = ilauplo_("U");
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
y_prec_state__ = 1;
if (y_prec_state__ == 2) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.;
}
}
dxrat = 0.;
dxratmax = 0.;
dzrat = 0.;
dzratmax = 0.;
final_dx_x__ = hugeval;
final_dz_z__ = hugeval;
prevnormdx = hugeval;
prev_dz_z__ = hugeval;
dz_z__ = hugeval;
dx_x__ = hugeval;
x_state__ = 1;
z_state__ = 0;
incr_prec__ = FALSE_;
i__2 = *ithresh;
for (cnt = 1; cnt <= i__2; ++cnt) {
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
if (y_prec_state__ == 0) {
zsymv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
&c__1, &c_b12, &res[1], &c__1);
} else if (y_prec_state__ == 1) {
blas_zsymv_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1,
prec_type__);
} else {
blas_zsymv2_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
y_dim1 + 1], &y_tail__[1], &c__1, &c_b12, &res[1], &
c__1, prec_type__);
}
/* XXX: RES is no longer needed. */
zcopy_(n, &res[1], &c__1, &dy[1], &c__1);
zsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &dy[1], n,
info);
/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
normx = 0.;
normy = 0.;
normdx = 0.;
dz_z__ = 0.;
ymin = hugeval;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * y_dim1;
yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ +
j * y_dim1]), abs(d__2));
i__4 = i__;
dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__]
), abs(d__2));
if (yk != 0.) {
/* Computing MAX */
d__1 = dz_z__, d__2 = dyk / yk;
dz_z__ = max(d__1,d__2);
} else if (dyk != 0.) {
dz_z__ = hugeval;
}
ymin = min(ymin,yk);
normy = max(normy,yk);
if (*colequ) {
/* Computing MAX */
d__1 = normx, d__2 = yk * c__[i__];
normx = max(d__1,d__2);
/* Computing MAX */
d__1 = normdx, d__2 = dyk * c__[i__];
normdx = max(d__1,d__2);
} else {
normx = normy;
normdx = max(normdx,dyk);
}
}
if (normx != 0.) {
dx_x__ = normdx / normx;
} else if (normdx == 0.) {
dx_x__ = 0.;
} else {
dx_x__ = hugeval;
}
dxrat = normdx / prevnormdx;
dzrat = dz_z__ / prev_dz_z__;
/* Check termination criteria. */
if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
incr_prec__ = TRUE_;
}
if (x_state__ == 3 && dxrat <= *rthresh) {
x_state__ = 1;
}
if (x_state__ == 1) {
if (dx_x__ <= eps) {
x_state__ = 2;
} else if (dxrat > *rthresh) {
if (y_prec_state__ != 2) {
incr_prec__ = TRUE_;
} else {
x_state__ = 3;
}
} else {
if (dxrat > dxratmax) {
dxratmax = dxrat;
}
}
if (x_state__ > 1) {
final_dx_x__ = dx_x__;
}
}
if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
z_state__ = 1;
}
if (z_state__ == 3 && dzrat <= *rthresh) {
z_state__ = 1;
}
if (z_state__ == 1) {
if (dz_z__ <= eps) {
z_state__ = 2;
} else if (dz_z__ > *dz_ub__) {
z_state__ = 0;
dzratmax = 0.;
final_dz_z__ = hugeval;
} else if (dzrat > *rthresh) {
if (y_prec_state__ != 2) {
incr_prec__ = TRUE_;
} else {
z_state__ = 3;
}
} else {
if (dzrat > dzratmax) {
dzratmax = dzrat;
}
}
if (z_state__ > 1) {
final_dz_z__ = dz_z__;
}
}
if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
goto L666;
}
if (incr_prec__) {
incr_prec__ = FALSE_;
++y_prec_state__;
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.;
}
}
prevnormdx = normdx;
prev_dz_z__ = dz_z__;
/* Update soluton. */
if (y_prec_state__ < 2) {
zaxpy_(n, &c_b12, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
} else {
zla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
}
}
/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
L666:
/* Set final_* when cnt hits ithresh. */
if (x_state__ == 1) {
final_dx_x__ = dx_x__;
}
if (z_state__ == 1) {
final_dz_z__ = dz_z__;
}
/* Compute error bounds. */
if (*n_norms__ >= 1) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
1 - dxratmax);
}
if (*n_norms__ >= 2) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
1 - dzratmax);
}
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. */
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
zsymv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1,
&c_b12, &res[1], &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__
+ j * b_dim1]), abs(d__2));
}
/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
zla_syamv__(&uplo2, n, &c_b33, &a[a_offset], lda, &y[j * y_dim1 + 1],
&c__1, &c_b33, &ayb[1], &c__1);
zla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
/* End of loop for each RHS. */
}
return 0;
} /* zla_syrfsx_extended__ */
/* Subroutine */ int zlapll_(integer *n, doublecomplex *x, integer *incx,
doublecomplex *y, integer *incy, doublereal *ssmin)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
/* Local variables */
static doublecomplex c__, a11, a12, a22, tau;
extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal ssmax;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Given two column vectors X and Y, let */
/* A = ( X Y ). */
/* The subroutine first computes the QR factorization of A = Q*R, */
/* and then computes the SVD of the 2-by-2 upper triangular matrix R. */
/* The smaller singular value of R is returned in SSMIN, which is used */
/* as the measurement of the linear dependency of the vectors X and Y. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The length of the vectors X and Y. */
/* X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX) */
/* On entry, X contains the N-vector X. */
/* On exit, X is overwritten. */
/* INCX (input) INTEGER */
/* The increment between successive elements of X. INCX > 0. */
/* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY) */
/* On entry, Y contains the N-vector Y. */
/* On exit, Y is overwritten. */
/* INCY (input) INTEGER */
/* The increment between successive elements of Y. INCY > 0. */
/* SSMIN (output) DOUBLE PRECISION */
/* The smallest singular value of the N-by-2 matrix A = ( X Y ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--y;
--x;
/* Function Body */
if (*n <= 1) {
*ssmin = 0.;
return 0;
}
/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */
zlarfg_(n, &x[1], &x[*incx + 1], incx, &tau);
a11.r = x[1].r, a11.i = x[1].i;
x[1].r = 1., x[1].i = 0.;
d_cnjg(&z__3, &tau);
z__2.r = -z__3.r, z__2.i = -z__3.i;
zdotc_(&z__4, n, &x[1], incx, &y[1], incy);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i +
z__2.i * z__4.r;
c__.r = z__1.r, c__.i = z__1.i;
zaxpy_(n, &c__, &x[1], incx, &y[1], incy);
i__1 = *n - 1;
zlarfg_(&i__1, &y[*incy + 1], &y[(*incy << 1) + 1], incy, &tau);
a12.r = y[1].r, a12.i = y[1].i;
i__1 = *incy + 1;
a22.r = y[i__1].r, a22.i = y[i__1].i;
/* Compute the SVD of 2-by-2 Upper triangular matrix. */
d__1 = z_abs(&a11);
d__2 = z_abs(&a12);
d__3 = z_abs(&a22);
dlas2_(&d__1, &d__2, &d__3, ssmin, &ssmax);
return 0;
/* End of ZLAPLL */
} /* zlapll_ */
/* Subroutine */ int zlatzm_(char *side, integer *m, integer *n,
doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
c1, doublecomplex *c2, integer *ldc, doublecomplex *work, ftnlen
side_len)
{
/* System generated locals */
integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
doublecomplex z__1;
/* Local variables */
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen),
zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
, zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), zlacgv_(integer *,
doublecomplex *, integer *);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine ZUNMRZ. */
/* ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix. */
/* Let P = I - tau*u*u', u = ( 1 ), */
/* ( v ) */
/* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */
/* SIDE = 'R'. */
/* If SIDE equals 'L', let */
/* C = [ C1 ] 1 */
/* [ C2 ] m-1 */
/* n */
/* Then C is overwritten by P*C. */
/* If SIDE equals 'R', let */
/* C = [ C1, C2 ] m */
/* 1 n-1 */
/* Then C is overwritten by C*P. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': form P * C */
/* = 'R': form C * P */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* V (input) COMPLEX*16 array, dimension */
/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
/* (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
/* The vector v in the representation of P. V is not used */
/* if TAU = 0. */
/* INCV (input) INTEGER */
/* The increment between elements of v. INCV <> 0 */
/* TAU (input) COMPLEX*16 */
/* The value tau in the representation of P. */
/* C1 (input/output) COMPLEX*16 array, dimension */
/* (LDC,N) if SIDE = 'L' */
/* (M,1) if SIDE = 'R' */
/* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */
/* if SIDE = 'R'. */
/* On exit, the first row of P*C if SIDE = 'L', or the first */
/* column of C*P if SIDE = 'R'. */
/* C2 (input/output) COMPLEX*16 array, dimension */
/* (LDC, N) if SIDE = 'L' */
/* (LDC, N-1) if SIDE = 'R' */
/* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */
/* m x (n - 1) matrix C2 if SIDE = 'R'. */
/* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */
/* if SIDE = 'R'. */
/* LDC (input) INTEGER */
/* The leading dimension of the arrays C1 and C2. */
/* LDC >= max(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (N) if SIDE = 'L' */
/* (M) if SIDE = 'R' */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c2_dim1 = *ldc;
c2_offset = 1 + c2_dim1;
c2 -= c2_offset;
c1_dim1 = *ldc;
c1_offset = 1 + c1_dim1;
c1 -= c1_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0 || tau->r == 0. && tau->i == 0.) {
return 0;
}
if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
/* w := conjg( C1 + v' * C2 ) */
zcopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
zlacgv_(n, &work[1], &c__1);
i__1 = *m - 1;
zgemv_("Conjugate transpose", &i__1, n, &c_b1, &c2[c2_offset], ldc, &
v[1], incv, &c_b1, &work[1], &c__1, (ftnlen)19);
/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w' */
/* [ C2 ] [ C2 ] [ v ] */
zlacgv_(n, &work[1], &c__1);
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(n, &z__1, &work[1], &c__1, &c1[c1_offset], ldc);
i__1 = *m - 1;
z__1.r = -tau->r, z__1.i = -tau->i;
zgeru_(&i__1, n, &z__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset],
ldc);
} else if (lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
/* w := C1 + C2 * v */
zcopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
i__1 = *n - 1;
zgemv_("No transpose", m, &i__1, &c_b1, &c2[c2_offset], ldc, &v[1],
incv, &c_b1, &work[1], &c__1, (ftnlen)12);
/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(m, &z__1, &work[1], &c__1, &c1[c1_offset], &c__1);
i__1 = *n - 1;
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, &i__1, &z__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset],
ldc);
}
return 0;
/* End of ZLATZM */
} /* zlatzm_ */
/* Subroutine */ int zherfs_(char *uplo, integer *n, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,
doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, k;
doublereal s, xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3], count;
extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
integer *, doublecomplex *, doublecomplex *, doublereal *,
integer *, integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal lstres;
extern /* Subroutine */ int zhetrs_(char *, integer *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHERFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is Hermitian indefinite, and */
/* provides error bounds and backward error estimates for the solution. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of A contains the upper triangular part */
/* of the matrix A, and the strictly lower triangular part of A */
/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
/* triangular part of A contains the lower triangular part of */
/* the matrix A, and the strictly upper triangular part of A is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
/* The factored form of the matrix A. AF contains the block */
/* diagonal matrix D and the multipliers used to obtain the */
/* factor U or L from the factorization A = U*D*U**H or */
/* A = L*D*L**H as computed by ZHETRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by ZHETRF. */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by ZHETRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHERFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
z__1.r = -1., z__1.i = -0.;
zhemv_(uplo, n, &z__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &
c_b1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
i__ + j * b_dim1]), abs(d__2));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
.r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
x_dim1]), abs(d__4)));
/* L40: */
}
i__3 = k + k * a_dim1;
rwork[k] = rwork[k] + (d__1 = a[i__3].r, abs(d__1)) * xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
i__3 = k + k * a_dim1;
rwork[k] += (d__1 = a[i__3].r, abs(d__1)) * xk;
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
.r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
x_dim1]), abs(d__4)));
/* L60: */
}
rwork[k] += s;
/* L70: */
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2))) / rwork[i__];
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__3 = i__;
d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = max(d__3,d__4);
}
/* L80: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
zhetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
n, info);
zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(A))* */
/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of A */
/* abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
/* Use ZLACN2 to estimate the infinity-norm of the matrix */
/* inv(A) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
;
} else {
i__3 = i__;
rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
/* L90: */
}
kase = 0;
L100:
zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
zhetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(A)*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L120: */
}
zhetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
d_imag(&x[i__ + j * x_dim1]), abs(d__2));
lstres = max(d__3,d__4);
/* L130: */
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of ZHERFS */
} /* zherfs_ */
doublereal zqpt01_(integer *m, integer *n, integer *k, doublecomplex *a,
doublecomplex *af, integer *lda, doublecomplex *tau, integer *jpvt,
doublecomplex *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
doublereal ret_val;
/* Local variables */
integer i__, j, info;
doublereal norma, rwork[1];
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZQPT01 tests the QR-factorization with pivoting of a matrix A. The */
/* array AF contains the (possibly partial) QR-factorization of A, where */
/* the upper triangle of AF(1:k,1:k) is a partial triangular factor, */
/* the entries below the diagonal in the first k columns are the */
/* Householder vectors, and the rest of AF contains a partially updated */
/* matrix. */
/* This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrices A and AF. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and AF. */
/* K (input) INTEGER */
/* The number of columns of AF that have been reduced */
/* to upper triangular form. */
/* A (input) COMPLEX*16 array, dimension (LDA, N) */
/* The original matrix A. */
/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
/* The (possibly partial) output of ZGEQPF. The upper triangle */
/* of AF(1:k,1:k) is a partial triangular factor, the entries */
/* below the diagonal in the first k columns are the Householder */
/* vectors, and the rest of AF contains a partially updated */
/* matrix. */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A and AF. */
/* TAU (input) COMPLEX*16 array, dimension (K) */
/* Details of the Householder transformations as returned by */
/* ZGEQPF. */
/* JPVT (input) INTEGER array, dimension (N) */
/* Pivot information as returned by ZGEQPF. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= M*N+N. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--jpvt;
--work;
/* Function Body */
ret_val = 0.;
/* Test if there is enough workspace */
if (*lwork < *m * *n + *n) {
this_xerbla_("ZQPT01", &c__10);
return ret_val;
}
/* Quick return if possible */
if (*m <= 0 || *n <= 0) {
return ret_val;
}
norma = zlange_("One-norm", m, n, &a[a_offset], lda, rwork);
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = (j - 1) * *m + i__;
i__4 = i__ + j * af_dim1;
work[i__3].r = af[i__4].r, work[i__3].i = af[i__4].i;
/* L10: */
}
i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = (j - 1) * *m + i__;
work[i__3].r = 0., work[i__3].i = 0.;
/* L20: */
}
/* L30: */
}
i__1 = *n;
for (j = *k + 1; j <= i__1; ++j) {
zcopy_(m, &af[j * af_dim1 + 1], &c__1, &work[(j - 1) * *m + 1], &c__1)
;
/* L40: */
}
i__1 = *lwork - *m * *n;
zunmqr_("Left", "No transpose", m, n, k, &af[af_offset], lda, &tau[1], &
work[1], m, &work[*m * *n + 1], &i__1, &info);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compare i-th column of QR and jpvt(i)-th column of A */
zaxpy_(m, &c_b16, &a[jpvt[j] * a_dim1 + 1], &c__1, &work[(j - 1) * *m
+ 1], &c__1);
/* L50: */
}
ret_val = zlange_("One-norm", m, n, &work[1], m, rwork) / ((
doublereal) max(*m,*n) * dlamch_("Epsilon"));
if (norma != 0.) {
ret_val /= norma;
}
return ret_val;
/* End of ZQPT01 */
} /* zqpt01_ */
/* Subroutine */ int zgbrfs_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *
afb, integer *ldafb, integer *ipiv, doublecomplex *b, integer *ldb,
doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
doublecomplex *work, doublereal *rwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1;
/* Local variables */
integer i__, j, k;
doublereal s;
integer kk;
doublereal xk;
integer nz;
doublereal eps;
integer kase;
doublereal safe1, safe2;
integer isave[3];
integer count;
doublereal safmin;
logical notran;
char transn[1], transt[1];
doublereal lstres;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
/* Purpose */
/* ======= */
/* ZGBRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is banded, and provides */
/* error bounds and backward error estimates for the solution. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
/* The original band matrix A, stored in rows 1 to KL+KU+1. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
/* AFB (input) COMPLEX*16 array, dimension (LDAFB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by ZGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* LDAFB (input) INTEGER */
/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from ZGBTRF; for 1<=i<=N, row i of the */
/* matrix was interchanged with row IPIV(i). */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by ZGBTRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
afb_dim1 = *ldafb;
afb_offset = 1 + afb_dim1;
afb -= afb_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldab < *kl + *ku + 1) {
*info = -7;
} else if (*ldafb < (*kl << 1) + *ku + 1) {
*info = -9;
} else if (*ldb < max(1,*n)) {
*info = -12;
} else if (*ldx < max(1,*n)) {
*info = -14;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZGBRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.;
berr[j] = 0.;
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
/* Computing MIN */
i__1 = *kl + *ku + 2, i__2 = *n + 1;
nz = min(i__1,i__2);
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A, A**T, or A**H, depending on TRANS. */
zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
z__1.r = -1., z__1.i = -0.;
zgbmv_(trans, n, n, kl, ku, &z__1, &ab[ab_offset], ldab, &x[j *
x_dim1 + 1], &c__1, &c_b1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
i__ + j * b_dim1]), abs(d__2));
}
/* Compute abs(op(A))*abs(X) + abs(B). */
if (notran) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
kk = *ku + 1 - k;
i__3 = k + j * x_dim1;
xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
x_dim1]), abs(d__2));
/* Computing MAX */
i__3 = 1, i__4 = k - *ku;
/* Computing MIN */
i__6 = *n, i__7 = k + *kl;
i__5 = min(i__6,i__7);
for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
i__3 = kk + i__ + k * ab_dim1;
rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
d_imag(&ab[kk + i__ + k * ab_dim1]), abs(d__2))) *
xk;
}
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.;
kk = *ku + 1 - k;
/* Computing MAX */
i__5 = 1, i__3 = k - *ku;
/* Computing MIN */
i__6 = *n, i__7 = k + *kl;
i__4 = min(i__6,i__7);
for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
i__5 = kk + i__ + k * ab_dim1;
i__3 = i__ + j * x_dim1;
s += ((d__1 = ab[i__5].r, abs(d__1)) + (d__2 = d_imag(&ab[
kk + i__ + k * ab_dim1]), abs(d__2))) * ((d__3 =
x[i__3].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j
* x_dim1]), abs(d__4)));
}
rwork[k] += s;
}
}
s = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__4 = i__;
d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2))) / rwork[i__];
s = max(d__3,d__4);
} else {
/* Computing MAX */
i__4 = i__;
d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ safe1);
s = max(d__3,d__4);
}
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
/* Update solution and try again. */
zgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
, &work[1], n, info);
zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(op(A)))* */
/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
/* Use ZLACN2 to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__4 = i__;
rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
;
} else {
i__4 = i__;
rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 =
d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ safe1;
}
}
kase = 0;
L100:
zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
zgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
ipiv[1], &work[1], n, info);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__4 = i__;
i__5 = i__;
i__3 = i__;
z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5]
* work[i__3].i;
work[i__4].r = z__1.r, work[i__4].i = z__1.i;
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__4 = i__;
i__5 = i__;
i__3 = i__;
z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5]
* work[i__3].i;
work[i__4].r = z__1.r, work[i__4].i = z__1.i;
}
zgbtrs_(transn, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
ipiv[1], &work[1], n, info);
}
goto L100;
}
/* Normalize error. */
lstres = 0.;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__4 = i__ + j * x_dim1;
d__3 = lstres, d__4 = (d__1 = x[i__4].r, abs(d__1)) + (d__2 =
d_imag(&x[i__ + j * x_dim1]), abs(d__2));
lstres = max(d__3,d__4);
}
if (lstres != 0.) {
ferr[j] /= lstres;
}
}
return 0;
/* End of ZGBRFS */
} /* zgbrfs_ */
/* Subroutine */ int zhegs2_(integer *itype, char *uplo, integer *n,
doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
integer k;
doublecomplex ct;
doublereal akk, bkk;
extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern logical lsame_(char *, char *);
logical upper;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), ztrmv_(
char *, char *, char *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), ztrsv_(char *
, char *, char *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), xerbla_(char
*, integer *), zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zlacgv_(integer *, doublecomplex *,
integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHEGS2 reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
/* B must have been previously factorized as U'*U or L*L' by ZPOTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
/* = 2 or 3: compute U*A*U' or L'*A*L. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored, and how B has been factorized. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) COMPLEX*16 array, dimension (LDB,N) */
/* The triangular factor from the Cholesky factorization of B, */
/* as returned by ZPOTRF. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda);
d__1 = akk * -.5;
ct.r = d__1, ct.i = 0.;
i__2 = *n - k;
zlacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
i__2 = *n - k;
zlacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
z__1.r = -1., z__1.i = -0.;
zher2_(uplo, &i__2, &z__1, &a[k + (k + 1) * a_dim1], lda,
&b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
zlacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
ztrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
k + 1 + (k + 1) * b_dim1], ldb, &a[k + (k + 1) *
a_dim1], lda);
i__2 = *n - k;
zlacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.;
if (k < *n) {
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1);
d__1 = akk * -.5;
ct.r = d__1, ct.i = 0.;
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
z__1.r = -1., z__1.i = -0.;
zher2_(uplo, &i__2, &z__1, &a[k + 1 + k * a_dim1], &c__1,
&b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
ztrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
&c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
ztrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k * a_dim1 + 1], &c__1);
d__1 = akk * .5;
ct.r = d__1, ct.i = 0.;
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
zher2_(uplo, &i__2, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[k *
b_dim1 + 1], &c__1, &a[a_offset], lda);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
a[i__2].r = d__1, a[i__2].i = 0.;
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
zlacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k - 1;
ztrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
b_offset], ldb, &a[k + a_dim1], lda);
d__1 = akk * .5;
ct.r = d__1, ct.i = 0.;
i__2 = k - 1;
zlacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
zher2_(uplo, &i__2, &c_b1, &a[k + a_dim1], lda, &b[k + b_dim1]
, ldb, &a[a_offset], lda);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
zlacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &a[k + a_dim1], lda);
i__2 = k - 1;
zlacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
a[i__2].r = d__1, a[i__2].i = 0.;
/* L40: */
}
}
}
return 0;
/* End of ZHEGS2 */
} /* zhegs2_ */
/* Subroutine */ int zlatdf_(integer *ijob, integer *n, doublecomplex *z__,
integer *ldz, doublecomplex *rhs, doublereal *rdsum, doublereal *
rdscal, integer *ipiv, integer *jpiv)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
double z_abs(doublecomplex *);
void z_sqrt(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, k;
doublecomplex bm, bp, xm[2], xp[2];
integer info;
doublecomplex temp, work[8];
doublereal scale;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
doublecomplex pmone;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal rtemp, sminu, rwork[2];
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
doublereal splus;
extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *), zgesc2_(
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *, doublereal *), zgecon_(char *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *);
extern doublereal dzasum_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zlaswp_(integer *, doublecomplex *,
integer *, integer *, integer *, integer *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATDF computes the contribution to the reciprocal Dif-estimate */
/* by solving for x in Z * x = b, where b is chosen such that the norm */
/* of x is as large as possible. It is assumed that LU decomposition */
/* of Z has been computed by ZGETC2. On entry RHS = f holds the */
/* contribution from earlier solved sub-systems, and on return RHS = x. */
/* The factorization of Z returned by ZGETC2 has the form */
/* Z = P * L * U * Q, where P and Q are permutation matrices. L is lower */
/* triangular with unit diagonal elements and U is upper triangular. */
/* Arguments */
/* ========= */
/* IJOB (input) INTEGER */
/* IJOB = 2: First compute an approximative null-vector e */
/* of Z using ZGECON, e is normalized and solve for */
/* Zx = +-e - f with the sign giving the greater value of */
/* 2-norm(x). About 5 times as expensive as Default. */
/* IJOB .ne. 2: Local look ahead strategy where */
/* all entries of the r.h.s. b is choosen as either +1 or */
/* -1. Default. */
/* N (input) INTEGER */
/* The number of columns of the matrix Z. */
/* Z (input) DOUBLE PRECISION array, dimension (LDZ, N) */
/* On entry, the LU part of the factorization of the n-by-n */
/* matrix Z computed by ZGETC2: Z = P * L * U * Q */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDA >= max(1, N). */
/* RHS (input/output) DOUBLE PRECISION array, dimension (N). */
/* On entry, RHS contains contributions from other subsystems. */
/* On exit, RHS contains the solution of the subsystem with */
/* entries according to the value of IJOB (see above). */
/* RDSUM (input/output) DOUBLE PRECISION */
/* On entry, the sum of squares of computed contributions to */
/* the Dif-estimate under computation by ZTGSYL, where the */
/* scaling factor RDSCAL (see below) has been factored out. */
/* On exit, the corresponding sum of squares updated with the */
/* contributions from the current sub-system. */
/* If TRANS = 'T' RDSUM is not touched. */
/* NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL. */
/* RDSCAL (input/output) DOUBLE PRECISION */
/* On entry, scaling factor used to prevent overflow in RDSUM. */
/* On exit, RDSCAL is updated w.r.t. the current contributions */
/* in RDSUM. */
/* If TRANS = 'T', RDSCAL is not touched. */
/* NOTE: RDSCAL only makes sense when ZTGSY2 is called by */
/* ZTGSYL. */
/* IPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* This routine is a further developed implementation of algorithm */
/* BSOLVE in [1] using complete pivoting in the LU factorization. */
/* [1] Bo Kagstrom and Lars Westin, */
/* Generalized Schur Methods with Condition Estimators for */
/* Solving the Generalized Sylvester Equation, IEEE Transactions */
/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */
/* [2] Peter Poromaa, */
/* On Efficient and Robust Estimators for the Separation */
/* between two Regular Matrix Pairs with Applications in */
/* Condition Estimation. Report UMINF-95.05, Department of */
/* Computing Science, Umea University, S-901 87 Umea, Sweden, */
/* 1995. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
if (*ijob != 2) {
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L-part choosing RHS either to +1 or -1. */
z__1.r = -1., z__1.i = -0.;
pmone.r = z__1.r, pmone.i = z__1.i;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
bp.r = z__1.r, bp.i = z__1.i;
i__2 = j;
z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
bm.r = z__1.r, bm.i = z__1.i;
splus = 1.;
/* Lockahead for L- part RHS(1:N-1) = +-1 */
/* SPLUS and SMIN computed more efficiently than in BSOLVE[1]. */
i__2 = *n - j;
zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1
+ j * z_dim1], &c__1);
splus += z__1.r;
i__2 = *n - j;
zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
sminu = z__1.r;
i__2 = j;
splus *= rhs[i__2].r;
if (splus > sminu) {
i__2 = j;
rhs[i__2].r = bp.r, rhs[i__2].i = bp.i;
} else if (sminu > splus) {
i__2 = j;
rhs[i__2].r = bm.r, rhs[i__2].i = bm.i;
} else {
/* In this case the updating sums are equal and we can */
/* choose RHS(J) +1 or -1. The first time this happens we */
/* choose -1, thereafter +1. This is a simple way to get */
/* good estimates of matrices like Byers well-known example */
/* (see [1]). (Not done in BSOLVE.) */
i__2 = j;
i__3 = j;
z__1.r = rhs[i__3].r + pmone.r, z__1.i = rhs[i__3].i +
pmone.i;
rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
pmone.r = 1., pmone.i = 0.;
}
/* Compute the remaining r.h.s. */
i__2 = j;
z__1.r = -rhs[i__2].r, z__1.i = -rhs[i__2].i;
temp.r = z__1.r, temp.i = z__1.i;
i__2 = *n - j;
zaxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
&c__1);
/* L10: */
}
/* Solve for U- part, lockahead for RHS(N) = +-1. This is not done */
/* In BSOLVE and will hopefully give us a better estimate because */
/* any ill-conditioning of the original matrix is transfered to U */
/* and not to L. U(N, N) is an approximation to sigma_min(LU). */
i__1 = *n - 1;
zcopy_(&i__1, &rhs[1], &c__1, work, &c__1);
i__1 = *n - 1;
i__2 = *n;
z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n;
i__2 = *n;
z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
splus = 0.;
sminu = 0.;
for (i__ = *n; i__ >= 1; --i__) {
z_div(&z__1, &c_b1, &z__[i__ + i__ * z_dim1]);
temp.r = z__1.r, temp.i = z__1.i;
i__1 = i__ - 1;
i__2 = i__ - 1;
z__1.r = work[i__2].r * temp.r - work[i__2].i * temp.i, z__1.i =
work[i__2].r * temp.i + work[i__2].i * temp.r;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = i__;
i__2 = i__;
z__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, z__1.i =
rhs[i__2].r * temp.i + rhs[i__2].i * temp.r;
rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
i__1 = *n;
for (k = i__ + 1; k <= i__1; ++k) {
i__2 = i__ - 1;
i__3 = i__ - 1;
i__4 = k - 1;
i__5 = i__ + k * z_dim1;
z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
z__[i__5].r * temp.i + z__[i__5].i * temp.r;
z__2.r = work[i__4].r * z__3.r - work[i__4].i * z__3.i,
z__2.i = work[i__4].r * z__3.i + work[i__4].i *
z__3.r;
z__1.r = work[i__3].r - z__2.r, z__1.i = work[i__3].i -
z__2.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = i__;
i__3 = i__;
i__4 = k;
i__5 = i__ + k * z_dim1;
z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
z__[i__5].r * temp.i + z__[i__5].i * temp.r;
z__2.r = rhs[i__4].r * z__3.r - rhs[i__4].i * z__3.i, z__2.i =
rhs[i__4].r * z__3.i + rhs[i__4].i * z__3.r;
z__1.r = rhs[i__3].r - z__2.r, z__1.i = rhs[i__3].i - z__2.i;
rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
/* L20: */
}
splus += z_abs(&work[i__ - 1]);
sminu += z_abs(&rhs[i__]);
/* L30: */
}
if (splus > sminu) {
zcopy_(n, work, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
i__1 = *n - 1;
zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
return 0;
}
/* ENTRY IJOB = 2 */
/* Compute approximate nullvector XM of Z */
zgecon_("I", n, &z__[z_offset], ldz, &c_b24, &rtemp, work, rwork, &info);
zcopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
i__1 = *n - 1;
zlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
zdotc_(&z__3, n, xm, &c__1, xm, &c__1);
z_sqrt(&z__2, &z__3);
z_div(&z__1, &c_b1, &z__2);
temp.r = z__1.r, temp.i = z__1.i;
zscal_(n, &temp, xm, &c__1);
zcopy_(n, xm, &c__1, xp, &c__1);
zaxpy_(n, &c_b1, &rhs[1], &c__1, xp, &c__1);
z__1.r = -1., z__1.i = -0.;
zaxpy_(n, &z__1, xm, &c__1, &rhs[1], &c__1);
zgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &scale);
zgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &scale);
if (dzasum_(n, xp, &c__1) > dzasum_(n, &rhs[1], &c__1)) {
zcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
return 0;
/* End of ZLATDF */
} /* zlatdf_ */
/* Subroutine */
int zhpgst_(integer *itype, char *uplo, integer *n, doublecomplex *ap, doublecomplex *bp, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
integer j, k, j1, k1, jj, kk;
doublecomplex ct;
doublereal ajj;
integer j1j1;
doublereal akk;
integer k1k1;
doublereal bjj, bkk;
extern /* Subroutine */
int zhpr2_(char *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *);
extern logical lsame_(char *, char *);
extern /* Double Complex */
VOID zdotc_f2c_(doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */
int zhpmv_(char *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex * , doublecomplex *, integer *), xerbla_( char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--bp;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3)
{
*info = -1;
}
else if (! upper && ! lsame_(uplo, "L"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHPGST", &i__1);
return 0;
}
if (*itype == 1)
{
if (upper)
{
/* Compute inv(U**H)*A*inv(U) */
/* J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
i__2 = jj;
i__3 = jj;
d__1 = ap[i__3].r;
ap[i__2].r = d__1;
ap[i__2].i = 0.; // , expr subst
i__2 = jj;
bjj = bp[i__2].r;
ztpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], & ap[j1], &c__1);
i__2 = j - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpmv_(uplo, &i__2, &z__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[ j1], &c__1);
i__2 = j - 1;
d__1 = 1. / bjj;
zdscal_(&i__2, &d__1, &ap[j1], &c__1);
i__2 = jj;
i__3 = jj;
i__4 = j - 1;
zdotc_f2c_(&z__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
z__2.r = ap[i__3].r - z__3.r;
z__2.i = ap[i__3].i - z__3.i; // , expr subst
z__1.r = z__2.r / bjj;
z__1.i = z__2.i / bjj; // , expr subst
ap[i__2].r = z__1.r;
ap[i__2].i = z__1.i; // , expr subst
/* L10: */
}
}
else
{
/* Compute inv(L)*A*inv(L**H) */
/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
/* Computing 2nd power */
d__1 = bkk;
akk /= d__1 * d__1;
i__2 = kk;
ap[i__2].r = akk;
ap[i__2].i = 0.; // , expr subst
if (k < *n)
{
i__2 = *n - k;
d__1 = 1. / bkk;
zdscal_(&i__2, &d__1, &ap[kk + 1], &c__1);
d__1 = akk * -.5;
ct.r = d__1;
ct.i = 0.; // , expr subst
i__2 = *n - k;
zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ;
i__2 = *n - k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zhpr2_(uplo, &i__2, &z__1, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]);
i__2 = *n - k;
zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ;
i__2 = *n - k;
ztpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1);
}
kk = k1k1;
/* L20: */
}
}
}
else
{
if (upper)
{
/* Compute U*A*U**H */
/* K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
i__2 = k - 1;
ztpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1);
d__1 = akk * .5;
ct.r = d__1;
ct.i = 0.; // , expr subst
i__2 = k - 1;
zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
zhpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]);
i__2 = k - 1;
zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
zdscal_(&i__2, &bkk, &ap[k1], &c__1);
i__2 = kk;
/* Computing 2nd power */
d__2 = bkk;
d__1 = akk * (d__2 * d__2);
ap[i__2].r = d__1;
ap[i__2].i = 0.; // , expr subst
/* L30: */
}
}
else
{
/* Compute L**H *A*L */
/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
i__2 = jj;
ajj = ap[i__2].r;
i__2 = jj;
bjj = bp[i__2].r;
i__2 = jj;
d__1 = ajj * bjj;
i__3 = *n - j;
zdotc_f2c_(&z__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
z__1.r = d__1 + z__2.r;
z__1.i = z__2.i; // , expr subst
ap[i__2].r = z__1.r;
ap[i__2].i = z__1.i; // , expr subst
i__2 = *n - j;
zdscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
zhpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, & c_b1, &ap[jj + 1], &c__1);
i__2 = *n - j + 1;
ztpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj] , &ap[jj], &c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of ZHPGST */
}