PyObject* multi_dotu(PyObject *self, PyObject *args)
{
PyArrayObject* a;
PyArrayObject* b;
PyArrayObject* c;
if (!PyArg_ParseTuple(args, "OOO", &a, &b, &c))
return NULL;
int n0 = PyArray_DIMS(a)[0];
int n = PyArray_DIMS(a)[1];
for (int i = 2; i < PyArray_NDIM(a); i++)
n *= PyArray_DIMS(a)[i];
int incx = 1;
int incy = 1;
if (PyArray_DESCR(a)->type_num == NPY_DOUBLE)
{
double *ap = DOUBLEP(a);
double *bp = DOUBLEP(b);
double *cp = DOUBLEP(c);
for (int i = 0; i < n0; i++)
{
cp[i] = ddot_(&n, (void*)ap,
&incx, (void*)bp, &incy);
ap += n;
bp += n;
}
}
else
{
double_complex* ap = COMPLEXP(a);
double_complex* bp = COMPLEXP(b);
double_complex* cp = COMPLEXP(c);
for (int i = 0; i < n0; i++)
{
cp[i] = 0.0;
for (int j = 0; j < n; j++)
cp[i] += ap[j] * bp[j];
ap += n;
bp += n;
}
}
Py_RETURN_NONE;
}
void QToCurve(const double *Q, integer d, integer n, double *C, bool isclosed)
{
double *q2n = new double[n + n * d];
double *q2nTimesQ = q2n + n;
integer inc = n;
for (integer i = 0; i < n; i++)
{
q2n[i] = sqrt(ddot_(&d, const_cast<double *> (Q + i), &inc, const_cast<double *> (Q + i), &inc));
}
ElasticCurvesRO::PointwiseQProdl(Q, q2n, d, n, q2nTimesQ);
for (integer i = 0; i < d; i++)
{
ElasticCurvesRO::CumTrapz(q2nTimesQ + i * n, n, 1.0 / (n - 1), C);
}
delete[] q2n;
};
double CheMPS2::Excitation::third_middle( const int ikappa, const SyBookkeeper * book_up, const SyBookkeeper * book_down, const double gamma, Sobject * S_up, Sobject * S_down, TensorO * Lovlp, TensorO * Rovlp, double * workmem1, double * workmem2 ){
const int index = S_up->gIndex();
const int TwoSL = S_up->gTwoSL( ikappa );
const int TwoSR = S_up->gTwoSR( ikappa );
const int TwoJ = S_up->gTwoJ( ikappa );
const int NL = S_up->gNL( ikappa );
const int NR = S_up->gNR( ikappa );
const int IL = S_up->gIL( ikappa );
const int IR = S_up->gIR( ikappa );
const int N1 = S_up->gN1( ikappa );
const int N2 = S_up->gN2( ikappa );
int dimLup = book_up ->gCurrentDim( index, NL, TwoSL, IL );
int dimRup = book_up ->gCurrentDim( index + 2, NR, TwoSR, IR );
int dimLdown = book_down->gCurrentDim( index, NL, TwoSL, IL );
int dimRdown = book_down->gCurrentDim( index + 2, NR, TwoSR, IR );
double inproduct = 0.0;
if (( dimLdown > 0 ) && ( dimRdown > 0 )){
double * block_down = S_down->gStorage( NL, TwoSL, IL, N1, N2, TwoJ, NR, TwoSR, IR );
double * block_left = Lovlp ->gStorage( NL, TwoSL, IL, NL, TwoSL, IL );
double * block_right = Rovlp ->gStorage( NR, TwoSR, IR, NR, TwoSR, IR );
char trans = 'T';
char notrans = 'N';
double one = 1.0;
double set = 0.0;
dgemm_( ¬rans, ¬rans, &dimLup, &dimRdown, &dimLdown, &one, block_left, &dimLup, block_down, &dimLdown, &set, workmem1, &dimLup );
dgemm_( ¬rans, &trans, &dimLup, &dimRup, &dimRdown, &one, workmem1, &dimLup, block_right, &dimRup, &set, workmem2, &dimLup );
double * block_up = S_up->gStorage() + S_up->gKappa2index( ikappa );
int size = dimLup * dimRup;
int inc1 = 1;
if ( fabs( gamma ) > 0.0 ){
double factor = gamma;
daxpy_( &size, &factor, workmem2, &inc1, block_up, &inc1 );
}
inproduct = ddot_( &size, workmem2, &inc1, block_up, &inc1 );
}
return inproduct;
}
void CheMPS2::Heff::addDiagramExcitations(const int ikappa, double * memS, double * memHeff, const Sobject * denS, int nLower, double ** VeffTilde) const{
int dimTotal = denS->gKappa2index(denS->gNKappa());
int ptr = denS->gKappa2index(ikappa);
int dimBlock = denS->gKappa2index(ikappa+1) - ptr;
int inc = 1;
#ifdef CHEMPS2_MPI_COMPILATION
const int MPIRANK = MPIchemps2::mpi_rank();
#endif
for (int state=0; state<nLower; state++){
#ifdef CHEMPS2_MPI_COMPILATION
if ( MPIchemps2::owner_specific_excitation( Prob->gL(), state ) == MPIRANK )
#endif
{
double alpha = ddot_(&dimTotal, memS, &inc, VeffTilde[state], &inc);
daxpy_(&dimBlock,&alpha,VeffTilde[state]+ptr,&inc,memHeff+ptr,&inc);
}
}
}
int main(int argc, char** argv) {
/* You can define arrays on the heap */
double *a = (double*) malloc( 3 * sizeof(double) );
a[0] = 1.0;
a[1] = 2.0;
a[2] = 3.0;
/* or on the stack */
double b[3] = { 4.0, 5.0, 6.0 };
printf("A=\tB=\n");
for (int i = 0; i < 3; i++) {
printf("%2.1f\t%2.1f\n", a[i], b[i]);
}
int N = 3, one = 1;
double dot_product = ddot_(&N, a, &one, b, &one);
printf("\nA dot B = %2.1f\n", dot_product);
return 0;
};
/*! drovector*dcovector operator */
inline double operator*(const drovector& rovec, const dcovector& covec)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] operator*(const drovector&, const dcovector&)"
<< std::endl;
#endif//CPPL_VERBOSE
#ifdef CPPL_DEBUG
if(rovec.L!=covec.L){
std::cerr << "[ERROR] operator*(const drovector&, const dcovector&)"
<< std::endl
<< "These two vectors can not make a product." << std::endl
<< "Your input was (" << rovec.L << ") * (" << covec.L << ")."
<< std::endl;
exit(1);
}
#endif//CPPL_DEBUG
double val( ddot_( rovec.L, rovec.Array, 1, covec.Array, 1 ) );
return val;
}
/* Ref: Weiss, Algorithm 11 CGS
* INPUT
* n : dimension of the problem
* b [n] : r-h-s vector
* atimes (int n, static double *x, double *b, void *param) :
* calc matrix-vector product A.x = b.
* atimes_param : parameters for atimes().
* it : struct iter. following entries are used
* it->max = kend : max of iteration
* it->eps = eps : criteria for |r^2|/|b^2|
* OUTPUT
* returned value : 0 == success, otherwise (-1) == failed
* x [n] : solution
* it->niter : # of iteration
* it->res2 : |r^2| / |b^2|
*/
int
cgs (int n, const double *b, double *x,
void (*atimes) (int, const double *, double *, void *),
void *atimes_param,
struct iter *it)
{
#ifndef HAVE_CBLAS_H
# ifdef HAVE_BLAS_H
/* use Fortran BLAS routines */
int i_1 = 1;
double d_m1 = -1.0;
double d_2 = 2.0;
# endif // !HAVE_BLAS_H
#endif // !HAVE_CBLAS_H
int ret = -1;
double eps2 = it->eps * it->eps;
int itmax = it->max;
double *r = (double *)malloc (sizeof (double) * n);
double *r0 = (double *)malloc (sizeof (double) * n);
double *p = (double *)malloc (sizeof (double) * n);
double *u = (double *)malloc (sizeof (double) * n);
double *ap = (double *)malloc (sizeof (double) * n);
double *q = (double *)malloc (sizeof (double) * n);
double *t = (double *)malloc (sizeof (double) * n);
CHECK_MALLOC (r, "cgs");
CHECK_MALLOC (r0, "cgs");
CHECK_MALLOC (p, "cgs");
CHECK_MALLOC (u, "cgs");
CHECK_MALLOC (ap, "cgs");
CHECK_MALLOC (q, "cgs");
CHECK_MALLOC (t, "cgs");
double r0ap;
double rho, rho1;
double delta;
double beta;
double res2 = 0.0;
#ifdef HAVE_CBLAS_H
/**
* ATLAS version
*/
double b2 = cblas_ddot (n, b, 1, b, 1); // (b,b)
eps2 *= b2;
// initial residue
atimes (n, x, r, atimes_param); // r = A.x
cblas_daxpy (n, -1.0, b, 1, r, 1); // r = A.x - b
cblas_dcopy (n, r, 1, r0, 1); // r0* = r
cblas_dcopy (n, r, 1, p, 1); // p = r
cblas_dcopy (n, r, 1, u, 1); // u = r
rho = cblas_ddot (n, r0, 1, r, 1); // rho = (r0*, r)
int i;
for (i = 0; i < itmax; i ++)
{
atimes (n, p, ap, atimes_param); // ap = A.p
r0ap = cblas_ddot (n, r0, 1, ap, 1); // r0ap = (r0*, A.p)
delta = - rho / r0ap;
cblas_dcopy (n, u, 1, q, 1); // q = u
cblas_dscal (n, 2.0, q, 1); // q = 2 u
cblas_daxpy (n, delta, ap, 1, q, 1); // q = 2 u + delta A.p
atimes (n, q, t, atimes_param); // t = A.q
cblas_daxpy (n, delta, t, 1, r, 1); // r = r + delta t
cblas_daxpy (n, delta, q, 1, x, 1); // x = x + delta q
res2 = cblas_ddot (n, r, 1, r, 1);
if (it->debug == 2)
{
fprintf (it->out, "libiter-cgs %d %e\n", i, res2 / b2);
}
if (res2 <= eps2)
{
ret = 0; // success
break;
}
rho1 = cblas_ddot (n, r0, 1, r, 1); // rho = (r0*, r)
beta = rho1 / rho;
rho = rho1;
// here t is not used so that this is used for working area.
double *qu = t;
cblas_dcopy (n, q, 1, qu, 1); // qu = q
cblas_daxpy (n, -1.0, u, 1, qu, 1); // qu = q - u
cblas_dcopy (n, r, 1, u, 1); // u = r
cblas_daxpy (n, beta, qu, 1, u, 1); // u = r + beta (q - u)
cblas_daxpy (n, beta, p, 1, qu, 1); // qu = q - u + beta * p
cblas_dcopy (n, u, 1, p, 1); // p = u
cblas_daxpy (n, beta, qu, 1, p, 1); // p = u + beta (q - u + b * p)
}
#else // !HAVE_CBLAS_H
# ifdef HAVE_BLAS_H
/**
* BLAS version
*/
double b2 = ddot_ (&n, b, &i_1, b, &i_1); // (b,b)
eps2 *= b2;
// initial residue
atimes (n, x, r, atimes_param); // r = A.x
daxpy_ (&n, &d_m1, b, &i_1, r, &i_1); // r = A.x - b
dcopy_ (&n, r, &i_1, r0, &i_1); // r0* = r
dcopy_ (&n, r, &i_1, p, &i_1); // p = r
dcopy_ (&n, r, &i_1, u, &i_1); // u = r
rho = ddot_ (&n, r0, &i_1, r, &i_1); // rho = (r0*, r)
int i;
for (i = 0; i < itmax; i ++)
{
atimes (n, p, ap, atimes_param); // ap = A.p
r0ap = ddot_ (&n, r0, &i_1, ap, &i_1); // r0ap = (r0*, A.p)
delta = - rho / r0ap;
dcopy_ (&n, u, &i_1, q, &i_1); // q = u
dscal_ (&n, &d_2, q, &i_1); // q = 2 u
daxpy_ (&n, &delta, ap, &i_1, q, &i_1); // q = 2 u + delta A.p
atimes (n, q, t, atimes_param); // t = A.q
daxpy_ (&n, &delta, t, &i_1, r, &i_1); // r = r + delta t
daxpy_ (&n, &delta, q, &i_1, x, &i_1); // x = x + delta q
res2 = ddot_ (&n, r, &i_1, r, &i_1);
if (it->debug == 2)
{
fprintf (it->out, "libiter-cgs %d %e\n", i, res2 / b2);
}
if (res2 <= eps2)
{
ret = 0; // success
break;
}
rho1 = ddot_ (&n, r0, &i_1, r, &i_1); // rho = (r0*, r)
beta = rho1 / rho;
rho = rho1;
// here t is not used so that this is used for working area.
double *qu = t;
dcopy_ (&n, q, &i_1, qu, &i_1); // qu = q
daxpy_ (&n, &d_m1, u, &i_1, qu, &i_1); // qu = q - u
dcopy_ (&n, r, &i_1, u, &i_1); // u = r
daxpy_ (&n, &beta, qu, &i_1, u, &i_1); // u = r + beta (q - u)
daxpy_ (&n, &beta, p, &i_1, qu, &i_1); // qu = q - u + beta * p
dcopy_ (&n, u, &i_1, p, &i_1); // p = u
daxpy_ (&n, &beta, qu, &i_1, p, &i_1); // p = u + beta (q - u + b * p)
}
# else // !HAVE_BLAS_H
/**
* local BLAS version
*/
double b2 = my_ddot (n, b, 1, b, 1); // (b,b)
eps2 *= b2;
// initial residue
atimes (n, x, r, atimes_param); // r = A.x
my_daxpy (n, -1.0, b, 1, r, 1); // r = A.x - b
my_dcopy (n, r, 1, r0, 1); // r0* = r
my_dcopy (n, r, 1, p, 1); // p = r
my_dcopy (n, r, 1, u, 1); // u = r
rho = my_ddot (n, r0, 1, r, 1); // rho = (r0*, r)
int i;
for (i = 0; i < itmax; i ++)
{
atimes (n, p, ap, atimes_param); // ap = A.p
r0ap = my_ddot (n, r0, 1, ap, 1); // r0ap = (r0*, A.p)
delta = - rho / r0ap;
my_dcopy (n, u, 1, q, 1); // q = u
my_dscal (n, 2.0, q, 1); // q = 2 u
my_daxpy (n, delta, ap, 1, q, 1); // q = 2 u + delta A.p
atimes (n, q, t, atimes_param); // t = A.q
my_daxpy (n, delta, t, 1, r, 1); // r = r + delta t
my_daxpy (n, delta, q, 1, x, 1); // x = x + delta q
res2 = my_ddot (n, r, 1, r, 1);
if (it->debug == 2)
{
fprintf (it->out, "libiter-cgs %d %e\n", i, res2 / b2);
}
if (res2 <= eps2)
{
ret = 0; // success
break;
}
rho1 = my_ddot (n, r0, 1, r, 1); // rho = (r0*, r)
beta = rho1 / rho;
rho = rho1;
// here t is not used so that this is used for working area.
double *qu = t;
my_dcopy (n, q, 1, qu, 1); // qu = q
my_daxpy (n, -1.0, u, 1, qu, 1); // qu = q - u
my_dcopy (n, r, 1, u, 1); // u = r
my_daxpy (n, beta, qu, 1, u, 1); // u = r + beta (q - u)
my_daxpy (n, beta, p, 1, qu, 1); // qu = q - u + beta * p
my_dcopy (n, u, 1, p, 1); // p = u
my_daxpy (n, beta, qu, 1, p, 1); // p = u + beta (q - u + b * p)
}
# endif // !HAVE_BLAS_H
#endif // !HAVE_CBLAS_H
free (r);
free (r0);
free (p);
free (u);
free (ap);
free (q);
free (t);
if (it->debug == 1)
{
fprintf (it->out, "libiter-cgs it= %d res^2= %e\n", i, res2);
}
it->niter = i;
it->res2 = res2 / b2;
return (ret);
}
double CheMPS2::Excitation::neighbours( const int ikappa, const SyBookkeeper * book_up, const SyBookkeeper * book_down, const double alpha, const double beta, const double gamma, Sobject * S_up, Sobject * S_down ){
const int index = S_up->gIndex();
const int TwoSL = S_up->gTwoSL( ikappa );
const int TwoSR = S_up->gTwoSR( ikappa );
const int TwoJ = S_up->gTwoJ( ikappa );
const int NL = S_up->gNL( ikappa );
const int NR = S_up->gNR( ikappa );
const int IL = S_up->gIL( ikappa );
const int IR = S_up->gIR( ikappa );
const int N1 = S_up->gN1( ikappa );
const int N2 = S_up->gN2( ikappa );
const int dimLup = book_up ->gCurrentDim( index, NL, TwoSL, IL );
const int dimRup = book_up ->gCurrentDim( index + 2, NR, TwoSR, IR );
const int dimLdown = book_down->gCurrentDim( index, NL, TwoSL, IL );
const int dimRdown = book_down->gCurrentDim( index + 2, NR, TwoSR, IR );
assert( dimLup == dimLdown );
assert( dimRup == dimRdown );
assert( book_up->gIrrep( index ) == book_up->gIrrep( index + 1 ) );
double * block_up = S_up->gStorage() + S_up->gKappa2index( ikappa );
int size = dimLup * dimRup;
int inc1 = 1;
// Add a^+ a
if ( fabs( alpha ) > 0.0 ){
if (( TwoJ == 0 ) && ( N1 == 1 ) && ( N2 == 1 )){
double * block_down = S_down->gStorage( NL, TwoSL, IL, 0, 2, TwoJ, NR, TwoSR, IR );
assert( block_down != NULL );
double factor = sqrt( 2.0 ) * alpha;
daxpy_( &size, &factor, block_down, &inc1, block_up, &inc1 );
}
if (( TwoJ == 1 ) && ( N1 == 2 ) && ( N2 == 1 )){
double * block_down = S_down->gStorage( NL, TwoSL, IL, 1, 2, TwoJ, NR, TwoSR, IR );
assert( block_down != NULL );
double factor = -alpha;
daxpy_( &size, &factor, block_down, &inc1, block_up, &inc1 );
}
if (( TwoJ == 1 ) && ( N1 == 1 ) && ( N2 == 0 )){
double * block_down = S_down->gStorage( NL, TwoSL, IL, 0, 1, TwoJ, NR, TwoSR, IR );
assert( block_down != NULL );
double factor = alpha;
daxpy_( &size, &factor, block_down, &inc1, block_up, &inc1 );
}
if (( TwoJ == 0 ) && ( N1 == 2 ) && ( N2 == 0 )){
double * block_down = S_down->gStorage( NL, TwoSL, IL, 1, 1, TwoJ, NR, TwoSR, IR );
assert( block_down != NULL );
double factor = sqrt( 2.0 ) * alpha;
daxpy_( &size, &factor, block_down, &inc1, block_up, &inc1 );
}
}
// Add a a^+
if ( fabs( beta ) > 0.0 ){
if (( TwoJ == 0 ) && ( N1 == 1 ) && ( N2 == 1 )){
double * block_down = S_down->gStorage( NL, TwoSL, IL, 2, 0, TwoJ, NR, TwoSR, IR );
assert( block_down != NULL );
double factor = sqrt( 2.0 ) * beta;
daxpy_( &size, &factor, block_down, &inc1, block_up, &inc1 );
}
if (( TwoJ == 1 ) && ( N1 == 0 ) && ( N2 == 1 )){
double * block_down = S_down->gStorage( NL, TwoSL, IL, 1, 0, TwoJ, NR, TwoSR, IR );
assert( block_down != NULL );
double factor = beta;
daxpy_( &size, &factor, block_down, &inc1, block_up, &inc1 );
}
if (( TwoJ == 1 ) && ( N1 == 1 ) && ( N2 == 2 )){
double * block_down = S_down->gStorage( NL, TwoSL, IL, 2, 1, TwoJ, NR, TwoSR, IR );
assert( block_down != NULL );
double factor = -beta;
daxpy_( &size, &factor, block_down, &inc1, block_up, &inc1 );
}
if (( TwoJ == 0 ) && ( N1 == 0 ) && ( N2 == 2 )){
double * block_down = S_down->gStorage( NL, TwoSL, IL, 1, 1, TwoJ, NR, TwoSR, IR );
assert( block_down != NULL );
double factor = sqrt( 2.0 ) * beta;
daxpy_( &size, &factor, block_down, &inc1, block_up, &inc1 );
}
}
// Add the constant part
double * block_down = S_down->gStorage( NL, TwoSL, IL, N1, N2, TwoJ, NR, TwoSR, IR );
assert( block_down != NULL );
if ( fabs( gamma ) > 0.0 ){
double factor = gamma;
daxpy_( &size, &factor, block_down, &inc1, block_up, &inc1 );
}
const double inproduct = ddot_( &size, block_down, &inc1, block_up, &inc1 );
return inproduct;
}
/* Subroutine */
int dpptri_(char *uplo, integer *n, doublereal *ap, integer * info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer j, jc, jj;
doublereal ajj;
integer jjn;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
extern /* Subroutine */
int dspr_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *), dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *);
logical upper;
extern /* Subroutine */
int xerbla_(char *, integer *), dtptri_( char *, char *, integer *, doublereal *, 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 Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DPPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
dtptri_(uplo, "Non-unit", n, &ap[1], info);
if (*info > 0)
{
return 0;
}
if (upper)
{
/* Compute the product inv(U) * inv(U)**T. */
jj = 0;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
jc = jj + 1;
jj += j;
if (j > 1)
{
i__2 = j - 1;
dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
}
ajj = ap[jj];
dscal_(&j, &ajj, &ap[jc], &c__1);
/* L10: */
}
}
else
{
/* Compute the product inv(L)**T * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
jjn = jj + *n - j + 1;
i__2 = *n - j + 1;
ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
if (j < *n)
{
i__2 = *n - j;
dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[ jj + 1], &c__1);
}
jj = jjn;
/* L20: */
}
}
return 0;
/* End of DPPTRI */
}
/* Subroutine */ int dpptri_(char *uplo, integer *n, doublereal *ap, integer *
info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer j, jc, jj;
doublereal ajj;
integer jjn;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DPPTRI computes the inverse of a real symmetric positive definite */
/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */
/* computed by DPPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangular factor is stored in AP; */
/* = 'L': Lower triangular factor is stored in AP. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T, packed columnwise as */
/* a linear array. The j-th column of U or L is stored in the */
/* array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
/* On exit, the upper or lower triangle of the (symmetric) */
/* inverse of A, overwriting the input factor U or L. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
/* zero, and the inverse could not be computed. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
dtptri_(uplo, "Non-unit", n, &ap[1], info);
if (*info > 0) {
return 0;
}
if (upper) {
/* Compute the product inv(U) * inv(U)'. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
if (j > 1) {
i__2 = j - 1;
dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
}
ajj = ap[jj];
dscal_(&j, &ajj, &ap[jc], &c__1);
}
} else {
/* Compute the product inv(L)' * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jjn = jj + *n - j + 1;
i__2 = *n - j + 1;
ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
if (j < *n) {
i__2 = *n - j;
dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[
jj + 1], &c__1);
}
jj = jjn;
}
}
return 0;
/* End of DPPTRI */
} /* dpptri_ */
// BLAS Level 1
double ddot( int N, double *a, int inca, double *b, int incb ){
return ddot_( &N, a, &inca, b, &incb );
};
/* Subroutine */ int dlaqtr_(logical *ltran, logical *lreal, integer *n,
doublereal *t, integer *ldt, doublereal *b, doublereal *w, doublereal
*scale, doublereal *x, doublereal *work, integer *info)
{
/* System generated locals */
integer t_dim1, t_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Local variables */
doublereal d__[4] /* was [2][2] */;
integer i__, j, k;
doublereal v[4] /* was [2][2] */, z__;
integer j1, j2, n1, n2;
doublereal si, xj, sr, rec, eps, tjj, tmp;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
integer ierr;
doublereal smin, xmax;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
integer jnext;
doublereal sminw, xnorm;
extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *
, doublereal *, integer *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern integer idamax_(integer *, doublereal *, integer *);
doublereal scaloc;
extern /* Subroutine */ int dladiv_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
doublereal bignum;
logical notran;
doublereal smlnum;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAQTR solves the real quasi-triangular system */
/* op(T)*p = scale*c, if LREAL = .TRUE. */
/* or the complex quasi-triangular systems */
/* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. */
/* in real arithmetic, where T is upper quasi-triangular. */
/* If LREAL = .FALSE., then the first diagonal block of T must be */
/* 1 by 1, B is the specially structured matrix */
/* B = [ b(1) b(2) ... b(n) ] */
/* [ w ] */
/* [ w ] */
/* [ . ] */
/* [ w ] */
/* op(A) = A or A', A' denotes the conjugate transpose of */
/* matrix A. */
/* On input, X = [ c ]. On output, X = [ p ]. */
/* [ d ] [ q ] */
/* This subroutine is designed for the condition number estimation */
/* in routine DTRSNA. */
/* Arguments */
/* ========= */
/* LTRAN (input) LOGICAL */
/* On entry, LTRAN specifies the option of conjugate transpose: */
/* = .FALSE., op(T+i*B) = T+i*B, */
/* = .TRUE., op(T+i*B) = (T+i*B)'. */
/* LREAL (input) LOGICAL */
/* On entry, LREAL specifies the input matrix structure: */
/* = .FALSE., the input is complex */
/* = .TRUE., the input is real */
/* N (input) INTEGER */
/* On entry, N specifies the order of T+i*B. N >= 0. */
/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */
/* On entry, T contains a matrix in Schur canonical form. */
/* If LREAL = .FALSE., then the first diagonal block of T mu */
/* be 1 by 1. */
/* LDT (input) INTEGER */
/* The leading dimension of the matrix T. LDT >= max(1,N). */
/* B (input) DOUBLE PRECISION array, dimension (N) */
/* On entry, B contains the elements to form the matrix */
/* B as described above. */
/* If LREAL = .TRUE., B is not referenced. */
/* W (input) DOUBLE PRECISION */
/* On entry, W is the diagonal element of the matrix B. */
/* If LREAL = .TRUE., W is not referenced. */
/* SCALE (output) DOUBLE PRECISION */
/* On exit, SCALE is the scale factor. */
/* X (input/output) DOUBLE PRECISION array, dimension (2*N) */
/* On entry, X contains the right hand side of the system. */
/* On exit, X is overwritten by the solution. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* On exit, INFO is set to */
/* 0: successful exit. */
/* 1: the some diagonal 1 by 1 block has been perturbed by */
/* a small number SMIN to keep nonsingularity. */
/* 2: the some diagonal 2 by 2 block has been perturbed by */
/* a small number in DLALN2 to keep nonsingularity. */
/* NOTE: In the interests of speed, this routine does not */
/* check the inputs for errors. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Do not test the input parameters for errors */
/* Parameter adjustments */
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
--b;
--x;
--work;
/* Function Body */
notran = ! (*ltran);
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
xnorm = dlange_("M", n, n, &t[t_offset], ldt, d__);
if (! (*lreal)) {
/* Computing MAX */
d__1 = xnorm, d__2 = abs(*w), d__1 = max(d__1,d__2), d__2 = dlange_(
"M", n, &c__1, &b[1], n, d__);
xnorm = max(d__1,d__2);
}
/* Computing MAX */
d__1 = smlnum, d__2 = eps * xnorm;
smin = max(d__1,d__2);
/* Compute 1-norm of each column of strictly upper triangular */
/* part of T to control overflow in triangular solver. */
work[1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
work[j] = dasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
/* L10: */
}
if (! (*lreal)) {
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
work[i__] += (d__1 = b[i__], abs(d__1));
/* L20: */
}
}
n2 = *n << 1;
n1 = *n;
if (! (*lreal)) {
n1 = n2;
}
k = idamax_(&n1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
*scale = 1.;
if (xmax > bignum) {
*scale = bignum / xmax;
dscal_(&n1, scale, &x[1], &c__1);
xmax = bignum;
}
if (*lreal) {
if (notran) {
/* Solve T*p = scale*c */
jnext = *n;
for (j = *n; j >= 1; --j) {
if (j > jnext) {
goto L30;
}
j1 = j;
j2 = j;
jnext = j - 1;
if (j > 1) {
if (t[j + (j - 1) * t_dim1] != 0.) {
j1 = j - 1;
jnext = j - 2;
}
}
if (j1 == j2) {
/* Meet 1 by 1 diagonal block */
/* Scale to avoid overflow when computing */
/* x(j) = b(j)/T(j,j) */
xj = (d__1 = x[j1], abs(d__1));
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1));
tmp = t[j1 + j1 * t_dim1];
if (tjj < smin) {
tmp = smin;
tjj = smin;
*info = 1;
}
if (xj == 0.) {
goto L30;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j1] /= tmp;
xj = (d__1 = x[j1], abs(d__1));
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j1 of T. */
if (xj > 1.) {
rec = 1. / xj;
if (work[j1] > (bignum - xmax) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
k = idamax_(&i__1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
}
} else {
/* Meet 2 by 2 diagonal block */
/* Call 2 by 2 linear system solve, to take */
/* care of possible overflow by scaling factor. */
d__[0] = x[j1];
d__[1] = x[j2];
dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1
* t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(n, &scaloc, &x[1], &c__1);
*scale *= scaloc;
}
x[j1] = v[0];
x[j2] = v[1];
/* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) */
/* to avoid overflow in updating right-hand side. */
/* Computing MAX */
d__1 = abs(v[0]), d__2 = abs(v[1]);
xj = max(d__1,d__2);
if (xj > 1.) {
rec = 1. / xj;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xmax) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
/* Update right-hand side */
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[j2];
daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
k = idamax_(&i__1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
}
}
L30:
;
}
} else {
/* Solve T'*p = scale*c */
jnext = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < jnext) {
goto L40;
}
j1 = j;
j2 = j;
jnext = j + 1;
if (j < *n) {
if (t[j + 1 + j * t_dim1] != 0.) {
j2 = j + 1;
jnext = j + 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side element by inner product. */
xj = (d__1 = x[j1], abs(d__1));
if (xmax > 1.) {
rec = 1. / xmax;
if (work[j1] > (bignum - xj) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
c__1);
xj = (d__1 = x[j1], abs(d__1));
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1));
tmp = t[j1 + j1 * t_dim1];
if (tjj < smin) {
tmp = smin;
tjj = smin;
*info = 1;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j1] /= tmp;
/* Computing MAX */
d__2 = xmax, d__3 = (d__1 = x[j1], abs(d__1));
xmax = max(d__2,d__3);
} else {
/* 2 by 2 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side elements by inner product. */
/* Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2],
abs(d__2));
xj = max(d__3,d__4);
if (xmax > 1.) {
rec = 1. / xmax;
/* Computing MAX */
d__1 = work[j2], d__2 = work[j1];
if (max(d__1,d__2) > (bignum - xj) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
&x[1], &c__1);
dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 *
t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &c_b25,
&c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(n, &scaloc, &x[1], &c__1);
*scale *= scaloc;
}
x[j1] = v[0];
x[j2] = v[1];
/* Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2],
abs(d__2)), d__3 = max(d__3,d__4);
xmax = max(d__3,xmax);
}
L40:
;
}
}
} else {
/* Computing MAX */
d__1 = eps * abs(*w);
sminw = max(d__1,smin);
if (notran) {
/* Solve (T + iB)*(p+iq) = c+id */
jnext = *n;
for (j = *n; j >= 1; --j) {
if (j > jnext) {
goto L70;
}
j1 = j;
j2 = j;
jnext = j - 1;
if (j > 1) {
if (t[j + (j - 1) * t_dim1] != 0.) {
j1 = j - 1;
jnext = j - 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block */
/* Scale if necessary to avoid overflow in division */
z__ = *w;
if (j1 == 1) {
z__ = b[1];
}
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(
d__2));
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__);
tmp = t[j1 + j1 * t_dim1];
if (tjj < sminw) {
tmp = sminw;
tjj = sminw;
*info = 1;
}
if (xj == 0.) {
goto L70;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
dladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si);
x[j1] = sr;
x[*n + j1] = si;
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(
d__2));
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j1 of T. */
if (xj > 1.) {
rec = 1. / xj;
if (work[j1] > (bignum - xmax) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
}
}
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[*
n + 1], &c__1);
x[1] += b[j1] * x[*n + j1];
x[*n + 1] -= b[j1] * x[j1];
xmax = 0.;
i__1 = j1 - 1;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__3 = xmax, d__4 = (d__1 = x[k], abs(d__1)) + (
d__2 = x[k + *n], abs(d__2));
xmax = max(d__3,d__4);
/* L50: */
}
}
} else {
/* Meet 2 by 2 diagonal block */
d__[0] = x[j1];
d__[1] = x[j2];
d__[2] = x[*n + j1];
d__[3] = x[*n + j2];
d__1 = -(*w);
dlaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 +
j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
c_b25, &d__1, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
i__1 = *n << 1;
dscal_(&i__1, &scaloc, &x[1], &c__1);
*scale = scaloc * *scale;
}
x[j1] = v[0];
x[j2] = v[1];
x[*n + j1] = v[2];
x[*n + j2] = v[3];
/* Scale X(J1), .... to avoid overflow in */
/* updating right hand side. */
/* Computing MAX */
d__1 = abs(v[0]) + abs(v[2]), d__2 = abs(v[1]) + abs(v[3])
;
xj = max(d__1,d__2);
if (xj > 1.) {
rec = 1. / xj;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xmax) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
}
}
/* Update the right-hand side. */
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[j2];
daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[*
n + 1], &c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j2];
daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[*
n + 1], &c__1);
x[1] = x[1] + b[j1] * x[*n + j1] + b[j2] * x[*n + j2];
x[*n + 1] = x[*n + 1] - b[j1] * x[j1] - b[j2] * x[j2];
xmax = 0.;
i__1 = j1 - 1;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__3 = (d__1 = x[k], abs(d__1)) + (d__2 = x[k + *
n], abs(d__2));
xmax = max(d__3,xmax);
/* L60: */
}
}
}
L70:
;
}
} else {
/* Solve (T + iB)'*(p+iq) = c+id */
jnext = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < jnext) {
goto L80;
}
j1 = j;
j2 = j;
jnext = j + 1;
if (j < *n) {
if (t[j + 1 + j * t_dim1] != 0.) {
j2 = j + 1;
jnext = j + 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side element by inner product. */
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(
d__2));
if (xmax > 1.) {
rec = 1. / xmax;
if (work[j1] > (bignum - xj) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
c__1);
i__2 = j1 - 1;
x[*n + j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[
*n + 1], &c__1);
if (j1 > 1) {
x[j1] -= b[j1] * x[*n + 1];
x[*n + j1] += b[j1] * x[1];
}
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(
d__2));
z__ = *w;
if (j1 == 1) {
z__ = b[1];
}
/* Scale if necessary to avoid overflow in */
/* complex division */
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__);
tmp = t[j1 + j1 * t_dim1];
if (tjj < sminw) {
tmp = sminw;
tjj = sminw;
*info = 1;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
d__1 = -z__;
dladiv_(&x[j1], &x[*n + j1], &tmp, &d__1, &sr, &si);
x[j1] = sr;
x[j1 + *n] = si;
/* Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n],
abs(d__2));
xmax = max(d__3,xmax);
} else {
/* 2 by 2 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side element by inner product. */
/* Computing MAX */
d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1],
abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + (
d__4 = x[*n + j2], abs(d__4));
xj = max(d__5,d__6);
if (xmax > 1.) {
rec = 1. / xmax;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xj) / xmax) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[2] = x[*n + j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &
c__1, &x[*n + 1], &c__1);
i__2 = j1 - 1;
d__[3] = x[*n + j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &
c__1, &x[*n + 1], &c__1);
d__[0] -= b[j1] * x[*n + 1];
d__[1] -= b[j2] * x[*n + 1];
d__[2] += b[j1] * x[1];
d__[3] += b[j2] * x[1];
dlaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1
* t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
c_b25, w, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(&n2, &scaloc, &x[1], &c__1);
*scale = scaloc * *scale;
}
x[j1] = v[0];
x[j2] = v[1];
x[*n + j1] = v[2];
x[*n + j2] = v[3];
/* Computing MAX */
d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1],
abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + (
d__4 = x[*n + j2], abs(d__4)), d__5 = max(d__5,
d__6);
xmax = max(d__5,xmax);
}
L80:
;
}
}
}
return 0;
/* End of DLAQTR */
} /* dlaqtr_ */
/* Subroutine */ HYPRE_Int dlatrd_(const char *uplo, integer *n, integer *nb, doublereal *
a, integer *lda, doublereal *e, doublereal *tau, doublereal *w,
integer *ldw)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DLATRD reduces NB rows and columns of a real symmetric matrix A to
symmetric tridiagonal form by an orthogonal similarity
transformation Q' * A * Q, and returns the matrices V and W which are
needed to apply the transformation to the unreduced part of A.
If UPLO = 'U', DLATRD reduces the last NB rows and columns of a
matrix, of which the upper triangle is supplied;
if UPLO = 'L', DLATRD reduces the first NB rows and columns of a
matrix, of which the lower triangle is supplied.
This is an auxiliary routine called by DSYTRD.
Arguments
=========
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A.
NB (input) INTEGER
The number of rows and columns to be reduced.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric 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 last NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements above the diagonal
with the array TAU, represent the orthogonal matrix Q as a
product of elementary reflectors;
if UPLO = 'L', the first NB columns have been reduced to
tridiagonal form, with the diagonal elements overwriting
the diagonal elements of A; the elements below the diagonal
with the array TAU, represent the orthogonal matrix Q as a
product of elementary reflectors.
See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= (1,N).
E (output) DOUBLE PRECISION array, dimension (N-1)
If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
elements of the last NB columns of the reduced matrix;
if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
the first NB columns of the reduced matrix.
TAU (output) DOUBLE PRECISION array, dimension (N-1)
The scalar factors of the elementary reflectors, stored in
TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
See Further Details.
W (output) DOUBLE PRECISION array, dimension (LDW,NB)
The n-by-nb matrix W required to update the unreduced part
of A.
LDW (input) INTEGER
The leading dimension of the array W. LDW >= max(1,N).
Further Details
===============
If UPLO = 'U', the matrix Q is represented as a product of elementary
reflectors
Q = H(n) H(n-1) . . . H(n-nb+1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
and tau in TAU(i-1).
If UPLO = 'L', the matrix Q is represented as a product of 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 real scalar, and v is a real vector with
v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
and tau in TAU(i).
The elements of the vectors v together form the n-by-nb matrix V
which is needed, with W, to apply the transformation to the unreduced
part of the matrix, using a symmetric rank-2k update of the form:
A := A - V*W' - W*V'.
The contents of A on exit are illustrated by the following examples
with n = 5 and nb = 2:
if UPLO = 'U': if UPLO = 'L':
( a a a v4 v5 ) ( d )
( a a v4 v5 ) ( 1 d )
( a 1 v5 ) ( v1 1 a )
( d 1 ) ( v1 v2 a a )
( d ) ( v1 v2 a a a )
where d denotes a diagonal element of the reduced matrix, a denotes
an element of the original matrix that is unchanged, and vi denotes
an element of the vector defining H(i).
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static doublereal c_b5 = -1.;
static doublereal c_b6 = 1.;
static integer c__1 = 1;
static doublereal c_b16 = 0.;
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i__;
static doublereal alpha;
extern /* Subroutine */ HYPRE_Int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(const char *,const char *);
extern /* Subroutine */ HYPRE_Int dgemv_(const char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), daxpy_(integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *),
dsymv_(const char *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *), dlarfg_(integer *, doublereal *, doublereal *, integer *,
doublereal *);
static integer iw;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define w_ref(a_1,a_2) w[(a_2)*w_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1 * 1;
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 = *n - i__;
dgemv_("No transpose", &i__, &i__2, &c_b5, &a_ref(1, i__ + 1),
lda, &w_ref(i__, iw + 1), ldw, &c_b6, &a_ref(1, i__),
&c__1);
i__2 = *n - i__;
dgemv_("No transpose", &i__, &i__2, &c_b5, &w_ref(1, iw + 1),
ldw, &a_ref(i__, i__ + 1), lda, &c_b6, &a_ref(1, i__),
&c__1);
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate
A(1:i-2,i) */
i__2 = i__ - 1;
dlarfg_(&i__2, &a_ref(i__ - 1, i__), &a_ref(1, i__), &c__1, &
tau[i__ - 1]);
e[i__ - 1] = a_ref(i__ - 1, i__);
a_ref(i__ - 1, i__) = 1.;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
dsymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a_ref(1,
i__), &c__1, &c_b16, &w_ref(1, iw), &c__1);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &w_ref(1, iw + 1)
, ldw, &a_ref(1, i__), &c__1, &c_b16, &w_ref(i__
+ 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(1, i__
+ 1), lda, &w_ref(i__ + 1, iw), &c__1, &c_b6, &
w_ref(1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &a_ref(1, i__ +
1), lda, &a_ref(1, i__), &c__1, &c_b16, &w_ref(
i__ + 1, iw), &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(1, iw
+ 1), ldw, &w_ref(i__ + 1, iw), &c__1, &c_b6, &
w_ref(1, iw), &c__1);
}
i__2 = i__ - 1;
dscal_(&i__2, &tau[i__ - 1], &w_ref(1, iw), &c__1);
i__2 = i__ - 1;
alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w_ref(1, iw), &
c__1, &a_ref(1, i__), &c__1);
i__2 = i__ - 1;
daxpy_(&i__2, &alpha, &a_ref(1, i__), &c__1, &w_ref(1, iw), &
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 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__, 1), lda, &
w_ref(i__, 1), ldw, &c_b6, &a_ref(i__, i__), &c__1);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(i__, 1), ldw, &
a_ref(i__, 1), lda, &c_b6, &a_ref(i__, i__), &c__1);
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate
A(i+2:n,i)
Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
dlarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(min(i__2,*n), i__)
, &c__1, &tau[i__]);
e[i__] = a_ref(i__ + 1, i__);
a_ref(i__ + 1, i__) = 1.;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
dsymv_("Lower", &i__2, &c_b6, &a_ref(i__ + 1, i__ + 1), lda, &
a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &w_ref(i__ + 1, 1),
ldw, &a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, 1)
, lda, &w_ref(1, i__), &c__1, &c_b6, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b6, &a_ref(i__ + 1, 1),
lda, &a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(1,
i__), &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(i__ + 1, 1)
, ldw, &w_ref(1, i__), &c__1, &c_b6, &w_ref(i__ + 1,
i__), &c__1);
i__2 = *n - i__;
dscal_(&i__2, &tau[i__], &w_ref(i__ + 1, i__), &c__1);
i__2 = *n - i__;
alpha = tau[i__] * -.5 * ddot_(&i__2, &w_ref(i__ + 1, i__), &
c__1, &a_ref(i__ + 1, i__), &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &w_ref(i__
+ 1, i__), &c__1);
}
/* L20: */
}
}
return 0;
/* End of DLATRD */
} /* dlatrd_ */
Int TRON::trcg(double delta, double *g, double *s, double *r)
{
Int i, inc = 1;
Int n = fun_obj->get_nr_variable();
double one = 1;
double *d = new double[n];
double *Hd = new double[n];
double rTr, rnewTrnew, alpha, beta, cgtol;
for (i=0; i<n; i++)
{
s[i] = 0;
r[i] = -g[i];
d[i] = r[i];
}
cgtol = eps_cg*dnrm2_(&n, g, &inc);
Int cg_iter = 0;
rTr = ddot_(&n, r, &inc, r, &inc);
while (1)
{
if (dnrm2_(&n, r, &inc) <= cgtol)
break;
cg_iter++;
fun_obj->Hv(d, Hd);
alpha = rTr/ddot_(&n, d, &inc, Hd, &inc);
daxpy_(&n, &alpha, d, &inc, s, &inc);
if (dnrm2_(&n, s, &inc) > delta)
{
info("cg reaches trust region boundary\n");
alpha = -alpha;
daxpy_(&n, &alpha, d, &inc, s, &inc);
double std = ddot_(&n, s, &inc, d, &inc);
double sts = ddot_(&n, s, &inc, s, &inc);
double dtd = ddot_(&n, d, &inc, d, &inc);
double dsq = delta*delta;
double rad = sqrt(std*std + dtd*(dsq-sts));
if (std >= 0)
alpha = (dsq - sts)/(std + rad);
else
alpha = (rad - std)/dtd;
daxpy_(&n, &alpha, d, &inc, s, &inc);
alpha = -alpha;
daxpy_(&n, &alpha, Hd, &inc, r, &inc);
break;
}
alpha = -alpha;
daxpy_(&n, &alpha, Hd, &inc, r, &inc);
rnewTrnew = ddot_(&n, r, &inc, r, &inc);
beta = rnewTrnew/rTr;
dscal_(&n, &beta, d, &inc);
daxpy_(&n, &one, r, &inc, d, &inc);
rTr = rnewTrnew;
}
delete[] d;
delete[] Hd;
return(cg_iter);
}
/* Subroutine */ int dsytri_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *ipiv, doublereal *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
doublereal d__1;
/* Local variables */
doublereal d__;
integer k;
doublereal t, ak;
integer kp;
doublereal akp1;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal temp, akkp1;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
integer kstep;
logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYTRI computes the inverse of a real symmetric indefinite matrix */
/* A using the factorization A = U*D*U**T or A = L*D*L**T computed by */
/* DSYTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the block diagonal matrix D and the multipliers */
/* used to obtain the factor U or L as computed by DSYTRF. */
/* On exit, if INFO = 0, the (symmetric) inverse of the original */
/* matrix. If UPLO = 'U', the upper triangular part of the */
/* inverse is formed and the part of A below the diagonal is not */
/* referenced; if UPLO = 'L' the lower triangular part of the */
/* inverse is formed and the part of A above the diagonal is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by DSYTRF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */
/* inverse could not be computed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--work;
/* 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_("DSYTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
for (*info = *n; *info >= 1; --(*info)) {
if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) {
return 0;
}
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) {
return 0;
}
/* L20: */
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L40;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
a[k + k * a_dim1] = 1. / a[k + k * a_dim1];
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k *
a_dim1 + 1], &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = (d__1 = a[k + (k + 1) * a_dim1], abs(d__1));
ak = a[k + k * a_dim1] / t;
akp1 = a[k + 1 + (k + 1) * a_dim1] / t;
akkp1 = a[k + (k + 1) * a_dim1] / t;
d__ = t * (ak * akp1 - 1.);
a[k + k * a_dim1] = akp1 / d__;
a[k + 1 + (k + 1) * a_dim1] = ak / d__;
a[k + (k + 1) * a_dim1] = -akkp1 / d__;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k *
a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + (k + 1) * a_dim1] -= ddot_(&i__1, &a[k * a_dim1 + 1], &
c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
i__1 = k - 1;
dcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
c__1);
i__1 = k - 1;
dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1);
i__1 = k - 1;
a[k + 1 + (k + 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &
a[(k + 1) * a_dim1 + 1], &c__1);
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading */
/* submatrix A(1:k+1,1:k+1) */
i__1 = kp - 1;
dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
c__1);
i__1 = k - kp - 1;
dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) *
a_dim1], lda);
temp = a[k + k * a_dim1];
a[k + k * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = temp;
if (kstep == 2) {
temp = a[k + (k + 1) * a_dim1];
a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1];
a[kp + (k + 1) * a_dim1] = temp;
}
}
k += kstep;
goto L30;
L40:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L50:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L60;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
a[k + k * a_dim1] = 1. / a[k + k * a_dim1];
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
c__1);
i__1 = *n - k;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 +
k * a_dim1], &c__1);
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
t = (d__1 = a[k + (k - 1) * a_dim1], abs(d__1));
ak = a[k - 1 + (k - 1) * a_dim1] / t;
akp1 = a[k + k * a_dim1] / t;
akkp1 = a[k + (k - 1) * a_dim1] / t;
d__ = t * (ak * akp1 - 1.);
a[k - 1 + (k - 1) * a_dim1] = akp1 / d__;
a[k + k * a_dim1] = ak / d__;
a[k + (k - 1) * a_dim1] = -akkp1 / d__;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
c__1);
i__1 = *n - k;
a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 +
k * a_dim1], &c__1);
i__1 = *n - k;
a[k + (k - 1) * a_dim1] -= ddot_(&i__1, &a[k + 1 + k * a_dim1]
, &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1);
i__1 = *n - k;
dcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
c__1);
i__1 = *n - k;
dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
&work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1]
, &c__1);
i__1 = *n - k;
a[k - 1 + (k - 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &
a[k + 1 + (k - 1) * a_dim1], &c__1);
}
kstep = 2;
}
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing */
/* submatrix A(k-1:n,k-1:n) */
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp *
a_dim1], &c__1);
}
i__1 = kp - k - 1;
dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) *
a_dim1], lda);
temp = a[k + k * a_dim1];
a[k + k * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = temp;
if (kstep == 2) {
temp = a[k + (k - 1) * a_dim1];
a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1];
a[kp + (k - 1) * a_dim1] = temp;
}
}
k -= kstep;
goto L50;
L60:
;
}
return 0;
/* End of DSYTRI */
} /* dsytri_ */
/* DECK DCGS */
/* Subroutine */ int dcgs_(integer *n, doublereal *b, doublereal *x, integer *
nelt, integer *ia, integer *ja, doublereal *a, integer *isym, S_fp
matvec, S_fp msolve, integer *itol, doublereal *tol, integer *itmax,
integer *iter, doublereal *err, integer *ierr, integer *iunit,
doublereal *r__, doublereal *r0, doublereal *p, doublereal *q,
doublereal *u, doublereal *v1, doublereal *v2, doublereal *rwork,
integer *iwork)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
static integer i__, k;
static doublereal ak, bk, akm;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal bnrm, rhon, fuzz, sigma;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
extern doublereal d1mach_(integer *);
static doublereal rhonm1;
extern integer isdcgs_(integer *, doublereal *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, S_fp, S_fp,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *);
static doublereal tolmin, solnrm;
/* ***BEGIN PROLOGUE DCGS */
/* ***PURPOSE Preconditioned BiConjugate Gradient Squared Ax=b Solver. */
/* Routine to solve a Non-Symmetric linear system Ax = b */
/* using the Preconditioned BiConjugate Gradient Squared */
/* method. */
/* ***LIBRARY SLATEC (SLAP) */
/* ***CATEGORY D2A4, D2B4 */
/* ***TYPE DOUBLE PRECISION (SCGS-S, DCGS-D) */
/* ***KEYWORDS BICONJUGATE GRADIENT, ITERATIVE PRECONDITION, */
/* NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE */
/* ***AUTHOR Greenbaum, Anne, (Courant Institute) */
/* Seager, Mark K., (LLNL) */
/* Lawrence Livermore National Laboratory */
/* PO BOX 808, L-60 */
/* Livermore, CA 94550 (510) 423-3141 */
/* [email protected] */
/* ***DESCRIPTION */
/* *Usage: */
/* INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX */
/* INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) */
/* DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), R0(N), P(N) */
/* DOUBLE PRECISION Q(N), U(N), V1(N), V2(N), RWORK(USER DEFINED) */
/* EXTERNAL MATVEC, MSOLVE */
/* CALL DCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, */
/* $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, */
/* $ R, R0, P, Q, U, V1, V2, RWORK, IWORK) */
/* *Arguments: */
/* N :IN Integer */
/* Order of the Matrix. */
/* B :IN Double Precision B(N). */
/* Right-hand side vector. */
/* X :INOUT Double Precision X(N). */
/* On input X is your initial guess for solution vector. */
/* On output X is the final approximate solution. */
/* NELT :IN Integer. */
/* Number of Non-Zeros stored in A. */
/* IA :IN Integer IA(NELT). */
/* JA :IN Integer JA(NELT). */
/* A :IN Double Precision A(NELT). */
/* These arrays contain the matrix data structure for A. */
/* It could take any form. See "Description", below, */
/* for more details. */
/* ISYM :IN Integer. */
/* Flag to indicate symmetric storage format. */
/* If ISYM=0, all non-zero entries of the matrix are stored. */
/* If ISYM=1, the matrix is symmetric, and only the upper */
/* or lower triangle of the matrix is stored. */
/* MATVEC :EXT External. */
/* Name of a routine which performs the matrix vector multiply */
/* operation Y = A*X given A and X. The name of the MATVEC */
/* routine must be declared external in the calling program. */
/* The calling sequence of MATVEC is: */
/* CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) */
/* Where N is the number of unknowns, Y is the product A*X upon */
/* return, X is an input vector. NELT, IA, JA, A and ISYM */
/* define the SLAP matrix data structure: see Description,below. */
/* MSOLVE :EXT External. */
/* Name of a routine which solves a linear system MZ = R for Z */
/* given R with the preconditioning matrix M (M is supplied via */
/* RWORK and IWORK arrays). The name of the MSOLVE routine */
/* must be declared external in the calling program. The */
/* calling sequence of MSOLVE is: */
/* CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) */
/* Where N is the number of unknowns, R is the right-hand side */
/* vector, and Z is the solution upon return. NELT, IA, JA, A */
/* and ISYM define the SLAP matrix data structure: see */
/* Description, below. RWORK is a double precision array that */
/* can be used to pass necessary preconditioning information and/ */
/* or workspace to MSOLVE. IWORK is an integer work array for */
/* the same purpose as RWORK. */
/* ITOL :IN Integer. */
/* Flag to indicate type of convergence criterion. */
/* If ITOL=1, iteration stops when the 2-norm of the residual */
/* divided by the 2-norm of the right-hand side is less than TOL. */
/* This routine must calculate the residual from R = A*X - B. */
/* This is unnatural and hence expensive for this type of iter- */
/* ative method. ITOL=2 is *STRONGLY* recommended. */
/* If ITOL=2, iteration stops when the 2-norm of M-inv times the */
/* residual divided by the 2-norm of M-inv times the right hand */
/* side is less than TOL, where M-inv time a vector is the pre- */
/* conditioning step. This is the *NATURAL* stopping for this */
/* iterative method and is *STRONGLY* recommended. */
/* ITOL=11 is often useful for checking and comparing different */
/* routines. For this case, the user must supply the "exact" */
/* solution or a very accurate approximation (one with an error */
/* much less than TOL) through a common block, */
/* COMMON /DSLBLK/ SOLN( ) */
/* If ITOL=11, iteration stops when the 2-norm of the difference */
/* between the iterative approximation and the user-supplied */
/* solution divided by the 2-norm of the user-supplied solution */
/* is less than TOL. */
/* TOL :INOUT Double Precision. */
/* Convergence criterion, as described above. (Reset if IERR=4.) */
/* ITMAX :IN Integer. */
/* Maximum number of iterations. */
/* ITER :OUT Integer. */
/* Number of iterations required to reach convergence, or */
/* ITMAX+1 if convergence criterion could not be achieved in */
/* ITMAX iterations. */
/* ERR :OUT Double Precision. */
/* Error estimate of error in final approximate solution, as */
/* defined by ITOL. */
/* IERR :OUT Integer. */
/* Return error flag. */
/* IERR = 0 => All went well. */
/* IERR = 1 => Insufficient space allocated for WORK or IWORK. */
/* IERR = 2 => Method failed to converge in ITMAX steps. */
/* IERR = 3 => Error in user input. */
/* Check input values of N, ITOL. */
/* IERR = 4 => User error tolerance set too tight. */
/* Reset to 500*D1MACH(3). Iteration proceeded. */
/* IERR = 5 => Breakdown of the method detected. */
/* (r0,r) approximately 0. */
/* IERR = 6 => Stagnation of the method detected. */
/* (r0,v) approximately 0. */
/* IUNIT :IN Integer. */
/* Unit number on which to write the error at each iteration, */
/* if this is desired for monitoring convergence. If unit */
/* number is 0, no writing will occur. */
/* R :WORK Double Precision R(N). */
/* R0 :WORK Double Precision R0(N). */
/* P :WORK Double Precision P(N). */
/* Q :WORK Double Precision Q(N). */
/* U :WORK Double Precision U(N). */
/* V1 :WORK Double Precision V1(N). */
/* V2 :WORK Double Precision V2(N). */
/* Double Precision arrays used for workspace. */
/* RWORK :WORK Double Precision RWORK(USER DEFINED). */
/* Double Precision array that can be used for workspace in */
/* MSOLVE. */
/* IWORK :WORK Integer IWORK(USER DEFINED). */
/* Integer array that can be used for workspace in MSOLVE. */
/* *Description */
/* This routine does not care what matrix data structure is */
/* used for A and M. It simply calls the MATVEC and MSOLVE */
/* routines, with the arguments as described above. The user */
/* could write any type of structure and the appropriate MATVEC */
/* and MSOLVE routines. It is assumed that A is stored in the */
/* IA, JA, A arrays in some fashion and that M (or INV(M)) is */
/* stored in IWORK and RWORK in some fashion. The SLAP */
/* routines DSDBCG and DSLUCS are examples of this procedure. */
/* Two examples of matrix data structures are the: 1) SLAP */
/* Triad format and 2) SLAP Column format. */
/* =================== S L A P Triad format =================== */
/* In this format only the non-zeros are stored. They may */
/* appear in *ANY* order. The user supplies three arrays of */
/* length NELT, where NELT is the number of non-zeros in the */
/* matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero */
/* the user puts the row and column index of that matrix */
/* element in the IA and JA arrays. The value of the non-zero */
/* matrix element is placed in the corresponding location of */
/* the A array. This is an extremely easy data structure to */
/* generate. On the other hand it is not too efficient on */
/* vector computers for the iterative solution of linear */
/* systems. Hence, SLAP changes this input data structure to */
/* the SLAP Column format for the iteration (but does not */
/* change it back). */
/* Here is an example of the SLAP Triad storage format for a */
/* 5x5 Matrix. Recall that the entries may appear in any order. */
/* 5x5 Matrix SLAP Triad format for 5x5 matrix on left. */
/* 1 2 3 4 5 6 7 8 9 10 11 */
/* |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 */
/* |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 */
/* | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 */
/* | 0 0 0 44 0| */
/* |51 0 53 0 55| */
/* =================== S L A P Column format ================== */
/* In this format the non-zeros are stored counting down */
/* columns (except for the diagonal entry, which must appear */
/* first in each "column") and are stored in the double pre- */
/* cision array A. In other words, for each column in the */
/* matrix first put the diagonal entry in A. Then put in the */
/* other non-zero elements going down the column (except the */
/* diagonal) in order. The IA array holds the row index for */
/* each non-zero. The JA array holds the offsets into the IA, */
/* A arrays for the beginning of each column. That is, */
/* IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- */
/* th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) */
/* are the last elements of the ICOL-th column. Note that we */
/* always have JA(N+1)=NELT+1, where N is the number of columns */
/* in the matrix and NELT is the number of non-zeros in the */
/* matrix. */
/* Here is an example of the SLAP Column storage format for a */
/* 5x5 Matrix (in the A and IA arrays '|' denotes the end of a */
/* column): */
/* 5x5 Matrix SLAP Column format for 5x5 matrix on left. */
/* 1 2 3 4 5 6 7 8 9 10 11 */
/* |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 */
/* |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 */
/* | 0 0 33 0 35| JA: 1 4 6 8 9 12 */
/* | 0 0 0 44 0| */
/* |51 0 53 0 55| */
/* *Cautions: */
/* This routine will attempt to write to the Fortran logical output */
/* unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that */
/* this logical unit is attached to a file or terminal before calling */
/* this routine with a non-zero value for IUNIT. This routine does */
/* not check for the validity of a non-zero IUNIT unit number. */
/* ***SEE ALSO DSDCGS, DSLUCS */
/* ***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver */
/* for nonsymmetric linear systems, Delft University */
/* of Technology Report 84-16, Department of Mathe- */
/* matics and Informatics, Delft, The Netherlands. */
/* 2. E. F. Kaasschieter, The solution of non-symmetric */
/* linear systems by biconjugate gradients or conjugate */
/* gradients squared, Delft University of Technology */
/* Report 86-21, Department of Mathematics and Informa- */
/* tics, Delft, The Netherlands. */
/* 3. Mark K. Seager, A SLAP for the Masses, in */
/* G. F. Carey, Ed., Parallel Supercomputing: Methods, */
/* Algorithms and Applications, Wiley, 1989, pp.135-155. */
/* ***ROUTINES CALLED D1MACH, DAXPY, DDOT, ISDCGS */
/* ***REVISION HISTORY (YYMMDD) */
/* 890404 DATE WRITTEN */
/* 890404 Previous REVISION DATE */
/* 890915 Made changes requested at July 1989 CML Meeting. (MKS) */
/* 890921 Removed TeX from comments. (FNF) */
/* 890922 Numerous changes to prologue to make closer to SLATEC */
/* standard. (FNF) */
/* 890929 Numerous changes to reduce SP/DP differences. (FNF) */
/* 891004 Added new reference. */
/* 910411 Prologue converted to Version 4.0 format. (BAB) */
/* 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) */
/* 920407 COMMON BLOCK renamed DSLBLK. (WRB) */
/* 920511 Added complete declaration section. (WRB) */
/* 920929 Corrected format of references. (FNF) */
/* 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) */
/* 921113 Corrected C***CATEGORY line. (FNF) */
/* ***END PROLOGUE DCGS */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Subroutine Arguments .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* ***FIRST EXECUTABLE STATEMENT DCGS */
/* Check some of the input data. */
/* Parameter adjustments */
--v2;
--v1;
--u;
--q;
--p;
--r0;
--r__;
--x;
--b;
--a;
--ja;
--ia;
--rwork;
--iwork;
/* Function Body */
*iter = 0;
*ierr = 0;
if (*n < 1) {
*ierr = 3;
return 0;
}
tolmin = d1mach_(&c__3) * 500;
if (*tol < tolmin) {
*tol = tolmin;
*ierr = 4;
}
/* Calculate initial residual and pseudo-residual, and check */
/* stopping criterion. */
(*matvec)(n, &x[1], &r__[1], nelt, &ia[1], &ja[1], &a[1], isym);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
v1[i__] = r__[i__] - b[i__];
/* L10: */
}
(*msolve)(n, &v1[1], &r__[1], nelt, &ia[1], &ja[1], &a[1], isym, &rwork[1]
, &iwork[1]);
if (isdcgs_(n, &b[1], &x[1], nelt, &ia[1], &ja[1], &a[1], isym, (S_fp)
matvec, (S_fp)msolve, itol, tol, itmax, iter, err, ierr, iunit, &
r__[1], &r0[1], &p[1], &q[1], &u[1], &v1[1], &v2[1], &rwork[1], &
iwork[1], &ak, &bk, &bnrm, &solnrm) != 0) {
goto L200;
}
if (*ierr != 0) {
return 0;
}
/* Set initial values. */
/* Computing 2nd power */
d__1 = d1mach_(&c__3);
fuzz = d__1 * d__1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
r0[i__] = r__[i__];
/* L20: */
}
rhonm1 = 1.;
/* ***** ITERATION LOOP ***** */
i__1 = *itmax;
for (k = 1; k <= i__1; ++k) {
*iter = k;
/* Calculate coefficient BK and direction vectors U, V and P. */
rhon = ddot_(n, &r0[1], &c__1, &r__[1], &c__1);
if (abs(rhonm1) < fuzz) {
goto L998;
}
bk = rhon / rhonm1;
if (*iter == 1) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__] = r__[i__];
p[i__] = r__[i__];
/* L30: */
}
} else {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__] = r__[i__] + bk * q[i__];
v1[i__] = q[i__] + bk * p[i__];
/* L40: */
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
p[i__] = u[i__] + bk * v1[i__];
/* L50: */
}
}
/* Calculate coefficient AK, new iterate X, Q */
(*matvec)(n, &p[1], &v2[1], nelt, &ia[1], &ja[1], &a[1], isym);
(*msolve)(n, &v2[1], &v1[1], nelt, &ia[1], &ja[1], &a[1], isym, &
rwork[1], &iwork[1]);
sigma = ddot_(n, &r0[1], &c__1, &v1[1], &c__1);
if (abs(sigma) < fuzz) {
goto L999;
}
ak = rhon / sigma;
akm = -ak;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
q[i__] = u[i__] + akm * v1[i__];
/* L60: */
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
v1[i__] = u[i__] + q[i__];
/* L70: */
}
/* X = X - ak*V1. */
daxpy_(n, &akm, &v1[1], &c__1, &x[1], &c__1);
/* -1 */
/* R = R - ak*M *A*V1 */
(*matvec)(n, &v1[1], &v2[1], nelt, &ia[1], &ja[1], &a[1], isym);
(*msolve)(n, &v2[1], &v1[1], nelt, &ia[1], &ja[1], &a[1], isym, &
rwork[1], &iwork[1]);
daxpy_(n, &akm, &v1[1], &c__1, &r__[1], &c__1);
/* check stopping criterion. */
if (isdcgs_(n, &b[1], &x[1], nelt, &ia[1], &ja[1], &a[1], isym, (S_fp)
matvec, (S_fp)msolve, itol, tol, itmax, iter, err, ierr,
iunit, &r__[1], &r0[1], &p[1], &q[1], &u[1], &v1[1], &v2[1], &
rwork[1], &iwork[1], &ak, &bk, &bnrm, &solnrm) != 0) {
goto L200;
}
/* Update RHO. */
rhonm1 = rhon;
/* L100: */
}
/* ***** end of loop ***** */
/* Stopping criterion not satisfied. */
*iter = *itmax + 1;
*ierr = 2;
L200:
return 0;
/* Breakdown of method detected. */
L998:
*ierr = 5;
return 0;
/* Stagnation of method detected. */
L999:
*ierr = 6;
return 0;
/* ------------- LAST LINE OF DCGS FOLLOWS ---------------------------- */
} /* dcgs_ */
/* Subroutine */ int dsytd2_(char *uplo, integer *n, doublereal *a, integer *
lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
form T by an orthogonal similarity transformation: Q' * A * Q = T.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric 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 orthogonal
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 orthogonal 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) DOUBLE PRECISION 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 real scalar, and v is a real 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 real scalar, and v is a real 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).
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b8 = 0.;
static doublereal c_b14 = -1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal taui;
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer i__;
static doublereal alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical upper;
extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *), dlarfg_(integer *, doublereal *,
doublereal *, integer *, doublereal *), xerbla_(char *, integer *
);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
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_("DSYTD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
if (upper) {
/* Reduce the upper triangle of A */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) = I - tau * v * v'
to annihilate A(1:i-1,i+1) */
dlarfg_(&i__, &a_ref(i__, i__ + 1), &a_ref(1, i__ + 1), &c__1, &
taui);
e[i__] = a_ref(i__, i__ + 1);
if (taui != 0.) {
/* Apply H(i) from both sides to A(1:i,1:i) */
a_ref(i__, i__ + 1) = 1.;
/* Compute x := tau * A * v storing x in TAU(1:i) */
dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a_ref(1, i__ +
1), &c__1, &c_b8, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a_ref(1,
i__ + 1), &c__1);
daxpy_(&i__, &alpha, &a_ref(1, i__ + 1), &c__1, &tau[1], &
c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
dsyr2_(uplo, &i__, &c_b14, &a_ref(1, i__ + 1), &c__1, &tau[1],
&c__1, &a[a_offset], lda);
a_ref(i__, i__ + 1) = e[i__];
}
d__[i__ + 1] = a_ref(i__ + 1, i__ + 1);
tau[i__] = taui;
/* L10: */
}
d__[1] = a_ref(1, 1);
} else {
/* Reduce the lower triangle of A */
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)
Computing MIN */
i__2 = i__ + 2;
i__3 = *n - i__;
dlarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(min(i__2,*n), i__), &
c__1, &taui);
e[i__] = a_ref(i__ + 1, i__);
if (taui != 0.) {
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
a_ref(i__ + 1, i__) = 1.;
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
dsymv_(uplo, &i__2, &taui, &a_ref(i__ + 1, i__ + 1), lda, &
a_ref(i__ + 1, i__), &c__1, &c_b8, &tau[i__], &c__1);
/* Compute w := x - 1/2 * tau * (x'*v) * v */
i__2 = *n - i__;
alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a_ref(
i__ + 1, i__), &c__1);
i__2 = *n - i__;
daxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &tau[i__],
&c__1);
/* Apply the transformation as a rank-2 update:
A := A - v * w' - w * v' */
i__2 = *n - i__;
dsyr2_(uplo, &i__2, &c_b14, &a_ref(i__ + 1, i__), &c__1, &tau[
i__], &c__1, &a_ref(i__ + 1, i__ + 1), lda)
;
a_ref(i__ + 1, i__) = e[i__];
}
d__[i__] = a_ref(i__, i__);
tau[i__] = taui;
/* L20: */
}
d__[*n] = a_ref(*n, *n);
}
return 0;
/* End of DSYTD2 */
} /* dsytd2_ */
/* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer j;
doublereal ajj;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
logical upper;
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPOTF2 computes the Cholesky factorization of a real symmetric */
/* positive definite matrix A. */
/* The factorization has the form */
/* A = U' * U , if UPLO = 'U', or */
/* A = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix and L is lower triangular. */
/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric 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 factor U or L from the Cholesky */
/* factorization A = U'*U or A = L*L'. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, the leading minor of order k is not */
/* positive definite, and the factorization could not be */
/* completed. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* 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_("DPOTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = j - 1;
ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j * a_dim1 + 1], &c__1,
&a[j * a_dim1 + 1], &c__1);
if (ajj <= 0. || disnan_(&ajj)) {
a[j + j * a_dim1] = ajj;
goto L30;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of row J. */
if (j < *n) {
i__2 = j - 1;
i__3 = *n - j;
dgemv_("Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1
+ 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + (
j + 1) * a_dim1], lda);
i__2 = *n - j;
d__1 = 1. / ajj;
dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = j - 1;
ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j
+ a_dim1], lda);
if (ajj <= 0. || disnan_(&ajj)) {
a[j + j * a_dim1] = ajj;
goto L30;
}
ajj = sqrt(ajj);
a[j + j * a_dim1] = ajj;
/* Compute elements J+1:N of column J. */
if (j < *n) {
i__2 = *n - j;
i__3 = j - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b10, &a[j + 1 +
a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 +
j * a_dim1], &c__1);
i__2 = *n - j;
d__1 = 1. / ajj;
dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of DPOTF2 */
} /* dpotf2_ */
void TRON::tron(double *w)
{
// Parameters for updating the iterates.
double eta0 = 1e-4, eta1 = 0.25, eta2 = 0.75;
// Parameters for updating the trust region size delta.
double sigma1 = 0.25, sigma2 = 0.5, sigma3 = 4;
Int n = fun_obj->get_nr_variable();
Int i, cg_iter;
double delta, snorm, one=1.0;
double alpha, f, fnew, prered, actred, gs;
Int search = 1, iter = 1, inc = 1;
double *s = new double[n];
double *r = new double[n];
double *g = new double[n];
// calculate gradient norm at w=0 for stopping condition.
double *w0 = new double[n];
for (i=0; i<n; i++)
w0[i] = 0;
fun_obj->fun(w0);
fun_obj->grad(w0, g);
double gnorm0 = dnrm2_(&n, g, &inc);
delete [] w0;
f = fun_obj->fun(w);
fun_obj->grad(w, g);
delta = dnrm2_(&n, g, &inc);
double gnorm = delta;
if (gnorm <= eps*gnorm0)
search = 0;
iter = 1;
double *w_new = new double[n];
while (iter <= max_iter && search)
{
cg_iter = trcg(delta, g, s, r);
memcpy(w_new, w, sizeof(double)*n);
daxpy_(&n, &one, s, &inc, w_new, &inc);
gs = ddot_(&n, g, &inc, s, &inc);
prered = -0.5*(gs-ddot_(&n, s, &inc, r, &inc));
fnew = fun_obj->fun(w_new);
// Compute the actual reduction.
actred = f - fnew;
// On the first iteration, adjust the initial step bound.
snorm = dnrm2_(&n, s, &inc);
if (iter == 1)
delta = min(delta, snorm);
// Compute prediction alpha*snorm of the step.
if (fnew - f - gs <= 0)
alpha = sigma3;
else
alpha = max(sigma1, -0.5*(gs/(fnew - f - gs)));
// Update the trust region bound according to the ratio of actual to predicted reduction.
if (actred < eta0*prered)
delta = min(max(alpha, sigma1)*snorm, sigma2*delta);
else if (actred < eta1*prered)
delta = max(sigma1*delta, min(alpha*snorm, sigma2*delta));
else if (actred < eta2*prered)
delta = max(sigma1*delta, min(alpha*snorm, sigma3*delta));
else
delta = max(delta, min(alpha*snorm, sigma3*delta));
info("iter %2d act %5.3e pre %5.3e delta %5.3e f %5.3e |g| %5.3e CG %3d\n", iter, actred, prered, delta, f, gnorm, cg_iter);
if (actred > eta0*prered)
{
iter++;
memcpy(w, w_new, sizeof(double)*n);
f = fnew;
fun_obj->grad(w, g);
gnorm = dnrm2_(&n, g, &inc);
if (gnorm <= eps*gnorm0)
break;
}
if (f < -1.0e+32)
{
info("WARNING: f < -1.0e+32\n");
break;
}
if (fabs(actred) <= 0 && prered <= 0)
{
info("WARNING: actred and prered <= 0\n");
break;
}
if (fabs(actred) <= 1.0e-12*fabs(f) &&
fabs(prered) <= 1.0e-12*fabs(f))
{
info("WARNING: actred and prered too small\n");
break;
}
}
delete[] g;
delete[] r;
delete[] w_new;
delete[] s;
}
/* DECK DBOLSM */
/* Subroutine */ int dbolsm_(doublereal *w, integer *mdw, integer *minput,
integer *ncols, doublereal *bl, doublereal *bu, integer *ind, integer
*iopt, doublereal *x, doublereal *rnorm, integer *mode, doublereal *
rw, doublereal *ww, doublereal *scl, integer *ibasis, integer *ibb)
{
/* System generated locals */
address a__1[3], a__2[4], a__3[6], a__4[5], a__5[2], a__6[7];
integer w_dim1, w_offset, i__1[3], i__2[4], i__3, i__4[6], i__5[5], i__6[
2], i__7[7], i__8, i__9, i__10;
doublereal d__1, d__2;
char ch__1[47], ch__2[50], ch__3[79], ch__4[53], ch__5[94], ch__6[75],
ch__7[83], ch__8[92], ch__9[105], ch__10[102], ch__11[61], ch__12[
110], ch__13[134], ch__14[44], ch__15[76];
/* Local variables */
static integer i__, j;
static doublereal t, t1, t2, sc;
static integer ip, jp, lp;
static doublereal ss, wt, cl1, cl2, cl3, fac, big;
static integer lds;
static doublereal bou, beta;
static integer jbig, jmag, ioff, jcol;
static doublereal wbig;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal wmag;
static integer mval, iter;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal xnew;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static char xern1[8], xern2[8], xern3[16], xern4[16];
static doublereal alpha;
static logical found;
static integer nsetb;
extern /* Subroutine */ int drotg_(doublereal *, doublereal *, doublereal
*, doublereal *), dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer igopr, itmax, itemp;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer lgopr;
extern /* Subroutine */ int dmout_(integer *, integer *, integer *,
doublereal *, char *, integer *, ftnlen);
static integer jdrop;
extern doublereal d1mach_(integer *);
extern /* Subroutine */ int dvout_(integer *, doublereal *, char *,
integer *, ftnlen), ivout_(integer *, integer *, char *, integer *
, ftnlen);
static integer mrows, jdrop1, jdrop2, jlarge;
static doublereal colabv, colblo, wlarge, tolind;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static integer iprint;
static logical constr;
static doublereal tolsze;
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___3 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___8 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___9 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___10 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___12 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___14 = { 0, xern4, 0, "(1PD15.6)", 16, 1 };
static icilist io___15 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___16 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___17 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___18 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___31 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___32 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___33 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___34 = { 0, xern4, 0, "(1PD15.6)", 16, 1 };
static icilist io___35 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___36 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___37 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___38 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___39 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___40 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___41 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___42 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___43 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___44 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___45 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___54 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE DBOLSM */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DBOCLS and DBOLS */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SBOLSM-S, DBOLSM-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* **** Double Precision Version of SBOLSM **** */
/* **** All INPUT and OUTPUT real variables are DOUBLE PRECISION **** */
/* Solve E*X = F (least squares sense) with bounds on */
/* selected X values. */
/* The user must have DIMENSION statements of the form: */
/* DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS), */
/* * X(NCOLS+NX), RW(NCOLS), WW(NCOLS), SCL(NCOLS) */
/* INTEGER IND(NCOLS), IOPT(1+NI), IBASIS(NCOLS), IBB(NCOLS) */
/* (Here NX=number of extra locations required for options 1,...,7; */
/* NX=0 for no options; here NI=number of extra locations possibly */
/* required for options 1-7; NI=0 for no options; NI=14 if all the */
/* options are simultaneously in use.) */
/* INPUT */
/* ----- */
/* -------------------- */
/* W(MDW,*),MINPUT,NCOLS */
/* -------------------- */
/* The array W(*,*) contains the matrix [E:F] on entry. The matrix */
/* [E:F] has MINPUT rows and NCOLS+1 columns. This data is placed in */
/* the array W(*,*) with E occupying the first NCOLS columns and the */
/* right side vector F in column NCOLS+1. The row dimension, MDW, of */
/* the array W(*,*) must satisfy the inequality MDW .ge. MINPUT. */
/* Other values of MDW are errors. The values of MINPUT and NCOLS */
/* must be positive. Other values are errors. */
/* ------------------ */
/* BL(*),BU(*),IND(*) */
/* ------------------ */
/* These arrays contain the information about the bounds that the */
/* solution values are to satisfy. The value of IND(J) tells the */
/* type of bound and BL(J) and BU(J) give the explicit values for */
/* the respective upper and lower bounds. */
/* 1. For IND(J)=1, require X(J) .ge. BL(J). */
/* 2. For IND(J)=2, require X(J) .le. BU(J). */
/* 3. For IND(J)=3, require X(J) .ge. BL(J) and */
/* X(J) .le. BU(J). */
/* 4. For IND(J)=4, no bounds on X(J) are required. */
/* The values of BL(*),BL(*) are modified by the subprogram. Values */
/* other than 1,2,3 or 4 for IND(J) are errors. In the case IND(J)=3 */
/* (upper and lower bounds) the condition BL(J) .gt. BU(J) is an */
/* error. */
/* ------- */
/* IOPT(*) */
/* ------- */
/* This is the array where the user can specify nonstandard options */
/* for DBOLSM. Most of the time this feature can be ignored by */
/* setting the input value IOPT(1)=99. Occasionally users may have */
/* needs that require use of the following subprogram options. For */
/* details about how to use the options see below: IOPT(*) CONTENTS. */
/* Option Number Brief Statement of Purpose */
/* ----- ------ ----- --------- -- ------- */
/* 1 Move the IOPT(*) processing pointer. */
/* 2 Change rank determination tolerance. */
/* 3 Change blow-up factor that determines the */
/* size of variables being dropped from active */
/* status. */
/* 4 Reset the maximum number of iterations to use */
/* in solving the problem. */
/* 5 The data matrix is triangularized before the */
/* problem is solved whenever (NCOLS/MINPUT) .lt. */
/* FAC. Change the value of FAC. */
/* 6 Redefine the weighting matrix used for */
/* linear independence checking. */
/* 7 Debug output is desired. */
/* 99 No more options to change. */
/* ---- */
/* X(*) */
/* ---- */
/* This array is used to pass data associated with options 1,2,3 and */
/* 5. Ignore this input parameter if none of these options are used. */
/* Otherwise see below: IOPT(*) CONTENTS. */
/* ---------------- */
/* IBASIS(*),IBB(*) */
/* ---------------- */
/* These arrays must be initialized by the user. The values */
/* IBASIS(J)=J, J=1,...,NCOLS */
/* IBB(J) =1, J=1,...,NCOLS */
/* are appropriate except when using nonstandard features. */
/* ------ */
/* SCL(*) */
/* ------ */
/* This is the array of scaling factors to use on the columns of the */
/* matrix E. These values must be defined by the user. To suppress */
/* any column scaling set SCL(J)=1.0, J=1,...,NCOLS. */
/* OUTPUT */
/* ------ */
/* ---------- */
/* X(*),RNORM */
/* ---------- */
/* The array X(*) contains a solution (if MODE .ge. 0 or .eq. -22) */
/* for the constrained least squares problem. The value RNORM is the */
/* minimum residual vector length. */
/* ---- */
/* MODE */
/* ---- */
/* The sign of mode determines whether the subprogram has completed */
/* normally, or encountered an error condition or abnormal status. */
/* A value of MODE .ge. 0 signifies that the subprogram has completed */
/* normally. The value of MODE (.ge. 0) is the number of variables */
/* in an active status: not at a bound nor at the value ZERO, for */
/* the case of free variables. A negative value of MODE will be one */
/* of the 18 cases -38,-37,...,-22, or -1. Values .lt. -1 correspond */
/* to an abnormal completion of the subprogram. To understand the */
/* abnormal completion codes see below: ERROR MESSAGES for DBOLSM */
/* An approximate solution will be returned to the user only when */
/* maximum iterations is reached, MODE=-22. */
/* ----------- */
/* RW(*),WW(*) */
/* ----------- */
/* These are working arrays each with NCOLS entries. The array RW(*) */
/* contains the working (scaled, nonactive) solution values. The */
/* array WW(*) contains the working (scaled, active) gradient vector */
/* values. */
/* ---------------- */
/* IBASIS(*),IBB(*) */
/* ---------------- */
/* These arrays contain information about the status of the solution */
/* when MODE .ge. 0. The indices IBASIS(K), K=1,...,MODE, show the */
/* nonactive variables; indices IBASIS(K), K=MODE+1,..., NCOLS are */
/* the active variables. The value (IBB(J)-1) is the number of times */
/* variable J was reflected from its upper bound. (Normally the user */
/* can ignore these parameters.) */
/* IOPT(*) CONTENTS */
/* ------- -------- */
/* The option array allows a user to modify internal variables in */
/* the subprogram without recompiling the source code. A central */
/* goal of the initial software design was to do a good job for most */
/* people. Thus the use of options will be restricted to a select */
/* group of users. The processing of the option array proceeds as */
/* follows: a pointer, here called LP, is initially set to the value */
/* 1. The value is updated as the options are processed. At the */
/* pointer position the option number is extracted and used for */
/* locating other information that allows for options to be changed. */
/* The portion of the array IOPT(*) that is used for each option is */
/* fixed; the user and the subprogram both know how many locations */
/* are needed for each option. A great deal of error checking is */
/* done by the subprogram on the contents of the option array. */
/* Nevertheless it is still possible to give the subprogram optional */
/* input that is meaningless. For example, some of the options use */
/* the location X(NCOLS+IOFF) for passing data. The user must manage */
/* the allocation of these locations when more than one piece of */
/* option data is being passed to the subprogram. */
/* 1 */
/* - */
/* Move the processing pointer (either forward or backward) to the */
/* location IOPT(LP+1). The processing pointer is moved to location */
/* LP+2 of IOPT(*) in case IOPT(LP)=-1. For example to skip over */
/* locations 3,...,NCOLS+2 of IOPT(*), */
/* IOPT(1)=1 */
/* IOPT(2)=NCOLS+3 */
/* (IOPT(I), I=3,...,NCOLS+2 are not defined here.) */
/* IOPT(NCOLS+3)=99 */
/* CALL DBOLSM */
/* CAUTION: Misuse of this option can yield some very hard-to-find */
/* bugs. Use it with care. */
/* 2 */
/* - */
/* The algorithm that solves the bounded least squares problem */
/* iteratively drops columns from the active set. This has the */
/* effect of joining a new column vector to the QR factorization of */
/* the rectangular matrix consisting of the partially triangularized */
/* nonactive columns. After triangularizing this matrix a test is */
/* made on the size of the pivot element. The column vector is */
/* rejected as dependent if the magnitude of the pivot element is */
/* .le. TOL* magnitude of the column in components strictly above */
/* the pivot element. Nominally the value of this (rank) tolerance */
/* is TOL = SQRT(R1MACH(4)). To change only the value of TOL, for */
/* example, */
/* X(NCOLS+1)=TOL */
/* IOPT(1)=2 */
/* IOPT(2)=1 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=TOL */
/* IOPT(LP)=2 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The required length of IOPT(*) is increased by 2 if option 2 is */
/* used; The required length of X(*) is increased by 1. A value of */
/* IOFF .le. 0 is an error. A value of TOL .le. R1MACH(4) gives a */
/* warning message; it is not considered an error. */
/* 3 */
/* - */
/* A solution component is left active (not used) if, roughly */
/* speaking, it seems too large. Mathematically the new component is */
/* left active if the magnitude is .ge.((vector norm of F)/(matrix */
/* norm of E))/BLOWUP. Nominally the factor BLOWUP = SQRT(R1MACH(4)). */
/* To change only the value of BLOWUP, for example, */
/* X(NCOLS+2)=BLOWUP */
/* IOPT(1)=3 */
/* IOPT(2)=2 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=BLOWUP */
/* IOPT(LP)=3 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The required length of IOPT(*) is increased by 2 if option 3 is */
/* used; the required length of X(*) is increased by 1. A value of */
/* IOFF .le. 0 is an error. A value of BLOWUP .le. 0.0 is an error. */
/* 4 */
/* - */
/* Normally the algorithm for solving the bounded least squares */
/* problem requires between NCOLS/3 and NCOLS drop-add steps to */
/* converge. (this remark is based on examining a small number of */
/* test cases.) The amount of arithmetic for such problems is */
/* typically about twice that required for linear least squares if */
/* there are no bounds and if plane rotations are used in the */
/* solution method. Convergence of the algorithm, while */
/* mathematically certain, can be much slower than indicated. To */
/* avoid this potential but unlikely event ITMAX drop-add steps are */
/* permitted. Nominally ITMAX=5*(MAX(MINPUT,NCOLS)). To change the */
/* value of ITMAX, for example, */
/* IOPT(1)=4 */
/* IOPT(2)=ITMAX */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* IOPT(LP)=4 */
/* IOPT(LP+1)=ITMAX */
/* . */
/* CALL DBOLSM */
/* The value of ITMAX must be .gt. 0. Other values are errors. Use */
/* of this option increases the required length of IOPT(*) by 2. */
/* 5 */
/* - */
/* For purposes of increased efficiency the MINPUT by NCOLS+1 data */
/* matrix [E:F] is triangularized as a first step whenever MINPUT */
/* satisfies FAC*MINPUT .gt. NCOLS. Nominally FAC=0.75. To change the */
/* value of FAC, */
/* X(NCOLS+3)=FAC */
/* IOPT(1)=5 */
/* IOPT(2)=3 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=FAC */
/* IOPT(LP)=5 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The value of FAC must be nonnegative. Other values are errors. */
/* Resetting FAC=0.0 suppresses the initial triangularization step. */
/* Use of this option increases the required length of IOPT(*) by 2; */
/* The required length of of X(*) is increased by 1. */
/* 6 */
/* - */
/* The norm used in testing the magnitudes of the pivot element */
/* compared to the mass of the column above the pivot line can be */
/* changed. The type of change that this option allows is to weight */
/* the components with an index larger than MVAL by the parameter */
/* WT. Normally MVAL=0 and WT=1. To change both the values MVAL and */
/* WT, where LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=WT */
/* IOPT(LP)=6 */
/* IOPT(LP+1)=IOFF */
/* IOPT(LP+2)=MVAL */
/* Use of this option increases the required length of IOPT(*) by 3. */
/* The length of X(*) is increased by 1. Values of MVAL must be */
/* nonnegative and not greater than MINPUT. Other values are errors. */
/* The value of WT must be positive. Any other value is an error. If */
/* either error condition is present a message will be printed. */
/* 7 */
/* - */
/* Debug output, showing the detailed add-drop steps for the */
/* constrained least squares problem, is desired. This option is */
/* intended to be used to locate suspected bugs. */
/* 99 */
/* -- */
/* There are no more options to change. */
/* The values for options are 1,...,7,99, and are the only ones */
/* permitted. Other values are errors. Options -99,-1,...,-7 mean */
/* that the repective options 99,1,...,7 are left at their default */
/* values. An example is the option to modify the (rank) tolerance: */
/* X(NCOLS+1)=TOL */
/* IOPT(1)=-2 */
/* IOPT(2)=1 */
/* IOPT(3)=99 */
/* Error Messages for DBOLSM */
/* ----- -------- --- --------- */
/* -22 MORE THAN ITMAX = ... ITERATIONS SOLVING BOUNDED LEAST */
/* SQUARES PROBLEM. */
/* -23 THE OPTION NUMBER = ... IS NOT DEFINED. */
/* -24 THE OFFSET = ... BEYOND POSTION NCOLS = ... MUST BE POSITIVE */
/* FOR OPTION NUMBER 2. */
/* -25 THE TOLERANCE FOR RANK DETERMINATION = ... IS LESS THAN */
/* MACHINE PRECISION = .... */
/* -26 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE */
/* FOR OPTION NUMBER 3. */
/* -27 THE RECIPROCAL OF THE BLOW-UP FACTOR FOR REJECTING VARIABLES */
/* MUST BE POSITIVE. NOW = .... */
/* -28 THE MAXIMUM NUMBER OF ITERATIONS = ... MUST BE POSITIVE. */
/* -29 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE */
/* FOR OPTION NUMBER 5. */
/* -30 THE FACTOR (NCOLS/MINPUT) WHERE PRETRIANGULARIZING IS */
/* PERFORMED MUST BE NONNEGATIVE. NOW = .... */
/* -31 THE NUMBER OF ROWS = ... MUST BE POSITIVE. */
/* -32 THE NUMBER OF COLUMNS = ... MUST BE POSTIVE. */
/* -33 THE ROW DIMENSION OF W(,) = ... MUST BE .GE. THE NUMBER OF */
/* ROWS = .... */
/* -34 FOR J = ... THE CONSTRAINT INDICATOR MUST BE 1-4. */
/* -35 FOR J = ... THE LOWER BOUND = ... IS .GT. THE UPPER BOUND = */
/* .... */
/* -36 THE INPUT ORDER OF COLUMNS = ... IS NOT BETWEEN 1 AND NCOLS */
/* = .... */
/* -37 THE BOUND POLARITY FLAG IN COMPONENT J = ... MUST BE */
/* POSITIVE. NOW = .... */
/* -38 THE ROW SEPARATOR TO APPLY WEIGHTING (...) MUST LIE BETWEEN */
/* 0 AND MINPUT = .... WEIGHT = ... MUST BE POSITIVE. */
/* ***SEE ALSO DBOCLS, DBOLS */
/* ***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, DMOUT, DNRM2, DROT, */
/* DROTG, DSWAP, DVOUT, IVOUT, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 821220 DATE WRITTEN */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 920422 Fixed usage of MINPUT. (WRB) */
/* 901009 Editorial changes, code now reads from top to bottom. (RWC) */
/* ***END PROLOGUE DBOLSM */
/* PURPOSE */
/* ------- */
/* THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE BOUNDED */
/* LEAST SQUARES PROBLEM. THE PROBLEM SOLVED HERE IS: */
/* SOLVE E*X = F (LEAST SQUARES SENSE) */
/* WITH BOUNDS ON SELECTED X VALUES. */
/* TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN */
/* EDITING AT THE CARD 'C++'. */
/* CHANGE THE SUBPROGRAM NAME TO DBOLSM AND THE STRINGS */
/* /SAXPY/ TO /DAXPY/, /SCOPY/ TO /DCOPY/, */
/* /SDOT/ TO /DDOT/, /SNRM2/ TO /DNRM2/, */
/* /SROT/ TO /DROT/, /SROTG/ TO /DROTG/, /R1MACH/ TO /D1MACH/, */
/* /SVOUT/ TO /DVOUT/, /SMOUT/ TO /DMOUT/, */
/* /SSWAP/ TO /DSWAP/, /E0/ TO /D0/, */
/* /REAL / TO /DOUBLE PRECISION/. */
/* ++ */
/* ***FIRST EXECUTABLE STATEMENT DBOLSM */
/* Verify that the problem dimensions are defined properly. */
/* Parameter adjustments */
w_dim1 = *mdw;
w_offset = 1 + w_dim1;
w -= w_offset;
--bl;
--bu;
--ind;
--iopt;
--x;
--rw;
--ww;
--scl;
--ibasis;
--ibb;
/* Function Body */
if (*minput <= 0) {
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 21, a__1[0] = "THE NUMBER OF ROWS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)47);
xermsg_("SLATEC", "DBOLSM", ch__1, &c__31, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)47);
*mode = -31;
return 0;
}
if (*ncols <= 0) {
s_wsfi(&io___3);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 24, a__1[0] = "THE NUMBER OF COLUMNS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)50);
xermsg_("SLATEC", "DBOLSM", ch__2, &c__32, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)50);
*mode = -32;
return 0;
}
if (*mdw < *minput) {
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*mdw), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 28, a__2[0] = "THE ROW DIMENSION OF W(,) = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 35, a__2[2] = " MUST BE .GE. THE NUMBER OF ROWS = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__3, a__2, i__2, &c__4, (ftnlen)79);
xermsg_("SLATEC", "DBOLSM", ch__3, &c__33, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)79);
*mode = -33;
return 0;
}
/* Verify that bound information is correct. */
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] < 1 || ind[j] > 4) {
s_wsfi(&io___8);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___9);
do_fio(&c__1, (char *)&ind[j], (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 8, a__1[0] = "FOR J = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 37, a__1[2] = " THE CONSTRAINT INDICATOR MUST BE 1-4";
s_cat(ch__4, a__1, i__1, &c__3, (ftnlen)53);
xermsg_("SLATEC", "DBOLSM", ch__4, &c__34, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)53);
*mode = -34;
return 0;
}
/* L10: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] == 3) {
if (bu[j] < bl[j]) {
s_wsfi(&io___10);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___12);
do_fio(&c__1, (char *)&bl[j], (ftnlen)sizeof(doublereal));
e_wsfi();
s_wsfi(&io___14);
do_fio(&c__1, (char *)&bu[j], (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__4[0] = 8, a__3[0] = "FOR J = ";
i__4[1] = 8, a__3[1] = xern1;
i__4[2] = 19, a__3[2] = " THE LOWER BOUND = ";
i__4[3] = 16, a__3[3] = xern3;
i__4[4] = 27, a__3[4] = " IS .GT. THE UPPER BOUND = ";
i__4[5] = 16, a__3[5] = xern4;
s_cat(ch__5, a__3, i__4, &c__6, (ftnlen)94);
xermsg_("SLATEC", "DBOLSM", ch__5, &c__35, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)94);
*mode = -35;
return 0;
}
}
/* L20: */
}
/* Check that permutation and polarity arrays have been set. */
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ibasis[j] < 1 || ibasis[j] > *ncols) {
s_wsfi(&io___15);
do_fio(&c__1, (char *)&ibasis[j], (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___16);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 29, a__2[0] = "THE INPUT ORDER OF COLUMNS = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 30, a__2[2] = " IS NOT BETWEEN 1 AND NCOLS = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__6, a__2, i__2, &c__4, (ftnlen)75);
xermsg_("SLATEC", "DBOLSM", ch__6, &c__36, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)75);
*mode = -36;
return 0;
}
if (ibb[j] <= 0) {
s_wsfi(&io___17);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___18);
do_fio(&c__1, (char *)&ibb[j], (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 41, a__2[0] = "THE BOUND POLARITY FLAG IN COMPONENT J "
"= ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 26, a__2[2] = " MUST BE POSITIVE.$$NOW = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__7, a__2, i__2, &c__4, (ftnlen)83);
xermsg_("SLATEC", "DBOLSM", ch__7, &c__37, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)83);
*mode = -37;
return 0;
}
/* L30: */
}
/* Process the option array. */
fac = .75;
tolind = sqrt(d1mach_(&c__4));
tolsze = sqrt(d1mach_(&c__4));
itmax = max(*minput,*ncols) * 5;
wt = 1.;
mval = 0;
iprint = 0;
/* Changes to some parameters can occur through the option array, */
/* IOPT(*). Process this array looking carefully for input data */
/* errors. */
lp = 0;
lds = 0;
/* Test for no more options. */
L590:
lp += lds;
ip = iopt[lp + 1];
jp = abs(ip);
if (ip == 99) {
goto L470;
} else if (jp == 99) {
lds = 1;
} else if (jp == 1) {
/* Move the IOPT(*) processing pointer. */
if (ip > 0) {
lp = iopt[lp + 2] - 1;
lds = 0;
} else {
lds = 2;
}
} else if (jp == 2) {
/* Change tolerance for rank determination. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___31);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___32);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 2.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__24, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -24;
return 0;
}
tolind = x[*ncols + ioff];
if (tolind < d1mach_(&c__4)) {
s_wsfi(&io___33);
do_fio(&c__1, (char *)&tolind, (ftnlen)sizeof(doublereal));
e_wsfi();
s_wsfi(&io___34);
d__1 = d1mach_(&c__4);
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__2[0] = 39, a__2[0] = "THE TOLERANCE FOR RANK DETERMINATIO"
"N = ";
i__2[1] = 16, a__2[1] = xern3;
i__2[2] = 34, a__2[2] = " IS LESS THAN MACHINE PRECISION = ";
i__2[3] = 16, a__2[3] = xern4;
s_cat(ch__9, a__2, i__2, &c__4, (ftnlen)105);
xermsg_("SLATEC", "DBOLSM", ch__9, &c__25, &c__0, (ftnlen)6, (
ftnlen)6, (ftnlen)105);
*mode = -25;
}
}
lds = 2;
} else if (jp == 3) {
/* Change blowup factor for allowing variables to become */
/* inactive. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___35);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___36);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 3.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__26, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -26;
return 0;
}
tolsze = x[*ncols + ioff];
if (tolsze <= 0.) {
s_wsfi(&io___37);
do_fio(&c__1, (char *)&tolsze, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__6[0] = 86, a__5[0] = "THE RECIPROCAL OF THE BLOW-UP FACTO"
"R FOR REJECTING VARIABLES MUST BE POSITIVE.$$NOW = ";
i__6[1] = 16, a__5[1] = xern3;
s_cat(ch__10, a__5, i__6, &c__2, (ftnlen)102);
xermsg_("SLATEC", "DBOLSM", ch__10, &c__27, &c__1, (ftnlen)6,
(ftnlen)6, (ftnlen)102);
*mode = -27;
return 0;
}
}
lds = 2;
} else if (jp == 4) {
/* Change the maximum number of iterations allowed. */
if (ip > 0) {
itmax = iopt[lp + 2];
if (itmax <= 0) {
s_wsfi(&io___38);
do_fio(&c__1, (char *)&itmax, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 35, a__1[0] = "THE MAXIMUM NUMBER OF ITERATIONS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__11, a__1, i__1, &c__3, (ftnlen)61);
xermsg_("SLATEC", "DBOLSM", ch__11, &c__28, &c__1, (ftnlen)6,
(ftnlen)6, (ftnlen)61);
*mode = -28;
return 0;
}
}
lds = 2;
} else if (jp == 5) {
/* Change the factor for pretriangularizing the data matrix. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___39);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___40);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 5.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__29, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -29;
return 0;
}
fac = x[*ncols + ioff];
if (fac < 0.) {
s_wsfi(&io___41);
do_fio(&c__1, (char *)&fac, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__6[0] = 94, a__5[0] = "THE FACTOR (NCOLS/MINPUT) WHERE PRE"
"-TRIANGULARIZING IS PERFORMED MUST BE NON-NEGATIVE.$"
"$NOW = ";
i__6[1] = 16, a__5[1] = xern3;
s_cat(ch__12, a__5, i__6, &c__2, (ftnlen)110);
xermsg_("SLATEC", "DBOLSM", ch__12, &c__30, &c__0, (ftnlen)6,
(ftnlen)6, (ftnlen)110);
*mode = -30;
return 0;
}
}
lds = 2;
} else if (jp == 6) {
/* Change the weighting factor (from 1.0) to apply to components */
/* numbered .gt. MVAL (initially set to 1.) This trick is needed */
/* for applications of this subprogram to the heavily weighted */
/* least squares problem that come from equality constraints. */
if (ip > 0) {
ioff = iopt[lp + 2];
mval = iopt[lp + 3];
wt = x[*ncols + ioff];
}
if (mval < 0 || mval > *minput || wt <= 0.) {
s_wsfi(&io___42);
do_fio(&c__1, (char *)&mval, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___43);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___44);
do_fio(&c__1, (char *)&wt, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__7[0] = 38, a__6[0] = "THE ROW SEPARATOR TO APPLY WEIGHTING (";
i__7[1] = 8, a__6[1] = xern1;
i__7[2] = 34, a__6[2] = ") MUST LIE BETWEEN 0 AND MINPUT = ";
i__7[3] = 8, a__6[3] = xern2;
i__7[4] = 12, a__6[4] = ".$$WEIGHT = ";
i__7[5] = 16, a__6[5] = xern3;
i__7[6] = 18, a__6[6] = " MUST BE POSITIVE.";
s_cat(ch__13, a__6, i__7, &c__7, (ftnlen)134);
xermsg_("SLATEC", "DBOLSM", ch__13, &c__38, &c__0, (ftnlen)6, (
ftnlen)6, (ftnlen)134);
*mode = -38;
return 0;
}
lds = 3;
} else if (jp == 7) {
/* Turn on debug output. */
if (ip > 0) {
iprint = 1;
}
lds = 2;
} else {
s_wsfi(&io___45);
do_fio(&c__1, (char *)&ip, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 20, a__1[0] = "THE OPTION NUMBER = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 16, a__1[2] = " IS NOT DEFINED.";
s_cat(ch__14, a__1, i__1, &c__3, (ftnlen)44);
xermsg_("SLATEC", "DBOLSM", ch__14, &c__23, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)44);
*mode = -23;
return 0;
}
goto L590;
/* Pretriangularize rectangular arrays of certain sizes for */
/* increased efficiency. */
L470:
if (fac * *minput > (doublereal) (*ncols)) {
i__3 = *ncols + 1;
for (j = 1; j <= i__3; ++j) {
i__8 = j + mval + 1;
for (i__ = *minput; i__ >= i__8; --i__) {
drotg_(&w[i__ - 1 + j * w_dim1], &w[i__ + j * w_dim1], &sc, &
ss);
w[i__ + j * w_dim1] = 0.;
i__9 = *ncols - j + 1;
drot_(&i__9, &w[i__ - 1 + (j + 1) * w_dim1], mdw, &w[i__ + (j
+ 1) * w_dim1], mdw, &sc, &ss);
/* L480: */
}
/* L490: */
}
mrows = *ncols + mval + 1;
} else {
mrows = *minput;
}
/* Set the X(*) array to zero so all components are defined. */
dcopy_(ncols, &c_b185, &c__0, &x[1], &c__1);
/* The arrays IBASIS(*) and IBB(*) are initialized by the calling */
/* program and the column scaling is defined in the calling program. */
/* 'BIG' is plus infinity on this machine. */
big = d1mach_(&c__2);
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] == 1) {
bu[j] = big;
} else if (ind[j] == 2) {
bl[j] = -big;
} else if (ind[j] == 4) {
bl[j] = -big;
bu[j] = big;
}
/* L550: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (bl[j] <= 0. && 0. <= bu[j] && (d__1 = bu[j], abs(d__1)) < (d__2 =
bl[j], abs(d__2)) || bu[j] < 0.) {
t = bu[j];
bu[j] = -bl[j];
bl[j] = -t;
scl[j] = -scl[j];
i__8 = mrows;
for (i__ = 1; i__ <= i__8; ++i__) {
w[i__ + j * w_dim1] = -w[i__ + j * w_dim1];
/* L560: */
}
}
/* Indices in set T(=TIGHT) are denoted by negative values */
/* of IBASIS(*). */
if (bl[j] >= 0.) {
ibasis[j] = -ibasis[j];
t = -bl[j];
bu[j] += t;
daxpy_(&mrows, &t, &w[j * w_dim1 + 1], &c__1, &w[(*ncols + 1) *
w_dim1 + 1], &c__1);
}
/* L570: */
}
nsetb = 0;
iter = 0;
if (iprint > 0) {
i__3 = *ncols + 1;
dmout_(&mrows, &i__3, mdw, &w[w_offset], "(' PRETRI. INPUT MATRIX')",
&c_n4, (ftnlen)25);
dvout_(ncols, &bl[1], "(' LOWER BOUNDS')", &c_n4, (ftnlen)17);
dvout_(ncols, &bu[1], "(' UPPER BOUNDS')", &c_n4, (ftnlen)17);
}
L580:
++iter;
if (iter > itmax) {
s_wsfi(&io___54);
do_fio(&c__1, (char *)&itmax, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 18, a__1[0] = "MORE THAN ITMAX = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 50, a__1[2] = " ITERATIONS SOLVING BOUNDED LEAST SQUARES P"
"ROBLEM.";
s_cat(ch__15, a__1, i__1, &c__3, (ftnlen)76);
xermsg_("SLATEC", "DBOLSM", ch__15, &c__22, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)76);
*mode = -22;
/* Rescale and translate variables. */
igopr = 1;
goto L130;
}
/* Find a variable to become non-active. */
/* T */
/* Compute (negative) of gradient vector, W = E *(F-E*X). */
dcopy_(ncols, &c_b185, &c__0, &ww[1], &c__1);
i__3 = *ncols;
for (j = nsetb + 1; j <= i__3; ++j) {
jcol = (i__8 = ibasis[j], abs(i__8));
i__8 = mrows - nsetb;
/* Computing MIN */
i__9 = nsetb + 1;
/* Computing MIN */
i__10 = nsetb + 1;
ww[j] = ddot_(&i__8, &w[min(i__9,mrows) + j * w_dim1], &c__1, &w[min(
i__10,mrows) + (*ncols + 1) * w_dim1], &c__1) * (d__1 = scl[
jcol], abs(d__1));
/* L200: */
}
if (iprint > 0) {
dvout_(ncols, &ww[1], "(' GRADIENT VALUES')", &c_n4, (ftnlen)20);
ivout_(ncols, &ibasis[1], "(' INTERNAL VARIABLE ORDER')", &c_n4, (
ftnlen)28);
ivout_(ncols, &ibb[1], "(' BOUND POLARITY')", &c_n4, (ftnlen)19);
}
/* If active set = number of total rows, quit. */
L210:
if (nsetb == mrows) {
found = FALSE_;
goto L120;
}
/* Choose an extremal component of gradient vector for a candidate */
/* to become non-active. */
wlarge = -big;
wmag = -big;
i__3 = *ncols;
for (j = nsetb + 1; j <= i__3; ++j) {
t = ww[j];
if (t == big) {
goto L220;
}
itemp = ibasis[j];
jcol = abs(itemp);
i__8 = mval - nsetb;
/* Computing MIN */
i__9 = nsetb + 1;
t1 = dnrm2_(&i__8, &w[min(i__9,mrows) + j * w_dim1], &c__1);
if (itemp < 0) {
if (ibb[jcol] % 2 == 0) {
t = -t;
}
if (t < 0.) {
goto L220;
}
if (mval > nsetb) {
t = t1;
}
if (t > wlarge) {
wlarge = t;
jlarge = j;
}
} else {
if (mval > nsetb) {
t = t1;
}
if (abs(t) > wmag) {
wmag = abs(t);
jmag = j;
}
}
L220:
;
}
/* Choose magnitude of largest component of gradient for candidate. */
jbig = 0;
wbig = 0.;
if (wlarge > 0.) {
jbig = jlarge;
wbig = wlarge;
}
if (wmag >= wbig) {
jbig = jmag;
wbig = wmag;
}
if (jbig == 0) {
found = FALSE_;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' FOUND NO VARIABLE TO ENTER')", &c_n4, (
ftnlen)31);
}
goto L120;
}
/* See if the incoming column is sufficiently independent. This */
/* test is made before an elimination is performed. */
if (iprint > 0) {
ivout_(&c__1, &jbig, "(' TRY TO BRING IN THIS COL.')", &c_n4, (ftnlen)
30);
}
if (mval <= nsetb) {
cl1 = dnrm2_(&mval, &w[jbig * w_dim1 + 1], &c__1);
i__3 = nsetb - mval;
/* Computing MIN */
i__8 = mval + 1;
cl2 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
i__3 = mrows - nsetb;
/* Computing MIN */
i__8 = nsetb + 1;
cl3 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
drotg_(&cl1, &cl2, &sc, &ss);
colabv = abs(cl1);
colblo = cl3;
} else {
cl1 = dnrm2_(&nsetb, &w[jbig * w_dim1 + 1], &c__1);
i__3 = mval - nsetb;
/* Computing MIN */
i__8 = nsetb + 1;
cl2 = dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &c__1);
i__3 = mrows - mval;
/* Computing MIN */
i__8 = mval + 1;
cl3 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
colabv = cl1;
drotg_(&cl2, &cl3, &sc, &ss);
colblo = abs(cl2);
}
if (colblo <= tolind * colabv) {
ww[jbig] = big;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' VARIABLE IS DEPENDENT, NOT USED.')", &
c_n4, (ftnlen)37);
}
goto L210;
}
/* Swap matrix columns NSETB+1 and JBIG, plus pointer information, */
/* and gradient values. */
++nsetb;
if (nsetb != jbig) {
dswap_(&mrows, &w[nsetb * w_dim1 + 1], &c__1, &w[jbig * w_dim1 + 1], &
c__1);
dswap_(&c__1, &ww[nsetb], &c__1, &ww[jbig], &c__1);
itemp = ibasis[nsetb];
ibasis[nsetb] = ibasis[jbig];
ibasis[jbig] = itemp;
}
/* Eliminate entries below the pivot line in column NSETB. */
if (mrows > nsetb) {
i__3 = nsetb + 1;
for (i__ = mrows; i__ >= i__3; --i__) {
if (i__ == mval + 1) {
goto L230;
}
drotg_(&w[i__ - 1 + nsetb * w_dim1], &w[i__ + nsetb * w_dim1], &
sc, &ss);
w[i__ + nsetb * w_dim1] = 0.;
i__8 = *ncols - nsetb + 1;
drot_(&i__8, &w[i__ - 1 + (nsetb + 1) * w_dim1], mdw, &w[i__ + (
nsetb + 1) * w_dim1], mdw, &sc, &ss);
L230:
;
}
if (mval >= nsetb && mval < mrows) {
drotg_(&w[nsetb + nsetb * w_dim1], &w[mval + 1 + nsetb * w_dim1],
&sc, &ss);
w[mval + 1 + nsetb * w_dim1] = 0.;
i__3 = *ncols - nsetb + 1;
drot_(&i__3, &w[nsetb + (nsetb + 1) * w_dim1], mdw, &w[mval + 1 +
(nsetb + 1) * w_dim1], mdw, &sc, &ss);
}
}
if (w[nsetb + nsetb * w_dim1] == 0.) {
ww[nsetb] = big;
--nsetb;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' PIVOT IS ZERO, NOT USED.')", &c_n4, (
ftnlen)29);
}
goto L210;
}
/* Check that new variable is moving in the right direction. */
itemp = ibasis[nsetb];
jcol = abs(itemp);
xnew = w[nsetb + (*ncols + 1) * w_dim1] / w[nsetb + nsetb * w_dim1] / (
d__1 = scl[jcol], abs(d__1));
if (itemp < 0) {
/* IF(WW(NSETB).GE.ZERO.AND.XNEW.LE.ZERO) exit(quit) */
/* IF(WW(NSETB).LE.ZERO.AND.XNEW.GE.ZERO) exit(quit) */
if (ww[nsetb] >= 0. && xnew <= 0. || ww[nsetb] <= 0. && xnew >= 0.) {
goto L240;
}
}
found = TRUE_;
goto L120;
L240:
ww[nsetb] = big;
--nsetb;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' VARIABLE HAS BAD DIRECTION, NOT USED.')", &
c_n4, (ftnlen)42);
}
goto L210;
/* Solve the triangular system. */
L270:
dcopy_(&nsetb, &w[(*ncols + 1) * w_dim1 + 1], &c__1, &rw[1], &c__1);
for (j = nsetb; j >= 1; --j) {
rw[j] /= w[j + j * w_dim1];
jcol = (i__3 = ibasis[j], abs(i__3));
t = rw[j];
if (ibb[jcol] % 2 == 0) {
rw[j] = -rw[j];
}
i__3 = j - 1;
d__1 = -t;
daxpy_(&i__3, &d__1, &w[j * w_dim1 + 1], &c__1, &rw[1], &c__1);
rw[j] /= (d__1 = scl[jcol], abs(d__1));
/* L280: */
}
if (iprint > 0) {
dvout_(&nsetb, &rw[1], "(' SOLN. VALUES')", &c_n4, (ftnlen)17);
ivout_(&nsetb, &ibasis[1], "(' COLS. USED')", &c_n4, (ftnlen)15);
}
if (lgopr == 2) {
dcopy_(&nsetb, &rw[1], &c__1, &x[1], &c__1);
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
itemp = ibasis[j];
jcol = abs(itemp);
if (itemp < 0) {
bou = 0.;
} else {
bou = bl[jcol];
}
if (-bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (x[j] <= bou) {
jdrop1 = j;
goto L340;
}
bou = bu[jcol];
if (bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (x[j] >= bou) {
jdrop2 = j;
goto L340;
}
/* L450: */
}
goto L340;
}
/* See if the unconstrained solution (obtained by solving the */
/* triangular system) satisfies the problem bounds. */
alpha = 2.;
beta = 2.;
x[nsetb] = 0.;
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
itemp = ibasis[j];
jcol = abs(itemp);
t1 = 2.;
t2 = 2.;
if (itemp < 0) {
bou = 0.;
} else {
bou = bl[jcol];
}
if (-bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (rw[j] <= bou) {
t1 = (x[j] - bou) / (x[j] - rw[j]);
}
bou = bu[jcol];
if (bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (rw[j] >= bou) {
t2 = (bou - x[j]) / (rw[j] - x[j]);
}
/* If not, then compute a step length so that the variables remain */
/* feasible. */
if (t1 < alpha) {
alpha = t1;
jdrop1 = j;
}
if (t2 < beta) {
beta = t2;
jdrop2 = j;
}
/* L310: */
}
constr = alpha < 2. || beta < 2.;
if (! constr) {
/* Accept the candidate because it satisfies the stated bounds */
/* on the variables. */
dcopy_(&nsetb, &rw[1], &c__1, &x[1], &c__1);
goto L580;
}
/* Take a step that is as large as possible with all variables */
/* remaining feasible. */
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
x[j] += min(alpha,beta) * (rw[j] - x[j]);
/* L330: */
}
if (alpha <= beta) {
jdrop2 = 0;
} else {
jdrop1 = 0;
}
L340:
if (jdrop1 + jdrop2 <= 0 || nsetb <= 0) {
goto L580;
}
/* L350: */
jdrop = jdrop1 + jdrop2;
itemp = ibasis[jdrop];
jcol = abs(itemp);
if (jdrop2 > 0) {
/* Variable is at an upper bound. Subtract multiple of this */
/* column from right hand side. */
t = bu[jcol];
if (itemp > 0) {
bu[jcol] = t - bl[jcol];
bl[jcol] = -t;
itemp = -itemp;
scl[jcol] = -scl[jcol];
i__3 = jdrop;
for (i__ = 1; i__ <= i__3; ++i__) {
w[i__ + jdrop * w_dim1] = -w[i__ + jdrop * w_dim1];
/* L360: */
}
} else {
++ibb[jcol];
if (ibb[jcol] % 2 == 0) {
t = -t;
}
}
/* Variable is at a lower bound. */
} else {
if ((doublereal) itemp < 0.) {
t = 0.;
} else {
t = -bl[jcol];
bu[jcol] += t;
itemp = -itemp;
}
}
daxpy_(&jdrop, &t, &w[jdrop * w_dim1 + 1], &c__1, &w[(*ncols + 1) *
w_dim1 + 1], &c__1);
/* Move certain columns left to achieve upper Hessenberg form. */
dcopy_(&jdrop, &w[jdrop * w_dim1 + 1], &c__1, &rw[1], &c__1);
i__3 = nsetb;
for (j = jdrop + 1; j <= i__3; ++j) {
ibasis[j - 1] = ibasis[j];
x[j - 1] = x[j];
dcopy_(&j, &w[j * w_dim1 + 1], &c__1, &w[(j - 1) * w_dim1 + 1], &c__1)
;
/* L370: */
}
ibasis[nsetb] = itemp;
w[nsetb * w_dim1 + 1] = 0.;
i__3 = mrows - jdrop;
dcopy_(&i__3, &w[nsetb * w_dim1 + 1], &c__0, &w[jdrop + 1 + nsetb *
w_dim1], &c__1);
dcopy_(&jdrop, &rw[1], &c__1, &w[nsetb * w_dim1 + 1], &c__1);
/* Transform the matrix from upper Hessenberg form to upper */
/* triangular form. */
--nsetb;
i__3 = nsetb;
for (i__ = jdrop; i__ <= i__3; ++i__) {
/* Look for small pivots and avoid mixing weighted and */
/* nonweighted rows. */
if (i__ == mval) {
t = 0.;
i__8 = nsetb;
for (j = i__; j <= i__8; ++j) {
jcol = (i__9 = ibasis[j], abs(i__9));
t1 = (d__1 = w[i__ + j * w_dim1] * scl[jcol], abs(d__1));
if (t1 > t) {
jbig = j;
t = t1;
}
/* L380: */
}
goto L400;
}
drotg_(&w[i__ + i__ * w_dim1], &w[i__ + 1 + i__ * w_dim1], &sc, &ss);
w[i__ + 1 + i__ * w_dim1] = 0.;
i__8 = *ncols - i__ + 1;
drot_(&i__8, &w[i__ + (i__ + 1) * w_dim1], mdw, &w[i__ + 1 + (i__ + 1)
* w_dim1], mdw, &sc, &ss);
/* L390: */
}
goto L430;
/* The triangularization is completed by giving up the Hessenberg */
/* form and triangularizing a rectangular matrix. */
L400:
dswap_(&mrows, &w[i__ * w_dim1 + 1], &c__1, &w[jbig * w_dim1 + 1], &c__1);
dswap_(&c__1, &ww[i__], &c__1, &ww[jbig], &c__1);
dswap_(&c__1, &x[i__], &c__1, &x[jbig], &c__1);
itemp = ibasis[i__];
ibasis[i__] = ibasis[jbig];
ibasis[jbig] = itemp;
jbig = i__;
i__3 = nsetb;
for (j = jbig; j <= i__3; ++j) {
i__8 = mrows;
for (i__ = j + 1; i__ <= i__8; ++i__) {
drotg_(&w[j + j * w_dim1], &w[i__ + j * w_dim1], &sc, &ss);
w[i__ + j * w_dim1] = 0.;
i__9 = *ncols - j + 1;
drot_(&i__9, &w[j + (j + 1) * w_dim1], mdw, &w[i__ + (j + 1) *
w_dim1], mdw, &sc, &ss);
/* L410: */
}
/* L420: */
}
/* See if the remaining coefficients are feasible. They should be */
/* because of the way MIN(ALPHA,BETA) was chosen. Any that are not */
/* feasible will be set to their bounds and appropriately translated. */
L430:
jdrop1 = 0;
jdrop2 = 0;
lgopr = 2;
goto L270;
/* Find a variable to become non-active. */
L120:
if (found) {
lgopr = 1;
goto L270;
}
/* Rescale and translate variables. */
igopr = 2;
L130:
dcopy_(&nsetb, &x[1], &c__1, &rw[1], &c__1);
dcopy_(ncols, &c_b185, &c__0, &x[1], &c__1);
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
jcol = (i__8 = ibasis[j], abs(i__8));
x[jcol] = rw[j] * (d__1 = scl[jcol], abs(d__1));
/* L140: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ibb[j] % 2 == 0) {
x[j] = bu[j] - x[j];
}
/* L150: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
jcol = ibasis[j];
if (jcol < 0) {
x[-jcol] = bl[-jcol] + x[-jcol];
}
/* L160: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (scl[j] < 0.) {
x[j] = -x[j];
}
/* L170: */
}
i__ = max(nsetb,mval);
i__3 = mrows - i__;
/* Computing MIN */
i__8 = i__ + 1;
*rnorm = dnrm2_(&i__3, &w[min(i__8,mrows) + (*ncols + 1) * w_dim1], &c__1)
;
if (igopr == 2) {
*mode = nsetb;
}
return 0;
} /* dbolsm_ */
/* Subroutine */ int dstein_(integer * n, doublereal * d__, doublereal * e,
integer * m, doublereal * w, integer * iblock,
integer * isplit, doublereal * z__, integer * ldz,
doublereal * work, integer * iwork,
integer * ifail, integer * info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer jblk, nblk;
extern doublereal ddot_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer jmax;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer i__, j;
extern /* Subroutine */ int dscal_(integer *, doublereal *,
doublereal *,
integer *);
static integer iseed[4], gpind, iinfo;
extern doublereal dasum_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer b1;
extern /* Subroutine */ int daxpy_(integer *, doublereal *,
doublereal *,
integer *, doublereal *, integer *);
static integer j1;
static doublereal ortol;
static integer indrv1, indrv2, indrv3, indrv4, indrv5, bn;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlagtf_(integer *, doublereal *,
doublereal *,
doublereal *, doublereal *,
doublereal *, doublereal *,
integer *, integer *);
static doublereal xj;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), dlagts_(
integer
*,
integer
*,
doublereal
*,
doublereal
*,
doublereal
*,
doublereal
*,
integer
*,
doublereal
*,
doublereal
*,
integer
*);
static integer nrmchk;
extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
doublereal *);
static integer blksiz;
static doublereal onenrm, dtpcrt, pertol, scl, eps, sep, nrm, tol;
static integer its;
static doublereal xjm, ztr, eps1;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Common block to return operation count and iteration count
ITCNT is initialized to 0, OPS is only incremented
Purpose
=======
DSTEIN computes the eigenvectors of a real symmetric tridiagonal
matrix T corresponding to specified eigenvalues, using inverse
iteration.
The maximum number of iterations allowed for each eigenvector is
specified by an internal parameter MAXITS (currently set to 5).
Arguments
=========
N (input) INTEGER
The order of the matrix. N >= 0.
D (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the tridiagonal matrix T.
E (input) DOUBLE PRECISION array, dimension (N)
The (n-1) subdiagonal elements of the tridiagonal matrix
T, in elements 1 to N-1. E(N) need not be set.
M (input) INTEGER
The number of eigenvectors to be found. 0 <= M <= N.
W (input) DOUBLE PRECISION array, dimension (N)
The first M elements of W contain the eigenvalues for
which eigenvectors are to be computed. The eigenvalues
should be grouped by split-off block and ordered from
smallest to largest within the block. ( The output array
W from DSTEBZ with ORDER = 'B' is expected here. )
IBLOCK (input) INTEGER array, dimension (N)
The submatrix indices associated with the corresponding
eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
the first submatrix from the top, =2 if W(i) belongs to
the second submatrix, etc. ( The output array IBLOCK
from DSTEBZ is expected here. )
ISPLIT (input) INTEGER array, dimension (N)
The splitting points, at which T breaks up into submatrices.
The first submatrix consists of rows/columns 1 to
ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
through ISPLIT( 2 ), etc.
( The output array ISPLIT from DSTEBZ is expected here. )
Z (output) DOUBLE PRECISION array, dimension (LDZ, M)
The computed eigenvectors. The eigenvector associated
with the eigenvalue W(i) is stored in the i-th column of
Z. Any vector which fails to converge is set to its current
iterate after MAXITS iterations.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= max(1,N).
WORK (workspace) DOUBLE PRECISION array, dimension (5*N)
IWORK (workspace) INTEGER array, dimension (N)
IFAIL (output) INTEGER array, dimension (M)
On normal exit, all elements of IFAIL are zero.
If one or more eigenvectors fail to converge after
MAXITS iterations, then their indices are stored in
array IFAIL.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, then i eigenvectors failed to converge
in MAXITS iterations. Their indices are stored in
array IFAIL.
Internal Parameters
===================
MAXITS INTEGER, default = 5
The maximum number of iterations performed.
EXTRA INTEGER, default = 2
The number of iterations performed after norm growth
criterion is satisfied, should be at least 1.
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
--w;
--iblock;
--isplit;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
*info = 0;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
if (*n < 0) {
*info = -1;
} else if (*m < 0 || *m > *n) {
*info = -4;
} else if (*ldz < max(1, *n)) {
*info = -9;
} else {
i__1 = *m;
for (j = 2; j <= i__1; ++j) {
if (iblock[j] < iblock[j - 1]) {
*info = -6;
goto L30;
}
if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) {
*info = -5;
goto L30;
}
/* L20: */
}
L30:
;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEIN", &i__1);
return 0;
}
/* Initialize iteration count. */
latime_1.itcnt = 0.;
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
} else if (*n == 1) {
z___ref(1, 1) = 1.;
return 0;
}
/* Get machine constants. */
eps = dlamch_("Precision");
/* Initialize seed for random number generator DLARNV. */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = 1;
/* L40: */
}
/* Initialize pointers. */
indrv1 = 0;
indrv2 = indrv1 + *n;
indrv3 = indrv2 + *n;
indrv4 = indrv3 + *n;
indrv5 = indrv4 + *n;
/* Compute eigenvectors of matrix blocks. */
j1 = 1;
i__1 = iblock[*m];
for (nblk = 1; nblk <= i__1; ++nblk) {
/* Find starting and ending indices of block nblk. */
if (nblk == 1) {
b1 = 1;
} else {
b1 = isplit[nblk - 1] + 1;
}
bn = isplit[nblk];
blksiz = bn - b1 + 1;
if (blksiz == 1) {
goto L60;
}
gpind = b1;
/* Compute reorthogonalization criterion and stopping criterion. */
onenrm = (d__1 = d__[b1], abs(d__1)) + (d__2 =
e[b1], abs(d__2));
/* Computing MAX */
d__3 = onenrm, d__4 = (d__1 = d__[bn], abs(d__1)) + (d__2 =
e[bn - 1],
abs(d__2));
onenrm = max(d__3, d__4);
i__2 = bn - 1;
for (i__ = b1 + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__4 = onenrm, d__5 = (d__1 =
d__[i__], abs(d__1)) + (d__2 =
e[i__ -
1],
abs
(d__2)) +
(d__3 = e[i__], abs(d__3));
onenrm = max(d__4, d__5);
/* L50: */
}
ortol = onenrm * .001;
dtpcrt = sqrt(.1 / blksiz);
/* Increment opcount for computing criteria. */
latime_1.ops = latime_1.ops + ((bn - b1) << 1) + 3;
/* Loop through eigenvalues of block nblk. */
L60:
jblk = 0;
i__2 = *m;
for (j = j1; j <= i__2; ++j) {
if (iblock[j] != nblk) {
j1 = j;
goto L160;
}
++jblk;
xj = w[j];
/* Skip all the work if the block size is one. */
if (blksiz == 1) {
work[indrv1 + 1] = 1.;
goto L120;
}
/* If eigenvalues j and j-1 are too close, add a relatively
small perturbation. */
if (jblk > 1) {
eps1 = (d__1 = eps * xj, abs(d__1));
pertol = eps1 * 10.;
sep = xj - xjm;
if (sep < pertol) {
xj = xjm + pertol;
}
}
its = 0;
nrmchk = 0;
/* Get random starting vector. */
dlarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
/* Increment opcount for getting random starting vector.
( DLARND(2,.) requires 9 flops. ) */
latime_1.ops += blksiz * 9;
/* Copy the matrix T so it won't be destroyed in factorization. */
dcopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1],
&c__1);
i__3 = blksiz - 1;
dcopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
i__3 = blksiz - 1;
dcopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
/* Compute LU factors with partial pivoting ( PT = LU ) */
tol = 0.;
dlagtf_(&blksiz, &work[indrv4 + 1], &xj,
&work[indrv2 + 2], &work[indrv3 + 1], &tol,
&work[indrv5 + 1], &iwork[1], &iinfo);
/* Increment opcount for computing LU factors.
( DLAGTF(BLKSIZ,...) requires about 8*BLKSIZ flops. ) */
latime_1.ops += blksiz << 3;
/* Update iteration count. */
L70:
++its;
if (its > 5) {
goto L100;
}
/* Normalize and scale the righthand side vector Pb.
Computing MAX */
d__2 = eps, d__3 = (d__1 =
work[indrv4 + blksiz], abs(d__1));
scl =
blksiz * onenrm * max(d__2, d__3) / dasum_(&blksiz,
&work
[indrv1 +
1],
&c__1);
dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
/* Solve the system LU = Pb. */
dlagts_(&c_n1, &blksiz, &work[indrv4 + 1],
&work[indrv2 + 2], &work[indrv3 + 1],
&work[indrv5 + 1], &iwork[1], &work[indrv1 + 1],
&tol, &iinfo);
/* Increment opcount for scaling and solving linear system.
( DLAGTS(-1,BLKSIZ,...) requires about 8*BLKSIZ flops. ) */
latime_1.ops = latime_1.ops + 3 + blksiz * 10;
/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
close enough. */
if (jblk == 1) {
goto L90;
}
if ((d__1 = xj - xjm, abs(d__1)) > ortol) {
gpind = j;
}
if (gpind != j) {
i__3 = j - 1;
for (i__ = gpind; i__ <= i__3; ++i__) {
ztr =
-ddot_(&blksiz, &work[indrv1 + 1],
&c__1, &z___ref(b1, i__),
&c__1);
daxpy_(&blksiz, &ztr, &z___ref(b1, i__),
&c__1, &work[indrv1 + 1], &c__1);
/* L80: */
}
/* Increment opcount for reorthogonalizing. */
latime_1.ops += (j - gpind) * blksiz << 2;
}
/* Check the infinity norm of the iterate. */
L90:
jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1);
nrm = (d__1 = work[indrv1 + jmax], abs(d__1));
/* Continue for additional iterations after norm reaches
stopping criterion. */
if (nrm < dtpcrt) {
goto L70;
}
++nrmchk;
if (nrmchk < 3) {
goto L70;
}
goto L110;
/* If stopping criterion was not satisfied, update info and
store eigenvector number in array ifail. */
L100:
++(*info);
ifail[*info] = j;
/* Accept iterate as jth eigenvector. */
L110:
scl = 1. / dnrm2_(&blksiz, &work[indrv1 + 1], &c__1);
jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1);
if (work[indrv1 + jmax] < 0.) {
scl = -scl;
}
dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
/* Increment opcount for scaling. */
latime_1.ops += blksiz * 3;
L120:
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
z___ref(i__, j) = 0.;
/* L130: */
}
i__3 = blksiz;
for (i__ = 1; i__ <= i__3; ++i__) {
z___ref(b1 + i__ - 1, j) = work[indrv1 + i__];
/* L140: */
}
/* Save the shift to check eigenvalue spacing at next
iteration. */
xjm = xj;
/* L150: */
}
L160:
;
}
return 0;
/* End of DSTEIN */
} /* dstein_ */
/* Subroutine */ int dlatdf_(integer *ijob, integer *n, doublereal *z__,
integer *ldz, doublereal *rhs, doublereal *rdsum, doublereal *rdscal,
integer *ipiv, integer *jpiv)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DLATDF uses the LU factorization of the n-by-n matrix Z computed by
DGETC2 and computes a contribution to the reciprocal Dif-estimate
by solving Z * x = b for x, and choosing the r.h.s. b such that
the norm of x is as large as possible. On entry RHS = b holds the
contribution from earlier solved sub-systems, and on return RHS = x.
The factorization of Z returned by DGETC2 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 DGECON, 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 DGETC2: 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 acoording 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 DTGSYL, 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 DTGSY2 is called by STGSYL.
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 DTGSY2 is called by
DTGSYL.
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 IMINF-95.05, Departement of
Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b23 = 1.;
static doublereal c_b37 = -1.;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer info;
static doublereal temp, work[32];
static integer i__, j, k;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
static doublereal pmone;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static doublereal sminu;
static integer iwork[8];
static doublereal splus;
extern /* Subroutine */ int dgesc2_(integer *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *);
static doublereal bm, bp;
extern /* Subroutine */ int dgecon_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *);
static doublereal xm[8], xp[8];
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *), dlaswp_(integer *, doublereal *,
integer *, integer *, integer *, integer *, integer *);
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
if (*ijob != 2) {
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L-part choosing RHS either to +1 or -1. */
pmone = -1.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
bp = rhs[j] + 1.;
bm = rhs[j] - 1.;
splus = 1.;
/* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
SMIN computed more efficiently than in BSOLVE [1]. */
i__2 = *n - j;
splus += ddot_(&i__2, &z___ref(j + 1, j), &c__1, &z___ref(j + 1,
j), &c__1);
i__2 = *n - j;
sminu = ddot_(&i__2, &z___ref(j + 1, j), &c__1, &rhs[j + 1], &
c__1);
splus *= rhs[j];
if (splus > sminu) {
rhs[j] = bp;
} else if (sminu > splus) {
rhs[j] = bm;
} 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.) */
rhs[j] += pmone;
pmone = 1.;
}
/* Compute the remaining r.h.s. */
temp = -rhs[j];
i__2 = *n - j;
daxpy_(&i__2, &temp, &z___ref(j + 1, j), &c__1, &rhs[j + 1], &
c__1);
/* L10: */
}
/* Solve for U-part, look-ahead 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;
dcopy_(&i__1, &rhs[1], &c__1, xp, &c__1);
xp[*n - 1] = rhs[*n] + 1.;
rhs[*n] += -1.;
splus = 0.;
sminu = 0.;
for (i__ = *n; i__ >= 1; --i__) {
temp = 1. / z___ref(i__, i__);
xp[i__ - 1] *= temp;
rhs[i__] *= temp;
i__1 = *n;
for (k = i__ + 1; k <= i__1; ++k) {
xp[i__ - 1] -= xp[k - 1] * (z___ref(i__, k) * temp);
rhs[i__] -= rhs[k] * (z___ref(i__, k) * temp);
/* L20: */
}
splus += (d__1 = xp[i__ - 1], abs(d__1));
sminu += (d__1 = rhs[i__], abs(d__1));
/* L30: */
}
if (splus > sminu) {
dcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
i__1 = *n - 1;
dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
dlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
} else {
/* IJOB = 2, Compute approximate nullvector XM of Z */
dgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, &
info);
dcopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
i__1 = *n - 1;
dlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
temp = 1. / sqrt(ddot_(n, xm, &c__1, xm, &c__1));
dscal_(n, &temp, xm, &c__1);
dcopy_(n, xm, &c__1, xp, &c__1);
daxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1);
daxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1);
dgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp);
dgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp);
if (dasum_(n, xp, &c__1) > dasum_(n, &rhs[1], &c__1)) {
dcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
dlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
}
return 0;
/* End of DLATDF */
} /* dlatdf_ */
/* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__,
doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl,
doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal *
work, integer *info)
{
/* System generated locals */
integer difr_dim1, difr_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal), d_sign(doublereal *, doublereal *);
/* Local variables */
integer i__, j;
doublereal dj, rho;
integer iwk1, iwk2, iwk3;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
integer iwk2i, iwk3i;
doublereal diflj, difrj, dsigj;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern doublereal dlamc3_(doublereal *, doublereal *);
extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
doublereal dsigjp;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASD8 finds the square roots of the roots of the secular equation, */
/* as defined by the values in DSIGMA and Z. It makes the appropriate */
/* calls to DLASD4, and stores, for each element in D, the distance */
/* to its two nearest poles (elements in DSIGMA). It also updates */
/* the arrays VF and VL, the first and last components of all the */
/* right singular vectors of the original bidiagonal matrix. */
/* DLASD8 is called from DLASD6. */
/* Arguments */
/* ========= */
/* ICOMPQ (input) INTEGER */
/* Specifies whether singular vectors are to be computed in */
/* factored form in the calling routine: */
/* = 0: Compute singular values only. */
/* = 1: Compute singular vectors in factored form as well. */
/* K (input) INTEGER */
/* The number of terms in the rational function to be solved */
/* by DLASD4. K >= 1. */
/* D (output) DOUBLE PRECISION array, dimension ( K ) */
/* On output, D contains the updated singular values. */
/* Z (input) DOUBLE PRECISION array, dimension ( K ) */
/* The first K elements of this array contain the components */
/* of the deflation-adjusted updating row vector. */
/* VF (input/output) DOUBLE PRECISION array, dimension ( K ) */
/* On entry, VF contains information passed through DBEDE8. */
/* On exit, VF contains the first K components of the first */
/* components of all right singular vectors of the bidiagonal */
/* matrix. */
/* VL (input/output) DOUBLE PRECISION array, dimension ( K ) */
/* On entry, VL contains information passed through DBEDE8. */
/* On exit, VL contains the first K components of the last */
/* components of all right singular vectors of the bidiagonal */
/* matrix. */
/* DIFL (output) DOUBLE PRECISION array, dimension ( K ) */
/* On exit, DIFL(I) = D(I) - DSIGMA(I). */
/* DIFR (output) DOUBLE PRECISION array, */
/* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */
/* dimension ( K ) if ICOMPQ = 0. */
/* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */
/* defined and will not be referenced. */
/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */
/* normalizing factors for the right singular vector matrix. */
/* LDDIFR (input) INTEGER */
/* The leading dimension of DIFR, must be at least K. */
/* DSIGMA (input) DOUBLE PRECISION array, dimension ( K ) */
/* The first K elements of this array contain the old roots */
/* of the deflated updating problem. These are the poles */
/* of the secular equation. */
/* WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = 1, an singular value did not converge */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Huan Ren, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--z__;
--vf;
--vl;
--difl;
difr_dim1 = *lddifr;
difr_offset = 1 + difr_dim1;
difr -= difr_offset;
--dsigma;
--work;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*k < 1) {
*info = -2;
} else if (*lddifr < *k) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASD8", &i__1);
return 0;
}
/* Quick return if possible */
if (*k == 1) {
d__[1] = abs(z__[1]);
difl[1] = d__[1];
if (*icompq == 1) {
difl[2] = 1.;
difr[(difr_dim1 << 1) + 1] = 1.;
}
return 0;
}
/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */
/* be computed with high relative accuracy (barring over/underflow). */
/* This is a problem on machines without a guard digit in */
/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */
/* which on any of these machines zeros out the bottommost */
/* bit of DSIGMA(I) if it is 1; this makes the subsequent */
/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */
/* occurs. On binary machines with a guard digit (almost all */
/* machines) it does not change DSIGMA(I) at all. On hexadecimal */
/* and decimal machines with a guard digit, it slightly */
/* changes the bottommost bits of DSIGMA(I). It does not account */
/* for hexadecimal or decimal machines without guard digits */
/* (we know of none). We use a subroutine call to compute */
/* 2*DSIGMA(I) to prevent optimizing compilers from eliminating */
/* this code. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
/* L10: */
}
/* Book keeping. */
iwk1 = 1;
iwk2 = iwk1 + *k;
iwk3 = iwk2 + *k;
iwk2i = iwk2 - 1;
iwk3i = iwk3 - 1;
/* Normalize Z. */
rho = dnrm2_(k, &z__[1], &c__1);
dlascl_("G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info);
rho *= rho;
/* Initialize WORK(IWK3). */
dlaset_("A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k);
/* Compute the updated singular values, the arrays DIFL, DIFR, */
/* and the updated Z. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[
iwk2], info);
/* If the root finder fails, the computation is terminated. */
if (*info != 0) {
return 0;
}
work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j];
difl[j] = -work[j];
difr[j + difr_dim1] = -work[j + 1];
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]);
/* L20: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
j]);
/* L30: */
}
/* L40: */
}
/* Compute updated Z. */
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1)));
z__[i__] = d_sign(&d__2, &z__[i__]);
/* L50: */
}
/* Update VF and VL. */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
diflj = difl[j];
dj = d__[j];
dsigj = -dsigma[j];
if (j < *k) {
difrj = -difr[j + difr_dim1];
dsigjp = -dsigma[j + 1];
}
work[j] = -z__[j] / diflj / (dsigma[j] + dj);
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / (
dsigma[i__] + dj);
/* L60: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) /
(dsigma[i__] + dj);
/* L70: */
}
temp = dnrm2_(k, &work[1], &c__1);
work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp;
work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp;
if (*icompq == 1) {
difr[j + (difr_dim1 << 1)] = temp;
}
/* L80: */
}
dcopy_(k, &work[iwk2], &c__1, &vf[1], &c__1);
dcopy_(k, &work[iwk3], &c__1, &vl[1], &c__1);
return 0;
/* End of DLASD8 */
} /* dlasd8_ */
/* Subroutine */ int dppt01_(char *uplo, integer *n, doublereal *a,
doublereal *afac, doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer i__1;
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
extern /* Subroutine */ int dspr_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *);
static integer i__, k;
static doublereal t;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
static doublereal anorm;
extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
doublereal *, doublereal *, integer *);
static integer kc;
extern doublereal dlamch_(char *), dlansp_(char *, char *,
integer *, doublereal *, doublereal *);
static doublereal eps;
static integer npp;
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DPPT01 reconstructs a symmetric positive definite packed matrix A
from its L*L' or U'*U factorization and computes the residual
norm( L*L' - A ) / ( N * norm(A) * EPS ) or
norm( U'*U - A ) / ( N * norm(A) * EPS ),
where EPS is the machine epsilon.
Arguments
==========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The number of rows and columns of the matrix A. N >= 0.
A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
The original symmetric matrix A, stored as a packed
triangular matrix.
AFAC (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
On entry, the factor L or U from the L*L' or U'*U
factorization of A, stored as a packed triangular matrix.
Overwritten with the reconstructed matrix, and then with the
difference L*L' - A (or U'*U - A).
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
RESID (output) DOUBLE PRECISION
If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
=====================================================================
Quick exit if N = 0
Parameter adjustments */
--rwork;
--afac;
--a;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = dlansp_("1", uplo, n, &a[1], &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
kc = *n * (*n - 1) / 2 + 1;
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
t = ddot_(&k, &afac[kc], &c__1, &afac[kc], &c__1);
afac[kc + k - 1] = t;
/* Compute the rest of column K. */
if (k > 1) {
i__1 = k - 1;
dtpmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[1], &
afac[kc], &c__1);
kc -= k - 1;
}
/* L10: */
}
/* Compute the product L*L', overwriting L. */
} else {
kc = *n * (*n + 1) / 2;
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of
columns K+1 through N. */
if (k < *n) {
i__1 = *n - k;
dspr_("Lower", &i__1, &c_b14, &afac[kc + 1], &c__1, &afac[kc
+ *n - k + 1]);
}
/* Scale column K by the diagonal element. */
t = afac[kc];
i__1 = *n - k + 1;
dscal_(&i__1, &t, &afac[kc], &c__1);
kc -= *n - k + 2;
/* L20: */
}
}
/* Compute the difference L*L' - A (or U'*U - A). */
npp = *n * (*n + 1) / 2;
i__1 = npp;
for (i__ = 1; i__ <= i__1; ++i__) {
afac[i__] -= a[i__];
/* L30: */
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = dlansp_("1", uplo, n, &afac[1], &rwork[1]);
*resid = *resid / (doublereal) (*n) / anorm / eps;
return 0;
/* End of DPPT01 */
} /* dppt01_ */
/* Ref: Weiss, Algorithm 12 BiCGSTAB
* INPUT
* n : dimension of the problem
* b [n] : r-h-s vector
* atimes (int n, static double *x, double *b, void *param) :
* calc matrix-vector product A.x = b.
* atimes_param : parameters for atimes().
* it : struct iter. following entries are used
* it->max = kend : max of iteration
* it->eps = eps : criteria for |r^2|/|b^2|
* OUTPUT
* returned value : 0 == success, otherwise (-1) == failed
* x [n] : solution
* it->niter : # of iteration
* it->res2 : |r^2| / |b^2|
*/
int
bicgstab (int n, const double *b, double *x,
void (*atimes) (int, const double *, double *, void *),
void *atimes_param,
struct iter *it)
{
#ifndef HAVE_CBLAS_H
# ifdef HAVE_BLAS_H
/* use Fortran BLAS routines */
int i_1 = 1;
double d_1 = 1.0;
double d_m1 = -1.0;
# endif // !HAVE_BLAS_H
#endif // !HAVE_CBLAS_H
int ret = -1;
double eps2 = it->eps * it->eps;
int itmax = it->max;
double *r = (double *)malloc (sizeof (double) * n);
double *rs = (double *)malloc (sizeof (double) * n);
double *p = (double *)malloc (sizeof (double) * n);
double *ap = (double *)malloc (sizeof (double) * n);
double *s = (double *)malloc (sizeof (double) * n);
double *t = (double *)malloc (sizeof (double) * n);
CHECK_MALLOC (r, "bicgstab");
CHECK_MALLOC (rs, "bicgstab");
CHECK_MALLOC (p, "bicgstab");
CHECK_MALLOC (ap, "bicgstab");
CHECK_MALLOC (s, "bicgstab");
CHECK_MALLOC (t, "bicgstab");
double rsap; // (r*, A.p)
double st;
double t2;
double rho, rho1;
double delta;
double gamma;
double beta;
double res2 = 0.0;
#ifdef HAVE_CBLAS_H
/**
* ATLAS version
*/
double b2 = cblas_ddot (n, b, 1, b, 1); // (b,b)
eps2 *= b2;
atimes (n, x, r, atimes_param); // r = A.x ...
cblas_daxpy (n, -1.0, b, 1, r, 1); // - b
cblas_dcopy (n, r, 1, rs, 1); // r* = r
cblas_dcopy (n, r, 1, p, 1); // p = r
rho = cblas_ddot (n, rs, 1, r, 1); // rho = (r*, r)
int i;
for (i = 0; i < itmax; i ++)
{
atimes (n, p, ap, atimes_param); // ap = A.p
rsap = cblas_ddot (n, rs, 1, ap, 1); // rsap = (r*, A.p)
delta = - rho / rsap;
cblas_dcopy (n, r, 1, s, 1); // s = r ...
cblas_daxpy (n, delta, ap, 1, s, 1); // + delta A.p
atimes (n, s, t, atimes_param); // t = A.s
st = cblas_ddot (n, s, 1, t, 1); // st = (s, t)
t2 = cblas_ddot (n, t, 1, t, 1); // t2 = (t, t)
gamma = - st / t2;
cblas_dcopy (n, s, 1, r, 1); // r = s ...
cblas_daxpy (n, gamma, t, 1, r, 1); // + gamma t
cblas_daxpy (n, delta, p, 1, x, 1); // x = x + delta p...
cblas_daxpy (n, gamma, s, 1, x, 1); // + gamma s
res2 = cblas_ddot (n, r, 1, r, 1);
if (it->debug == 2)
{
fprintf (it->out,
"libiter-bicgstab(cblas) %d %e\n",
i, res2 / b2);
}
if (res2 <= eps2)
{
ret = 0; // success
break;
}
rho1 = cblas_ddot (n, rs, 1, r, 1); // rho = (r*, r)
beta = rho1 / rho * delta / gamma;
rho = rho1;
cblas_daxpy (n, gamma, ap, 1, p, 1); // p = p + gamma A.p
cblas_dscal (n, beta, p, 1); // p = beta (p + gamma A.p)
cblas_daxpy (n, 1.0, r, 1, p, 1); // p = r + beta(p + gamma A.p)
}
#else // !HAVE_CBLAS_H
# ifdef HAVE_BLAS_H
/**
* BLAS version
*/
double b2 = ddot_ (&n, b, &i_1, b, &i_1); // (b,b)
eps2 *= b2;
atimes (n, x, r, atimes_param); // r = A.x ...
daxpy_ (&n, &d_m1, b, &i_1, r, &i_1); // - b
dcopy_ (&n, r, &i_1, rs, &i_1); // r* = r
dcopy_ (&n, r, &i_1, p, &i_1); // p = r
rho = ddot_ (&n, rs, &i_1, r, &i_1); // rho = (r*, r)
int i;
for (i = 0; i < itmax; i ++)
{
atimes (n, p, ap, atimes_param); // ap = A.p
rsap = ddot_ (&n, rs, &i_1, ap, &i_1); // rsap = (r*, A.p)
delta = - rho / rsap;
dcopy_ (&n, r, &i_1, s, &i_1); // s = r ...
daxpy_ (&n, &delta, ap, &i_1, s, &i_1); // + delta A.p
atimes (n, s, t, atimes_param); // t = A.s
st = ddot_ (&n, s, &i_1, t, &i_1); // st = (s, t)
t2 = ddot_ (&n, t, &i_1, t, &i_1); // t2 = (t, t)
gamma = - st / t2;
dcopy_ (&n, s, &i_1, r, &i_1); // r = s ...
daxpy_ (&n, &gamma, t, &i_1, r, &i_1); // + gamma t
daxpy_ (&n, &delta, p, &i_1, x, &i_1); // x = x + delta p...
daxpy_ (&n, &gamma, s, &i_1, x, &i_1); // + gamma s
res2 = ddot_ (&n, r, &i_1, r, &i_1);
if (it->debug == 2)
{
fprintf (it->out,
"libiter-bicgstab(blas) %d %e\n",
i, res2 / b2);
}
if (res2 <= eps2)
{
ret = 0; // success
break;
}
if (res2 > 1.0e20)
{
// already too big residual
break;
}
rho1 = ddot_ (&n, rs, &i_1, r, &i_1); // rho = (r*, r)
beta = rho1 / rho * delta / gamma;
rho = rho1;
daxpy_ (&n, &gamma, ap, &i_1, p, &i_1); // p = p + gamma A.p
dscal_ (&n, &beta, p, &i_1); // p = beta (p + gamma A.p)
daxpy_ (&n, &d_1, r, &i_1, p, &i_1); // p = r + beta(p + gamma A.p)
}
# else // !HAVE_BLAS_H
/**
* local BLAS version
*/
double b2 = my_ddot (n, b, 1, b, 1); // (b,b)
eps2 *= b2;
atimes (n, x, r, atimes_param); // r = A.x ...
my_daxpy (n, -1.0, b, 1, r, 1); // - b
my_dcopy (n, r, 1, rs, 1); // r* = r
my_dcopy (n, r, 1, p, 1); // p = r
rho = my_ddot (n, rs, 1, r, 1); // rho = (r*, r)
int i;
for (i = 0; i < itmax; i ++)
{
atimes (n, p, ap, atimes_param); // ap = A.p
rsap = my_ddot (n, rs, 1, ap, 1); // rsap = (r*, A.p)
delta = - rho / rsap;
my_dcopy (n, r, 1, s, 1); // s = r ...
my_daxpy (n, delta, ap, 1, s, 1); // + delta A.p
atimes (n, s, t, atimes_param); // t = A.s
st = my_ddot (n, s, 1, t, 1); // st = (s, t)
t2 = my_ddot (n, t, 1, t, 1); // t2 = (t, t)
gamma = - st / t2;
my_dcopy (n, s, 1, r, 1); // r = s ...
my_daxpy (n, gamma, t, 1, r, 1); // + gamma t
my_daxpy (n, delta, p, 1, x, 1); // x = x + delta p...
my_daxpy (n, gamma, s, 1, x, 1); // + gamma s
res2 = my_ddot (n, r, 1, r, 1);
if (it->debug == 2)
{
fprintf (it->out,
"libiter-bicgstab(myblas) %d %e\n",
i, res2 / b2);
}
if (res2 <= eps2)
{
ret = 0; // success
break;
}
rho1 = my_ddot (n, rs, 1, r, 1); // rho = (r*, r)
beta = rho1 / rho * delta / gamma;
rho = rho1;
my_daxpy (n, gamma, ap, 1, p, 1); // p = p + gamma A.p
my_dscal (n, beta, p, 1); // p = beta (p + gamma A.p)
my_daxpy (n, 1.0, r, 1, p, 1); // p = r + beta(p + gamma A.p)
}
# endif // !HAVE_BLAS_H
#endif // !HAVE_CBLAS_H
free (r);
free (rs);
free (p);
free (ap);
free (s);
free (t);
if (it->debug == 1)
{
fprintf (it->out, "libiter-bicgstab %d %e\n", i, res2 / b2);
}
it->niter = i;
it->res2 = res2 / b2;
return (ret);
}
/* Subroutine */ int dsvdc_(doublereal *x, integer *ldx, integer *n, integer *
p, doublereal *s, doublereal *e, doublereal *u, integer *ldu,
doublereal *v, integer *ldv, doublereal *work, integer *job, integer *
info)
{
/* System generated locals */
integer x_dim1, x_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3;
doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7;
/* Builtin functions */
double d_sign(doublereal *, doublereal *), sqrt(doublereal);
/* Local variables */
static doublereal b, c__, f, g;
static integer i__, j, k, l, m;
static doublereal t, t1, el;
static integer kk;
static doublereal cs;
static integer ll, mm, ls;
static doublereal sl;
static integer lu;
static doublereal sm, sn;
static integer lm1, mm1, lp1, mp1, nct, ncu, lls, nrt;
static doublereal emm1, smm1;
static integer kase;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer jobu, iter;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal test;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer nctp1, nrtp1;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal scale, shift;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), drotg_(doublereal *, doublereal *,
doublereal *, doublereal *);
static integer maxit;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical wantu, wantv;
static doublereal ztest;
/* dsvdc is a subroutine to reduce a double precision nxp matrix x */
/* by orthogonal transformations u and v to diagonal form. the */
/* diagonal elements s(i) are the singular values of x. the */
/* columns of u are the corresponding left singular vectors, */
/* and the columns of v the right singular vectors. */
/* on entry */
/* x double precision(ldx,p), where ldx.ge.n. */
/* x contains the matrix whose singular value */
/* decomposition is to be computed. x is */
/* destroyed by dsvdc. */
/* ldx integer. */
/* ldx is the leading dimension of the array x. */
/* n integer. */
/* n is the number of rows of the matrix x. */
/* p integer. */
/* p is the number of columns of the matrix x. */
/* ldu integer. */
/* ldu is the leading dimension of the array u. */
/* (see below). */
/* ldv integer. */
/* ldv is the leading dimension of the array v. */
/* (see below). */
/* work double precision(n). */
/* work is a scratch array. */
/* job integer. */
/* job controls the computation of the singular */
/* vectors. it has the decimal expansion ab */
/* with the following meaning */
/* a.eq.0 do not compute the left singular */
/* vectors. */
/* a.eq.1 return the n left singular vectors */
/* in u. */
/* a.ge.2 return the first min(n,p) singular */
/* vectors in u. */
/* b.eq.0 do not compute the right singular */
/* vectors. */
/* b.eq.1 return the right singular vectors */
/* in v. */
/* on return */
/* s double precision(mm), where mm=min(n+1,p). */
/* the first min(n,p) entries of s contain the */
/* singular values of x arranged in descending */
/* order of magnitude. */
/* e double precision(p), */
/* e ordinarily contains zeros. however see the */
/* discussion of info for exceptions. */
/* u double precision(ldu,k), where ldu.ge.n. if */
/* joba.eq.1 then k.eq.n, if joba.ge.2 */
/* then k.eq.min(n,p). */
/* u contains the matrix of left singular vectors. */
/* u is not referenced if joba.eq.0. if n.le.p */
/* or if joba.eq.2, then u may be identified with x */
/* in the subroutine call. */
/* v double precision(ldv,p), where ldv.ge.p. */
/* v contains the matrix of right singular vectors. */
/* v is not referenced if job.eq.0. if p.le.n, */
/* then v may be identified with x in the */
/* subroutine call. */
/* info integer. */
/* the singular values (and their corresponding */
/* singular vectors) s(info+1),s(info+2),...,s(m) */
/* are correct (here m=min(n,p)). thus if */
/* info.eq.0, all the singular values and their */
/* vectors are correct. in any event, the matrix */
/* b = trans(u)*x*v is the bidiagonal matrix */
/* with the elements of s on its diagonal and the */
/* elements of e on its super-diagonal (trans(u) */
/* is the transpose of u). thus the singular */
/* values of x and b are the same. */
/* linpack. this version dated 08/14/78 . */
/* correction made to shift 2/84. */
/* g.w. stewart, university of maryland, argonne national lab. */
/* dsvdc uses the following functions and subprograms. */
/* external drot */
/* blas daxpy,ddot,dscal,dswap,dnrm2,drotg */
/* fortran dabs,dmax1,max0,min0,mod,dsqrt */
/* internal variables */
/* set the maximum number of iterations. */
/* Parameter adjustments */
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--s;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--work;
/* Function Body */
maxit = 30;
/* determine what is to be computed. */
wantu = FALSE_;
wantv = FALSE_;
jobu = *job % 100 / 10;
ncu = *n;
if (jobu > 1) {
ncu = min(*n,*p);
}
if (jobu != 0) {
wantu = TRUE_;
}
if (*job % 10 != 0) {
wantv = TRUE_;
}
/* reduce x to bidiagonal form, storing the diagonal elements */
/* in s and the super-diagonal elements in e. */
*info = 0;
/* Computing MIN */
i__1 = *n - 1;
nct = min(i__1,*p);
/* Computing MAX */
/* Computing MIN */
i__3 = *p - 2;
i__1 = 0, i__2 = min(i__3,*n);
nrt = max(i__1,i__2);
lu = max(nct,nrt);
if (lu < 1) {
goto L170;
}
i__1 = lu;
for (l = 1; l <= i__1; ++l) {
lp1 = l + 1;
if (l > nct) {
goto L20;
}
/* compute the transformation for the l-th column and */
/* place the l-th diagonal in s(l). */
i__2 = *n - l + 1;
s[l] = dnrm2_(&i__2, &x[l + l * x_dim1], &c__1);
if (s[l] == 0.) {
goto L10;
}
if (x[l + l * x_dim1] != 0.) {
s[l] = d_sign(&s[l], &x[l + l * x_dim1]);
}
i__2 = *n - l + 1;
d__1 = 1. / s[l];
dscal_(&i__2, &d__1, &x[l + l * x_dim1], &c__1);
x[l + l * x_dim1] += 1.;
L10:
s[l] = -s[l];
L20:
if (*p < lp1) {
goto L50;
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
if (l > nct) {
goto L30;
}
if (s[l] == 0.) {
goto L30;
}
/* apply the transformation. */
i__3 = *n - l + 1;
t = -ddot_(&i__3, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1) / x[l + l * x_dim1];
i__3 = *n - l + 1;
daxpy_(&i__3, &t, &x[l + l * x_dim1], &c__1, &x[l + j * x_dim1], &
c__1);
L30:
/* place the l-th row of x into e for the */
/* subsequent calculation of the row transformation. */
e[j] = x[l + j * x_dim1];
/* L40: */
}
L50:
if (! wantu || l > nct) {
goto L70;
}
/* place the transformation in u for subsequent back */
/* multiplication. */
i__2 = *n;
for (i__ = l; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = x[i__ + l * x_dim1];
/* L60: */
}
L70:
if (l > nrt) {
goto L150;
}
/* compute the l-th row transformation and place the */
/* l-th super-diagonal in e(l). */
i__2 = *p - l;
e[l] = dnrm2_(&i__2, &e[lp1], &c__1);
if (e[l] == 0.) {
goto L80;
}
if (e[lp1] != 0.) {
e[l] = d_sign(&e[l], &e[lp1]);
}
i__2 = *p - l;
d__1 = 1. / e[l];
dscal_(&i__2, &d__1, &e[lp1], &c__1);
e[lp1] += 1.;
L80:
e[l] = -e[l];
if (lp1 > *n || e[l] == 0.) {
goto L120;
}
/* apply the transformation. */
i__2 = *n;
for (i__ = lp1; i__ <= i__2; ++i__) {
work[i__] = 0.;
/* L90: */
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l;
daxpy_(&i__3, &e[j], &x[lp1 + j * x_dim1], &c__1, &work[lp1], &
c__1);
/* L100: */
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l;
d__1 = -e[j] / e[lp1];
daxpy_(&i__3, &d__1, &work[lp1], &c__1, &x[lp1 + j * x_dim1], &
c__1);
/* L110: */
}
L120:
if (! wantv) {
goto L140;
}
/* place the transformation in v for subsequent */
/* back multiplication. */
i__2 = *p;
for (i__ = lp1; i__ <= i__2; ++i__) {
v[i__ + l * v_dim1] = e[i__];
/* L130: */
}
L140:
L150:
/* L160: */
;
}
L170:
/* set up the final bidiagonal matrix or order m. */
/* Computing MIN */
i__1 = *p, i__2 = *n + 1;
m = min(i__1,i__2);
nctp1 = nct + 1;
nrtp1 = nrt + 1;
if (nct < *p) {
s[nctp1] = x[nctp1 + nctp1 * x_dim1];
}
if (*n < m) {
s[m] = 0.;
}
if (nrtp1 < m) {
e[nrtp1] = x[nrtp1 + m * x_dim1];
}
e[m] = 0.;
/* if required, generate u. */
if (! wantu) {
goto L300;
}
if (ncu < nctp1) {
goto L200;
}
i__1 = ncu;
for (j = nctp1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + j * u_dim1] = 0.;
/* L180: */
}
u[j + j * u_dim1] = 1.;
/* L190: */
}
L200:
if (nct < 1) {
goto L290;
}
i__1 = nct;
for (ll = 1; ll <= i__1; ++ll) {
l = nct - ll + 1;
if (s[l] == 0.) {
goto L250;
}
lp1 = l + 1;
if (ncu < lp1) {
goto L220;
}
i__2 = ncu;
for (j = lp1; j <= i__2; ++j) {
i__3 = *n - l + 1;
t = -ddot_(&i__3, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1) / u[l + l * u_dim1];
i__3 = *n - l + 1;
daxpy_(&i__3, &t, &u[l + l * u_dim1], &c__1, &u[l + j * u_dim1], &
c__1);
/* L210: */
}
L220:
i__2 = *n - l + 1;
dscal_(&i__2, &c_b44, &u[l + l * u_dim1], &c__1);
u[l + l * u_dim1] += 1.;
lm1 = l - 1;
if (lm1 < 1) {
goto L240;
}
i__2 = lm1;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = 0.;
/* L230: */
}
L240:
goto L270;
L250:
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__ + l * u_dim1] = 0.;
/* L260: */
}
u[l + l * u_dim1] = 1.;
L270:
/* L280: */
;
}
L290:
L300:
/* if it is required, generate v. */
if (! wantv) {
goto L350;
}
i__1 = *p;
for (ll = 1; ll <= i__1; ++ll) {
l = *p - ll + 1;
lp1 = l + 1;
if (l > nrt) {
goto L320;
}
if (e[l] == 0.) {
goto L320;
}
i__2 = *p;
for (j = lp1; j <= i__2; ++j) {
i__3 = *p - l;
t = -ddot_(&i__3, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1) / v[lp1 + l * v_dim1];
i__3 = *p - l;
daxpy_(&i__3, &t, &v[lp1 + l * v_dim1], &c__1, &v[lp1 + j *
v_dim1], &c__1);
/* L310: */
}
L320:
i__2 = *p;
for (i__ = 1; i__ <= i__2; ++i__) {
v[i__ + l * v_dim1] = 0.;
/* L330: */
}
v[l + l * v_dim1] = 1.;
/* L340: */
}
L350:
/* main iteration loop for the singular values. */
mm = m;
iter = 0;
L360:
/* quit if all the singular values have been found. */
/* ...exit */
if (m == 0) {
goto L620;
}
/* if too many iterations have been performed, set */
/* flag and return. */
if (iter < maxit) {
goto L370;
}
*info = m;
/* ......exit */
goto L620;
L370:
/* this section of the program inspects for */
/* negligible elements in the s and e arrays. on */
/* completion the variables kase and l are set as follows. */
/* kase = 1 if s(m) and e(l-1) are negligible and l.lt.m */
/* kase = 2 if s(l) is negligible and l.lt.m */
/* kase = 3 if e(l-1) is negligible, l.lt.m, and */
/* s(l), ..., s(m) are not negligible (qr step). */
/* kase = 4 if e(m-1) is negligible (convergence). */
i__1 = m;
for (ll = 1; ll <= i__1; ++ll) {
l = m - ll;
/* ...exit */
if (l == 0) {
goto L400;
}
test = (d__1 = s[l], abs(d__1)) + (d__2 = s[l + 1], abs(d__2));
ztest = test + (d__1 = e[l], abs(d__1));
if (ztest != test) {
goto L380;
}
e[l] = 0.;
/* ......exit */
goto L400;
L380:
/* L390: */
;
}
L400:
if (l != m - 1) {
goto L410;
}
kase = 4;
goto L480;
L410:
lp1 = l + 1;
mp1 = m + 1;
i__1 = mp1;
for (lls = lp1; lls <= i__1; ++lls) {
ls = m - lls + lp1;
/* ...exit */
if (ls == l) {
goto L440;
}
test = 0.;
if (ls != m) {
test += (d__1 = e[ls], abs(d__1));
}
if (ls != l + 1) {
test += (d__1 = e[ls - 1], abs(d__1));
}
ztest = test + (d__1 = s[ls], abs(d__1));
if (ztest != test) {
goto L420;
}
s[ls] = 0.;
/* ......exit */
goto L440;
L420:
/* L430: */
;
}
L440:
if (ls != l) {
goto L450;
}
kase = 3;
goto L470;
L450:
if (ls != m) {
goto L460;
}
kase = 1;
goto L470;
L460:
kase = 2;
l = ls;
L470:
L480:
++l;
/* perform the task indicated by kase. */
switch (kase) {
case 1: goto L490;
case 2: goto L520;
case 3: goto L540;
case 4: goto L570;
}
/* deflate negligible s(m). */
L490:
mm1 = m - 1;
f = e[m - 1];
e[m - 1] = 0.;
i__1 = mm1;
for (kk = l; kk <= i__1; ++kk) {
k = mm1 - kk + l;
t1 = s[k];
drotg_(&t1, &f, &cs, &sn);
s[k] = t1;
if (k == l) {
goto L500;
}
f = -sn * e[k - 1];
e[k - 1] = cs * e[k - 1];
L500:
if (wantv) {
drot_(p, &v[k * v_dim1 + 1], &c__1, &v[m * v_dim1 + 1], &c__1, &
cs, &sn);
}
/* L510: */
}
goto L610;
/* split at negligible s(l). */
L520:
f = e[l - 1];
e[l - 1] = 0.;
i__1 = m;
for (k = l; k <= i__1; ++k) {
t1 = s[k];
drotg_(&t1, &f, &cs, &sn);
s[k] = t1;
f = -sn * e[k];
e[k] = cs * e[k];
if (wantu) {
drot_(n, &u[k * u_dim1 + 1], &c__1, &u[(l - 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/* L530: */
}
goto L610;
/* perform one qr step. */
L540:
/* calculate the shift. */
/* Computing MAX */
d__6 = (d__1 = s[m], abs(d__1)), d__7 = (d__2 = s[m - 1], abs(d__2)),
d__6 = max(d__6,d__7), d__7 = (d__3 = e[m - 1], abs(d__3)), d__6 =
max(d__6,d__7), d__7 = (d__4 = s[l], abs(d__4)), d__6 = max(d__6,
d__7), d__7 = (d__5 = e[l], abs(d__5));
scale = max(d__6,d__7);
sm = s[m] / scale;
smm1 = s[m - 1] / scale;
emm1 = e[m - 1] / scale;
sl = s[l] / scale;
el = e[l] / scale;
/* Computing 2nd power */
d__1 = emm1;
b = ((smm1 + sm) * (smm1 - sm) + d__1 * d__1) / 2.;
/* Computing 2nd power */
d__1 = sm * emm1;
c__ = d__1 * d__1;
shift = 0.;
if (b == 0. && c__ == 0.) {
goto L550;
}
/* Computing 2nd power */
d__1 = b;
shift = sqrt(d__1 * d__1 + c__);
if (b < 0.) {
shift = -shift;
}
shift = c__ / (b + shift);
L550:
f = (sl + sm) * (sl - sm) + shift;
g = sl * el;
/* chase zeros. */
mm1 = m - 1;
i__1 = mm1;
for (k = l; k <= i__1; ++k) {
drotg_(&f, &g, &cs, &sn);
if (k != l) {
e[k - 1] = f;
}
f = cs * s[k] + sn * e[k];
e[k] = cs * e[k] - sn * s[k];
g = sn * s[k + 1];
s[k + 1] = cs * s[k + 1];
if (wantv) {
drot_(p, &v[k * v_dim1 + 1], &c__1, &v[(k + 1) * v_dim1 + 1], &
c__1, &cs, &sn);
}
drotg_(&f, &g, &cs, &sn);
s[k] = f;
f = cs * e[k] + sn * s[k + 1];
s[k + 1] = -sn * e[k] + cs * s[k + 1];
g = sn * e[k + 1];
e[k + 1] = cs * e[k + 1];
if (wantu && k < *n) {
drot_(n, &u[k * u_dim1 + 1], &c__1, &u[(k + 1) * u_dim1 + 1], &
c__1, &cs, &sn);
}
/* L560: */
}
e[m - 1] = f;
++iter;
goto L610;
/* convergence. */
L570:
/* make the singular value positive. */
if (s[l] >= 0.) {
goto L580;
}
s[l] = -s[l];
if (wantv) {
dscal_(p, &c_b44, &v[l * v_dim1 + 1], &c__1);
}
L580:
/* order the singular value. */
L590:
if (l == mm) {
goto L600;
}
/* ...exit */
if (s[l] >= s[l + 1]) {
goto L600;
}
t = s[l];
s[l] = s[l + 1];
s[l + 1] = t;
if (wantv && l < *p) {
dswap_(p, &v[l * v_dim1 + 1], &c__1, &v[(l + 1) * v_dim1 + 1], &c__1);
}
if (wantu && l < *n) {
dswap_(n, &u[l * u_dim1 + 1], &c__1, &u[(l + 1) * u_dim1 + 1], &c__1);
}
++l;
goto L590;
L600:
iter = 0;
--m;
L610:
goto L360;
L620:
return 0;
} /* dsvdc_ */
/*< SUBROUTINE LSI(W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, IP) >*/
/* Subroutine */ int lsi_(doublereal *w, integer *mdw, integer *ma, integer *
mg, integer *n, doublereal *prgopt, doublereal *x, doublereal *rnorm,
integer *mode, doublereal *ws, integer *ip)
{
/* Initialized data */
static doublereal zero = 0.;
static doublereal drelpr = 0.;
static doublereal one = 1.;
static doublereal half = .5;
/* Format strings */
static char fmt_40[] = "";
static char fmt_60[] = "";
/* System generated locals */
integer w_dim1, w_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, l, m, n1, n2, n3;
extern /* Subroutine */ int h12_(integer *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, integer *);
integer ii;
doublereal rb;
integer il, im1, ip1, np1;
doublereal fac, gam, tau;
logical cov;
integer key;
doublereal tol;
integer map1, krm1, krp1;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
extern /* Subroutine */ int hfti_(doublereal *, integer *, integer *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
integer link;
extern /* Subroutine */ int lpdp_(doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
integer last, next, igo990, igo994;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
integer krank;
extern doublereal dasum_(integer *, doublereal *, integer *);
doublereal anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
doublereal xnorm;
integer minman, mdlpdp;
/* Assigned format variables */
static char *igo994_fmt, *igo990_fmt;
/* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */
/* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */
/* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */
/* (START EDITING AT LINE WITH C++ IN COLS. 1-3.) */
/* /REAL (12 BLANKS)/DOUBLE PRECISION/,/DASUM/DASUM/,/DDOT/DDOT/, */
/* / DSQRT/ DSQRT/,/DMAX1/DMAX1/,/DSWAP/DSWAP/, */
/* /DCOPY/DCOPY/,/DSCAL/DSCAL/,/DAXPY/DAXPY/,/D0/D0/,/DRELPR/DRELPR/ */
/* THIS IS A COMPANION SUBPROGRAM TO LSEI( ). */
/* THE DOCUMENTATION FOR LSEI( ) HAS MORE COMPLETE */
/* USAGE INSTRUCTIONS. */
/* WRITTEN BY R. J. HANSON, SLA. */
/* SOLVE.. */
/* AX = B, A MA BY N (LEAST SQUARES EQUATIONS) */
/* SUBJECT TO.. */
/* GX.GE.H, G MG BY N (INEQUALITY CONSTRAINTS) */
/* INPUT.. */
/* W(*,*) CONTAINS (A B) IN ROWS 1,...,MA+MG, COLS 1,...,N+1. */
/* (G H) */
/* MDW,MA,MG,N */
/* CONTAIN (RESP) VAR. DIMENSION OF W(*,*), */
/* AND MATRIX DIMENSIONS. */
/* PRGOPT(*), */
/* PROGRAM OPTION VECTOR. */
/* OUTPUT.. */
/* X(*),RNORM */
/* SOLUTION VECTOR(UNLESS MODE=2), LENGTH OF AX-B. */
/* MODE */
/* =0 INEQUALITY CONSTRAINTS ARE COMPATIBLE. */
/* =2 INEQUALITY CONSTRAINTS CONTRADICTORY. */
/* WS(*), */
/* WORKING STORAGE OF DIMENSION K+N+(MG+2)*(N+7), */
/* WHERE K=MAX(MA+MG,N). */
/* IP(MG+2*N+1) */
/* INTEGER WORKING STORAGE */
/* REVISED OCT. 1, 1981. */
/* SUBROUTINES CALLED */
/* LPDP THIS SUBPROGRAM MINIMIZES A SUM OF SQUARES */
/* OF UNKNOWNS SUBJECT TO LINEAR INEQUALITY */
/* CONSTRAINTS. PART OF THIS PACKAGE. */
/* ++ */
/* DDOT,DSCAL SUBROUTINES FROM THE BLAS PACKAGE. */
/* DAXPY,DASUM, SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308. */
/* DCOPY,DSWAP */
/* HFTI SOLVES AN UNCONSTRAINED LINEAR LEAST SQUARES */
/* PROBLEM. PART OF THIS PACKAGE. */
/* H12 SUBROUTINE TO CONSTRUCT AND APPLY A HOUSEHOLDER */
/* TRANSFORMATION. */
/* SUBROUTINE LSI(W,MDW,MA,MG,N,PRGOPT,X,RNORM,MODE,WS,IP) */
/*< DOUBLE PRECISION W(MDW,1), PRGOPT(1), RNORM, WS(1), X(1) >*/
/*< INTEGER IP(1) >*/
/*< >*/
/*< DOUBLE PRECISION DASUM, DDOT, DSQRT, DMAX1 >*/
/*< LOGICAL COV >*/
/*< DATA ZERO /0.D0/, DRELPR /0.D0/, ONE /1.D0/, HALF /.5E0/ >*/
#line 77 "../fortran/lsi.f"
/* Parameter adjustments */
#line 77 "../fortran/lsi.f"
w_dim1 = *mdw;
#line 77 "../fortran/lsi.f"
w_offset = 1 + w_dim1;
#line 77 "../fortran/lsi.f"
w -= w_offset;
#line 77 "../fortran/lsi.f"
--prgopt;
#line 77 "../fortran/lsi.f"
--x;
#line 77 "../fortran/lsi.f"
--ws;
#line 77 "../fortran/lsi.f"
--ip;
#line 77 "../fortran/lsi.f"
#line 77 "../fortran/lsi.f"
/* Function Body */
/* COMPUTE MACHINE PRECISION=DRELPR ONLY WHEN NECESSARY. */
/*< IF (.NOT.(DRELPR.EQ.ZERO)) GO TO 30 >*/
#line 80 "../fortran/lsi.f"
if (! (drelpr == zero)) {
#line 80 "../fortran/lsi.f"
goto L30;
#line 80 "../fortran/lsi.f"
}
/*< DRELPR = ONE >*/
#line 81 "../fortran/lsi.f"
drelpr = one;
/*< 10 IF (ONE+DRELPR.EQ.ONE) GO TO 20 >*/
#line 82 "../fortran/lsi.f"
L10:
#line 82 "../fortran/lsi.f"
if (one + drelpr == one) {
#line 82 "../fortran/lsi.f"
goto L20;
#line 82 "../fortran/lsi.f"
}
/*< DRELPR = DRELPR*HALF >*/
#line 83 "../fortran/lsi.f"
drelpr *= half;
/*< GO TO 10 >*/
#line 84 "../fortran/lsi.f"
goto L10;
/*< 20 DRELPR = DRELPR + DRELPR >*/
#line 85 "../fortran/lsi.f"
L20:
#line 85 "../fortran/lsi.f"
drelpr += drelpr;
/*< 30 MODE = 0 >*/
#line 86 "../fortran/lsi.f"
L30:
#line 86 "../fortran/lsi.f"
*mode = 0;
/*< RNORM = ZERO >*/
#line 87 "../fortran/lsi.f"
*rnorm = zero;
/*< M = MA + MG >*/
#line 88 "../fortran/lsi.f"
m = *ma + *mg;
/*< NP1 = N + 1 >*/
#line 89 "../fortran/lsi.f"
np1 = *n + 1;
/*< KRANK = 0 >*/
#line 90 "../fortran/lsi.f"
krank = 0;
/*< IF (N.LE.0 .OR. M.LE.0) GO TO 70 >*/
#line 91 "../fortran/lsi.f"
if (*n <= 0 || m <= 0) {
#line 91 "../fortran/lsi.f"
goto L70;
#line 91 "../fortran/lsi.f"
}
/*< ASSIGN 40 TO IGO994 >*/
#line 92 "../fortran/lsi.f"
igo994 = 0;
#line 92 "../fortran/lsi.f"
igo994_fmt = fmt_40;
/*< GO TO 500 >*/
#line 93 "../fortran/lsi.f"
goto L500;
/* PROCESS-OPTION-VECTOR */
/* COMPUTE MATRIX NORM OF LEAST SQUARES EQUAS. */
/*< 40 ANORM = ZERO >*/
#line 98 "../fortran/lsi.f"
L40:
#line 98 "../fortran/lsi.f"
anorm = zero;
/*< DO 50 J=1,N >*/
#line 99 "../fortran/lsi.f"
i__1 = *n;
#line 99 "../fortran/lsi.f"
for (j = 1; j <= i__1; ++j) {
/*< ANORM = DMAX1(ANORM,DASUM(MA,W(1,J),1)) >*/
/* Computing MAX */
#line 100 "../fortran/lsi.f"
d__1 = anorm, d__2 = dasum_(ma, &w[j * w_dim1 + 1], &c__1);
#line 100 "../fortran/lsi.f"
anorm = max(d__1,d__2);
/*< 50 CONTINUE >*/
#line 101 "../fortran/lsi.f"
/* L50: */
#line 101 "../fortran/lsi.f"
}
/* SET TOL FOR HFTI( ) RANK TEST. */
/*< TAU = TOL*ANORM >*/
#line 104 "../fortran/lsi.f"
tau = tol * anorm;
/* COMPUTE HOUSEHOLDER ORTHOGONAL DECOMP OF MATRIX. */
/*< IF (N.GT.0) WS(1) = ZERO >*/
#line 107 "../fortran/lsi.f"
if (*n > 0) {
#line 107 "../fortran/lsi.f"
ws[1] = zero;
#line 107 "../fortran/lsi.f"
}
/*< CALL DCOPY(N, WS, 0, WS, 1) >*/
#line 108 "../fortran/lsi.f"
dcopy_(n, &ws[1], &c__0, &ws[1], &c__1);
/*< CALL DCOPY(MA, W(1,NP1), 1, WS, 1) >*/
#line 109 "../fortran/lsi.f"
dcopy_(ma, &w[np1 * w_dim1 + 1], &c__1, &ws[1], &c__1);
/*< K = MAX0(M,N) >*/
#line 110 "../fortran/lsi.f"
k = max(m,*n);
/*< MINMAN = MIN0(MA,N) >*/
#line 111 "../fortran/lsi.f"
minman = min(*ma,*n);
/*< N1 = K + 1 >*/
#line 112 "../fortran/lsi.f"
n1 = k + 1;
/*< N2 = N1 + N >*/
#line 113 "../fortran/lsi.f"
n2 = n1 + *n;
/*< >*/
#line 114 "../fortran/lsi.f"
hfti_(&w[w_offset], mdw, ma, n, &ws[1], &c__1, &c__1, &tau, &krank, rnorm,
&ws[n2], &ws[n1], &ip[1]);
/*< FAC = ONE >*/
#line 116 "../fortran/lsi.f"
fac = one;
/*< GAM=MA-KRANK >*/
#line 117 "../fortran/lsi.f"
gam = (doublereal) (*ma - krank);
/*< IF (KRANK.LT.MA) FAC = RNORM**2/GAM >*/
#line 118 "../fortran/lsi.f"
if (krank < *ma) {
/* Computing 2nd power */
#line 118 "../fortran/lsi.f"
d__1 = *rnorm;
#line 118 "../fortran/lsi.f"
fac = d__1 * d__1 / gam;
#line 118 "../fortran/lsi.f"
}
/*< ASSIGN 60 TO IGO990 >*/
#line 119 "../fortran/lsi.f"
igo990 = 0;
#line 119 "../fortran/lsi.f"
igo990_fmt = fmt_60;
/*< GO TO 80 >*/
#line 120 "../fortran/lsi.f"
goto L80;
/* REDUCE-TO-LPDP-AND-SOLVE */
/*< 60 CONTINUE >*/
#line 123 "../fortran/lsi.f"
L60:
/*< 70 IP(1) = KRANK >*/
#line 124 "../fortran/lsi.f"
L70:
#line 124 "../fortran/lsi.f"
ip[1] = krank;
/*< IP(2) = N + MAX0(M,N) + (MG+2)*(N+7) >*/
#line 125 "../fortran/lsi.f"
ip[2] = *n + max(m,*n) + (*mg + 2) * (*n + 7);
/*< RETURN >*/
#line 126 "../fortran/lsi.f"
return 0;
/*< 80 CONTINUE >*/
#line 127 "../fortran/lsi.f"
L80:
/* TO REDUCE-TO-LPDP-AND-SOLVE */
/*< MAP1 = MA + 1 >*/
#line 130 "../fortran/lsi.f"
map1 = *ma + 1;
/* COMPUTE INEQ. RT-HAND SIDE FOR LPDP. */
/*< IF (.NOT.(MA.LT.M)) GO TO 260 >*/
#line 133 "../fortran/lsi.f"
if (! (*ma < m)) {
#line 133 "../fortran/lsi.f"
goto L260;
#line 133 "../fortran/lsi.f"
}
/*< IF (.NOT.(MINMAN.GT.0)) GO TO 160 >*/
#line 134 "../fortran/lsi.f"
if (! (minman > 0)) {
#line 134 "../fortran/lsi.f"
goto L160;
#line 134 "../fortran/lsi.f"
}
/*< DO 90 I=MAP1,M >*/
#line 135 "../fortran/lsi.f"
i__1 = m;
#line 135 "../fortran/lsi.f"
for (i__ = map1; i__ <= i__1; ++i__) {
/*< W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) >*/
#line 136 "../fortran/lsi.f"
w[i__ + np1 * w_dim1] -= ddot_(n, &w[i__ + w_dim1], mdw, &ws[1], &
c__1);
/*< 90 CONTINUE >*/
#line 137 "../fortran/lsi.f"
/* L90: */
#line 137 "../fortran/lsi.f"
}
/*< DO 100 I=1,MINMAN >*/
#line 138 "../fortran/lsi.f"
i__1 = minman;
#line 138 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< J = IP(I) >*/
#line 139 "../fortran/lsi.f"
j = ip[i__];
/* APPLY PERMUTATIONS TO COLS OF INEQ. CONSTRAINT MATRIX. */
/*< CALL DSWAP(MG, W(MAP1,I), 1, W(MAP1,J), 1) >*/
#line 142 "../fortran/lsi.f"
dswap_(mg, &w[map1 + i__ * w_dim1], &c__1, &w[map1 + j * w_dim1], &
c__1);
/*< 100 CONTINUE >*/
#line 143 "../fortran/lsi.f"
/* L100: */
#line 143 "../fortran/lsi.f"
}
/* APPLY HOUSEHOLDER TRANSFORMATIONS TO CONSTRAINT MATRIX. */
/*< IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.N)) GO TO 120 >*/
#line 146 "../fortran/lsi.f"
if (! (0 < krank && krank < *n)) {
#line 146 "../fortran/lsi.f"
goto L120;
#line 146 "../fortran/lsi.f"
}
/*< DO 110 II=1,KRANK >*/
#line 147 "../fortran/lsi.f"
i__1 = krank;
#line 147 "../fortran/lsi.f"
for (ii = 1; ii <= i__1; ++ii) {
/*< I = KRANK + 1 - II >*/
#line 148 "../fortran/lsi.f"
i__ = krank + 1 - ii;
/*< L = N1 + I >*/
#line 149 "../fortran/lsi.f"
l = n1 + i__;
/*< >*/
#line 150 "../fortran/lsi.f"
i__2 = krank + 1;
#line 150 "../fortran/lsi.f"
h12_(&c__2, &i__, &i__2, n, &w[i__ + w_dim1], mdw, &ws[l - 1], &w[
map1 + w_dim1], mdw, &c__1, mg);
/*< 110 CONTINUE >*/
#line 152 "../fortran/lsi.f"
/* L110: */
#line 152 "../fortran/lsi.f"
}
/* COMPUTE PERMUTED INEQ. CONSTR. MATRIX TIMES R-INVERSE. */
/*< 120 DO 150 I=MAP1,M >*/
#line 155 "../fortran/lsi.f"
L120:
#line 155 "../fortran/lsi.f"
i__1 = m;
#line 155 "../fortran/lsi.f"
for (i__ = map1; i__ <= i__1; ++i__) {
/*< IF (.NOT.(0.LT.KRANK)) GO TO 140 >*/
#line 156 "../fortran/lsi.f"
if (! (0 < krank)) {
#line 156 "../fortran/lsi.f"
goto L140;
#line 156 "../fortran/lsi.f"
}
/*< DO 130 J=1,KRANK >*/
#line 157 "../fortran/lsi.f"
i__2 = krank;
#line 157 "../fortran/lsi.f"
for (j = 1; j <= i__2; ++j) {
/*< W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) >*/
#line 158 "../fortran/lsi.f"
i__3 = j - 1;
#line 158 "../fortran/lsi.f"
w[i__ + j * w_dim1] = (w[i__ + j * w_dim1] - ddot_(&i__3, &w[j *
w_dim1 + 1], &c__1, &w[i__ + w_dim1], mdw)) / w[j + j *
w_dim1];
/*< 130 CONTINUE >*/
#line 159 "../fortran/lsi.f"
/* L130: */
#line 159 "../fortran/lsi.f"
}
/*< 140 CONTINUE >*/
#line 160 "../fortran/lsi.f"
L140:
/*< 150 CONTINUE >*/
#line 161 "../fortran/lsi.f"
/* L150: */
#line 161 "../fortran/lsi.f"
;
#line 161 "../fortran/lsi.f"
}
/* SOLVE THE REDUCED PROBLEM WITH LPDP ALGORITHM, */
/* THE LEAST PROJECTED DISTANCE PROBLEM. */
/*< 160 >*/
#line 165 "../fortran/lsi.f"
L160:
#line 165 "../fortran/lsi.f"
i__1 = *n - krank;
#line 165 "../fortran/lsi.f"
lpdp_(&w[map1 + w_dim1], mdw, mg, &krank, &i__1, &prgopt[1], &x[1], &
xnorm, &mdlpdp, &ws[n2], &ip[*n + 1]);
/*< IF (.NOT.(MDLPDP.EQ.1)) GO TO 240 >*/
#line 167 "../fortran/lsi.f"
if (! (mdlpdp == 1)) {
#line 167 "../fortran/lsi.f"
goto L240;
#line 167 "../fortran/lsi.f"
}
/*< IF (.NOT.(KRANK.GT.0)) GO TO 180 >*/
#line 168 "../fortran/lsi.f"
if (! (krank > 0)) {
#line 168 "../fortran/lsi.f"
goto L180;
#line 168 "../fortran/lsi.f"
}
/* COMPUTE SOLN IN ORIGINAL COORDINATES. */
/*< DO 170 II=1,KRANK >*/
#line 171 "../fortran/lsi.f"
i__1 = krank;
#line 171 "../fortran/lsi.f"
for (ii = 1; ii <= i__1; ++ii) {
/*< I = KRANK + 1 - II >*/
#line 172 "../fortran/lsi.f"
i__ = krank + 1 - ii;
/*< X(I) = (X(I)-DDOT(II-1,W(I,I+1),MDW,X(I+1),1))/W(I,I) >*/
#line 173 "../fortran/lsi.f"
i__2 = ii - 1;
#line 173 "../fortran/lsi.f"
x[i__] = (x[i__] - ddot_(&i__2, &w[i__ + (i__ + 1) * w_dim1], mdw, &x[
i__ + 1], &c__1)) / w[i__ + i__ * w_dim1];
/*< 170 CONTINUE >*/
#line 174 "../fortran/lsi.f"
/* L170: */
#line 174 "../fortran/lsi.f"
}
/* APPLY HOUSEHOLDER TRANS. TO SOLN VECTOR. */
/*< 180 IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.N)) GO TO 200 >*/
#line 177 "../fortran/lsi.f"
L180:
#line 177 "../fortran/lsi.f"
if (! (0 < krank && krank < *n)) {
#line 177 "../fortran/lsi.f"
goto L200;
#line 177 "../fortran/lsi.f"
}
/*< DO 190 I=1,KRANK >*/
#line 178 "../fortran/lsi.f"
i__1 = krank;
#line 178 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< L = N1 + I >*/
#line 179 "../fortran/lsi.f"
l = n1 + i__;
/*< CALL H12(2, I, KRANK+1, N, W(I,1), MDW, WS(L-1), X, 1, 1, 1) >*/
#line 180 "../fortran/lsi.f"
i__2 = krank + 1;
#line 180 "../fortran/lsi.f"
h12_(&c__2, &i__, &i__2, n, &w[i__ + w_dim1], mdw, &ws[l - 1], &x[1],
&c__1, &c__1, &c__1);
/*< 190 CONTINUE >*/
#line 181 "../fortran/lsi.f"
/* L190: */
#line 181 "../fortran/lsi.f"
}
/*< 200 IF (.NOT.(MINMAN.GT.0)) GO TO 230 >*/
#line 182 "../fortran/lsi.f"
L200:
#line 182 "../fortran/lsi.f"
if (! (minman > 0)) {
#line 182 "../fortran/lsi.f"
goto L230;
#line 182 "../fortran/lsi.f"
}
/* REPERMUTE VARIABLES TO THEIR INPUT ORDER. */
/*< DO 210 II=1,MINMAN >*/
#line 185 "../fortran/lsi.f"
i__1 = minman;
#line 185 "../fortran/lsi.f"
for (ii = 1; ii <= i__1; ++ii) {
/*< I = MINMAN + 1 - II >*/
#line 186 "../fortran/lsi.f"
i__ = minman + 1 - ii;
/*< J = IP(I) >*/
#line 187 "../fortran/lsi.f"
j = ip[i__];
/*< CALL DSWAP(1, X(I), 1, X(J), 1) >*/
#line 188 "../fortran/lsi.f"
dswap_(&c__1, &x[i__], &c__1, &x[j], &c__1);
/*< 210 CONTINUE >*/
#line 189 "../fortran/lsi.f"
/* L210: */
#line 189 "../fortran/lsi.f"
}
/* VARIABLES ARE NOW IN ORIG. COORDINATES. */
/* ADD SOLN OF UNSCONSTRAINED PROB. */
/*< DO 220 I=1,N >*/
#line 193 "../fortran/lsi.f"
i__1 = *n;
#line 193 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< X(I) = X(I) + WS(I) >*/
#line 194 "../fortran/lsi.f"
x[i__] += ws[i__];
/*< 220 CONTINUE >*/
#line 195 "../fortran/lsi.f"
/* L220: */
#line 195 "../fortran/lsi.f"
}
/* COMPUTE THE RESIDUAL VECTOR NORM. */
/*< RNORM = DSQRT(RNORM**2+XNORM**2) >*/
/* Computing 2nd power */
#line 198 "../fortran/lsi.f"
d__1 = *rnorm;
/* Computing 2nd power */
#line 198 "../fortran/lsi.f"
d__2 = xnorm;
#line 198 "../fortran/lsi.f"
*rnorm = sqrt(d__1 * d__1 + d__2 * d__2);
/*< 230 GO TO 250 >*/
#line 199 "../fortran/lsi.f"
L230:
#line 199 "../fortran/lsi.f"
goto L250;
/*< 240 MODE = 2 >*/
#line 200 "../fortran/lsi.f"
L240:
#line 200 "../fortran/lsi.f"
*mode = 2;
/*< 250 GO TO 270 >*/
#line 201 "../fortran/lsi.f"
L250:
#line 201 "../fortran/lsi.f"
goto L270;
/*< 260 CALL DCOPY(N, WS, 1, X, 1) >*/
#line 202 "../fortran/lsi.f"
L260:
#line 202 "../fortran/lsi.f"
dcopy_(n, &ws[1], &c__1, &x[1], &c__1);
/*< 270 IF (.NOT.(COV .AND. KRANK.GT.0)) GO TO 490 >*/
#line 203 "../fortran/lsi.f"
L270:
#line 203 "../fortran/lsi.f"
if (! (cov && krank > 0)) {
#line 203 "../fortran/lsi.f"
goto L490;
#line 203 "../fortran/lsi.f"
}
/* COMPUTE COVARIANCE MATRIX BASED ON THE ORTHOGONAL DECOMP. */
/* FROM HFTI( ). */
/*< KRM1 = KRANK - 1 >*/
#line 208 "../fortran/lsi.f"
krm1 = krank - 1;
/*< KRP1 = KRANK + 1 >*/
#line 209 "../fortran/lsi.f"
krp1 = krank + 1;
/* COPY DIAG. TERMS TO WORKING ARRAY. */
/*< CALL DCOPY(KRANK, W, MDW+1, WS(N2), 1) >*/
#line 212 "../fortran/lsi.f"
i__1 = *mdw + 1;
#line 212 "../fortran/lsi.f"
dcopy_(&krank, &w[w_offset], &i__1, &ws[n2], &c__1);
/* RECIPROCATE DIAG. TERMS. */
/*< DO 280 J=1,KRANK >*/
#line 215 "../fortran/lsi.f"
i__1 = krank;
#line 215 "../fortran/lsi.f"
for (j = 1; j <= i__1; ++j) {
/*< W(J,J) = ONE/W(J,J) >*/
#line 216 "../fortran/lsi.f"
w[j + j * w_dim1] = one / w[j + j * w_dim1];
/*< 280 CONTINUE >*/
#line 217 "../fortran/lsi.f"
/* L280: */
#line 217 "../fortran/lsi.f"
}
/*< IF (.NOT.(KRANK.GT.1)) GO TO 310 >*/
#line 218 "../fortran/lsi.f"
if (! (krank > 1)) {
#line 218 "../fortran/lsi.f"
goto L310;
#line 218 "../fortran/lsi.f"
}
/* INVERT THE UPPER TRIANGULAR QR FACTOR ON ITSELF. */
/*< DO 300 I=1,KRM1 >*/
#line 221 "../fortran/lsi.f"
i__1 = krm1;
#line 221 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< IP1 = I + 1 >*/
#line 222 "../fortran/lsi.f"
ip1 = i__ + 1;
/*< DO 290 J=IP1,KRANK >*/
#line 223 "../fortran/lsi.f"
i__2 = krank;
#line 223 "../fortran/lsi.f"
for (j = ip1; j <= i__2; ++j) {
/*< W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) >*/
#line 224 "../fortran/lsi.f"
i__3 = j - i__;
#line 224 "../fortran/lsi.f"
w[i__ + j * w_dim1] = -ddot_(&i__3, &w[i__ + i__ * w_dim1], mdw, &
w[i__ + j * w_dim1], &c__1) * w[j + j * w_dim1];
/*< 290 CONTINUE >*/
#line 225 "../fortran/lsi.f"
/* L290: */
#line 225 "../fortran/lsi.f"
}
/*< 300 CONTINUE >*/
#line 226 "../fortran/lsi.f"
/* L300: */
#line 226 "../fortran/lsi.f"
}
/* COMPUTE THE INVERTED FACTOR TIMES ITS TRANSPOSE. */
/*< 310 DO 330 I=1,KRANK >*/
#line 229 "../fortran/lsi.f"
L310:
#line 229 "../fortran/lsi.f"
i__1 = krank;
#line 229 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< DO 320 J=I,KRANK >*/
#line 230 "../fortran/lsi.f"
i__2 = krank;
#line 230 "../fortran/lsi.f"
for (j = i__; j <= i__2; ++j) {
/*< W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) >*/
#line 231 "../fortran/lsi.f"
i__3 = krank + 1 - j;
#line 231 "../fortran/lsi.f"
w[i__ + j * w_dim1] = ddot_(&i__3, &w[i__ + j * w_dim1], mdw, &w[
j + j * w_dim1], mdw);
/*< 320 CONTINUE >*/
#line 232 "../fortran/lsi.f"
/* L320: */
#line 232 "../fortran/lsi.f"
}
/*< 330 CONTINUE >*/
#line 233 "../fortran/lsi.f"
/* L330: */
#line 233 "../fortran/lsi.f"
}
/*< IF (.NOT.(KRANK.LT.N)) GO TO 450 >*/
#line 234 "../fortran/lsi.f"
if (! (krank < *n)) {
#line 234 "../fortran/lsi.f"
goto L450;
#line 234 "../fortran/lsi.f"
}
/* ZERO OUT LOWER TRAPEZOIDAL PART. */
/* COPY UPPER TRI. TO LOWER TRI. PART. */
/*< DO 340 J=1,KRANK >*/
#line 238 "../fortran/lsi.f"
i__1 = krank;
#line 238 "../fortran/lsi.f"
for (j = 1; j <= i__1; ++j) {
/*< CALL DCOPY(J, W(1,J), 1, W(J,1), MDW) >*/
#line 239 "../fortran/lsi.f"
dcopy_(&j, &w[j * w_dim1 + 1], &c__1, &w[j + w_dim1], mdw);
/*< 340 CONTINUE >*/
#line 240 "../fortran/lsi.f"
/* L340: */
#line 240 "../fortran/lsi.f"
}
/*< DO 350 I=KRP1,N >*/
#line 241 "../fortran/lsi.f"
i__1 = *n;
#line 241 "../fortran/lsi.f"
for (i__ = krp1; i__ <= i__1; ++i__) {
/*< W(I,1) = ZERO >*/
#line 242 "../fortran/lsi.f"
w[i__ + w_dim1] = zero;
/*< CALL DCOPY(I, W(I,1), 0, W(I,1), MDW) >*/
#line 243 "../fortran/lsi.f"
dcopy_(&i__, &w[i__ + w_dim1], &c__0, &w[i__ + w_dim1], mdw);
/*< 350 CONTINUE >*/
#line 244 "../fortran/lsi.f"
/* L350: */
#line 244 "../fortran/lsi.f"
}
/* APPLY RIGHT SIDE TRANSFORMATIONS TO LOWER TRI. */
/*< N3 = N2 + KRP1 >*/
#line 247 "../fortran/lsi.f"
n3 = n2 + krp1;
/*< DO 430 I=1,KRANK >*/
#line 248 "../fortran/lsi.f"
i__1 = krank;
#line 248 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< L = N1 + I >*/
#line 249 "../fortran/lsi.f"
l = n1 + i__;
/*< K = N2 + I >*/
#line 250 "../fortran/lsi.f"
k = n2 + i__;
/*< RB = WS(L-1)*WS(K-1) >*/
#line 251 "../fortran/lsi.f"
rb = ws[l - 1] * ws[k - 1];
/*< IF (.NOT.(RB.LT.ZERO)) GO TO 420 >*/
#line 252 "../fortran/lsi.f"
if (! (rb < zero)) {
#line 252 "../fortran/lsi.f"
goto L420;
#line 252 "../fortran/lsi.f"
}
/* IF RB.GE.ZERO, TRANSFORMATION CAN BE REGARDED AS ZERO. */
/*< RB = ONE/RB >*/
#line 255 "../fortran/lsi.f"
rb = one / rb;
/* STORE UNSCALED RANK-ONE HOUSEHOLDER UPDATE IN WORK ARRAY. */
/*< WS(N3) = ZERO >*/
#line 258 "../fortran/lsi.f"
ws[n3] = zero;
/*< CALL DCOPY(N, WS(N3), 0, WS(N3), 1) >*/
#line 259 "../fortran/lsi.f"
dcopy_(n, &ws[n3], &c__0, &ws[n3], &c__1);
/*< L = N1 + I >*/
#line 260 "../fortran/lsi.f"
l = n1 + i__;
/*< K = N3 + I >*/
#line 261 "../fortran/lsi.f"
k = n3 + i__;
/*< WS(K-1) = WS(L-1) >*/
#line 262 "../fortran/lsi.f"
ws[k - 1] = ws[l - 1];
/*< DO 360 J=KRP1,N >*/
#line 263 "../fortran/lsi.f"
i__2 = *n;
#line 263 "../fortran/lsi.f"
for (j = krp1; j <= i__2; ++j) {
/*< K = N3 + J >*/
#line 264 "../fortran/lsi.f"
k = n3 + j;
/*< WS(K-1) = W(I,J) >*/
#line 265 "../fortran/lsi.f"
ws[k - 1] = w[i__ + j * w_dim1];
/*< 360 CONTINUE >*/
#line 266 "../fortran/lsi.f"
/* L360: */
#line 266 "../fortran/lsi.f"
}
/*< DO 370 J=1,N >*/
#line 267 "../fortran/lsi.f"
i__2 = *n;
#line 267 "../fortran/lsi.f"
for (j = 1; j <= i__2; ++j) {
/*< L = N3 + I >*/
#line 268 "../fortran/lsi.f"
l = n3 + i__;
/*< K = N3 + J >*/
#line 269 "../fortran/lsi.f"
k = n3 + j;
/*< >*/
#line 270 "../fortran/lsi.f"
i__3 = j - i__;
#line 270 "../fortran/lsi.f"
i__4 = *n - j + 1;
#line 270 "../fortran/lsi.f"
ws[j] = ddot_(&i__3, &w[j + i__ * w_dim1], mdw, &ws[l - 1], &c__1)
+ ddot_(&i__4, &w[j + j * w_dim1], &c__1, &ws[k - 1], &
c__1);
/*< WS(J) = WS(J)*RB >*/
#line 272 "../fortran/lsi.f"
ws[j] *= rb;
/*< 370 CONTINUE >*/
#line 273 "../fortran/lsi.f"
/* L370: */
#line 273 "../fortran/lsi.f"
}
/*< L = N3 + I >*/
#line 274 "../fortran/lsi.f"
l = n3 + i__;
/*< GAM = DDOT(N-I+1,WS(L-1),1,WS(I),1)*RB >*/
#line 275 "../fortran/lsi.f"
i__2 = *n - i__ + 1;
#line 275 "../fortran/lsi.f"
gam = ddot_(&i__2, &ws[l - 1], &c__1, &ws[i__], &c__1) * rb;
/*< GAM = GAM*HALF >*/
#line 276 "../fortran/lsi.f"
gam *= half;
/*< CALL DAXPY(N-I+1, GAM, WS(L-1), 1, WS(I), 1) >*/
#line 277 "../fortran/lsi.f"
i__2 = *n - i__ + 1;
#line 277 "../fortran/lsi.f"
daxpy_(&i__2, &gam, &ws[l - 1], &c__1, &ws[i__], &c__1);
/*< DO 410 J=I,N >*/
#line 278 "../fortran/lsi.f"
i__2 = *n;
#line 278 "../fortran/lsi.f"
for (j = i__; j <= i__2; ++j) {
/*< IF (.NOT.(I.GT.1)) GO TO 390 >*/
#line 279 "../fortran/lsi.f"
if (! (i__ > 1)) {
#line 279 "../fortran/lsi.f"
goto L390;
#line 279 "../fortran/lsi.f"
}
/*< IM1 = I - 1 >*/
#line 280 "../fortran/lsi.f"
im1 = i__ - 1;
/*< K = N3 + J >*/
#line 281 "../fortran/lsi.f"
k = n3 + j;
/*< DO 380 L=1,IM1 >*/
#line 282 "../fortran/lsi.f"
i__3 = im1;
#line 282 "../fortran/lsi.f"
for (l = 1; l <= i__3; ++l) {
/*< W(J,L) = W(J,L) + WS(K-1)*WS(L) >*/
#line 283 "../fortran/lsi.f"
w[j + l * w_dim1] += ws[k - 1] * ws[l];
/*< 380 CONTINUE >*/
#line 284 "../fortran/lsi.f"
/* L380: */
#line 284 "../fortran/lsi.f"
}
/*< 390 K = N3 + J >*/
#line 285 "../fortran/lsi.f"
L390:
#line 285 "../fortran/lsi.f"
k = n3 + j;
/*< DO 400 L=I,J >*/
#line 286 "../fortran/lsi.f"
i__3 = j;
#line 286 "../fortran/lsi.f"
for (l = i__; l <= i__3; ++l) {
/*< IL = N3 + L >*/
#line 287 "../fortran/lsi.f"
il = n3 + l;
/*< W(J,L) = W(J,L) + WS(J)*WS(IL-1) + WS(L)*WS(K-1) >*/
#line 288 "../fortran/lsi.f"
w[j + l * w_dim1] = w[j + l * w_dim1] + ws[j] * ws[il - 1] +
ws[l] * ws[k - 1];
/*< 400 CONTINUE >*/
#line 289 "../fortran/lsi.f"
/* L400: */
#line 289 "../fortran/lsi.f"
}
/*< 410 CONTINUE >*/
#line 290 "../fortran/lsi.f"
/* L410: */
#line 290 "../fortran/lsi.f"
}
/*< 420 CONTINUE >*/
#line 291 "../fortran/lsi.f"
L420:
/*< 430 CONTINUE >*/
#line 292 "../fortran/lsi.f"
/* L430: */
#line 292 "../fortran/lsi.f"
;
#line 292 "../fortran/lsi.f"
}
/* COPY LOWER TRI. TO UPPER TRI. TO SYMMETRIZE THE COVARIANCE MATRIX. */
/*< DO 440 I=1,N >*/
#line 295 "../fortran/lsi.f"
i__1 = *n;
#line 295 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< CALL DCOPY(I, W(I,1), MDW, W(1,I), 1) >*/
#line 296 "../fortran/lsi.f"
dcopy_(&i__, &w[i__ + w_dim1], mdw, &w[i__ * w_dim1 + 1], &c__1);
/*< 440 CONTINUE >*/
#line 297 "../fortran/lsi.f"
/* L440: */
#line 297 "../fortran/lsi.f"
}
/* REPERMUTE ROWS AND COLS. */
/*< 450 DO 470 II=1,MINMAN >*/
#line 300 "../fortran/lsi.f"
L450:
#line 300 "../fortran/lsi.f"
i__1 = minman;
#line 300 "../fortran/lsi.f"
for (ii = 1; ii <= i__1; ++ii) {
/*< I = MINMAN + 1 - II >*/
#line 301 "../fortran/lsi.f"
i__ = minman + 1 - ii;
/*< K = IP(I) >*/
#line 302 "../fortran/lsi.f"
k = ip[i__];
/*< IF (.NOT.(I.NE.K)) GO TO 460 >*/
#line 303 "../fortran/lsi.f"
if (! (i__ != k)) {
#line 303 "../fortran/lsi.f"
goto L460;
#line 303 "../fortran/lsi.f"
}
/*< CALL DSWAP(1, W(I,I), 1, W(K,K), 1) >*/
#line 304 "../fortran/lsi.f"
dswap_(&c__1, &w[i__ + i__ * w_dim1], &c__1, &w[k + k * w_dim1], &
c__1);
/*< CALL DSWAP(I-1, W(1,I), 1, W(1,K), 1) >*/
#line 305 "../fortran/lsi.f"
i__2 = i__ - 1;
#line 305 "../fortran/lsi.f"
dswap_(&i__2, &w[i__ * w_dim1 + 1], &c__1, &w[k * w_dim1 + 1], &c__1);
/*< CALL DSWAP(K-I-1, W(I,I+1), MDW, W(I+1,K), 1) >*/
#line 306 "../fortran/lsi.f"
i__2 = k - i__ - 1;
#line 306 "../fortran/lsi.f"
dswap_(&i__2, &w[i__ + (i__ + 1) * w_dim1], mdw, &w[i__ + 1 + k *
w_dim1], &c__1);
/*< CALL DSWAP(N-K, W(I,K+1), MDW, W(K,K+1), MDW) >*/
#line 307 "../fortran/lsi.f"
i__2 = *n - k;
#line 307 "../fortran/lsi.f"
dswap_(&i__2, &w[i__ + (k + 1) * w_dim1], mdw, &w[k + (k + 1) *
w_dim1], mdw);
/*< 460 CONTINUE >*/
#line 308 "../fortran/lsi.f"
L460:
/*< 470 CONTINUE >*/
#line 309 "../fortran/lsi.f"
/* L470: */
#line 309 "../fortran/lsi.f"
;
#line 309 "../fortran/lsi.f"
}
/* PUT IN NORMALIZED RESIDUAL SUM OF SQUARES SCALE FACTOR */
/* AND SYMMETRIZE THE RESULTING COVARIANCE MARIX. */
/*< DO 480 J=1,N >*/
#line 313 "../fortran/lsi.f"
i__1 = *n;
#line 313 "../fortran/lsi.f"
for (j = 1; j <= i__1; ++j) {
/*< CALL DSCAL(J, FAC, W(1,J), 1) >*/
#line 314 "../fortran/lsi.f"
dscal_(&j, &fac, &w[j * w_dim1 + 1], &c__1);
/*< CALL DCOPY(J, W(1,J), 1, W(J,1), MDW) >*/
#line 315 "../fortran/lsi.f"
dcopy_(&j, &w[j * w_dim1 + 1], &c__1, &w[j + w_dim1], mdw);
/*< 480 CONTINUE >*/
#line 316 "../fortran/lsi.f"
/* L480: */
#line 316 "../fortran/lsi.f"
}
/*< 490 GO TO 540 >*/
#line 317 "../fortran/lsi.f"
L490:
#line 317 "../fortran/lsi.f"
goto L540;
/*< 500 CONTINUE >*/
#line 318 "../fortran/lsi.f"
L500:
/* TO PROCESS-OPTION-VECTOR */
/* THE NOMINAL TOLERANCE USED IN THE CODE, */
/*< TOL = DSQRT(DRELPR) >*/
#line 323 "../fortran/lsi.f"
tol = sqrt(drelpr);
/*< COV = .FALSE. >*/
#line 324 "../fortran/lsi.f"
cov = FALSE_;
/*< LAST = 1 >*/
#line 325 "../fortran/lsi.f"
last = 1;
/*< LINK = PRGOPT(1) >*/
#line 326 "../fortran/lsi.f"
link = (integer) prgopt[1];
/*< 510 IF (.NOT.(LINK.GT.1)) GO TO 520 >*/
#line 327 "../fortran/lsi.f"
L510:
#line 327 "../fortran/lsi.f"
if (! (link > 1)) {
#line 327 "../fortran/lsi.f"
goto L520;
#line 327 "../fortran/lsi.f"
}
/*< KEY = PRGOPT(LAST+1) >*/
#line 328 "../fortran/lsi.f"
key = (integer) prgopt[last + 1];
/*< IF (KEY.EQ.1) COV = PRGOPT(LAST+2).NE.ZERO >*/
#line 329 "../fortran/lsi.f"
if (key == 1) {
#line 329 "../fortran/lsi.f"
cov = prgopt[last + 2] != zero;
#line 329 "../fortran/lsi.f"
}
/*< IF (KEY.EQ.5) TOL = DMAX1(DRELPR,PRGOPT(LAST+2)) >*/
#line 330 "../fortran/lsi.f"
if (key == 5) {
/* Computing MAX */
#line 330 "../fortran/lsi.f"
d__1 = drelpr, d__2 = prgopt[last + 2];
#line 330 "../fortran/lsi.f"
tol = max(d__1,d__2);
#line 330 "../fortran/lsi.f"
}
/*< NEXT = PRGOPT(LINK) >*/
#line 331 "../fortran/lsi.f"
next = (integer) prgopt[link];
/*< LAST = LINK >*/
#line 332 "../fortran/lsi.f"
last = link;
/*< LINK = NEXT >*/
#line 333 "../fortran/lsi.f"
link = next;
/*< GO TO 510 >*/
#line 334 "../fortran/lsi.f"
goto L510;
/*< 520 GO TO 530 >*/
#line 335 "../fortran/lsi.f"
L520:
#line 335 "../fortran/lsi.f"
goto L530;
/*< 530 GO TO IGO994, (40) >*/
#line 336 "../fortran/lsi.f"
L530:
#line 336 "../fortran/lsi.f"
switch (igo994) {
#line 336 "../fortran/lsi.f"
case 0: goto L40;
#line 336 "../fortran/lsi.f"
}
/*< 540 GO TO IGO990, (60) >*/
#line 337 "../fortran/lsi.f"
L540:
#line 337 "../fortran/lsi.f"
switch (igo990) {
#line 337 "../fortran/lsi.f"
case 0: goto L60;
#line 337 "../fortran/lsi.f"
}
/*< END >*/
} /* lsi_ */
/* Subroutine */ int dposl_(
double *a,
int *lda,
int *n,
double *b)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2;
/* Local variables */
extern double ddot_(
int *n,
double *dx,
int *incx,
double *dy,
int *incy);
/* Subroutine */ int daxpy_(
int *n,
double *da,
double *dx,
int *incx,
double *dy,
int *incy);
static int k;
static double t;
static int kb;
/* dposl solves the double precision symmetric positive definite */
/* system a * x = b */
/* using the factors computed by dpoco or dpofa. */
/* on entry */
/* a double precision(lda, n) */
/* the output from dpoco or dpofa. */
/* lda int */
/* the leading dimension of the array a . */
/* n int */
/* the order of the matrix a . */
/* b double precision(n) */
/* the right hand side vector. */
/* on return */
/* b the solution vector x . */
/* error condition */
/* a division by zero will occur if the input factor contains */
/* a zero on the diagonal. technically this indicates */
/* singularity but it is usually caused by improper subroutine */
/* arguments. it will not occur if the subroutines are called */
/* correctly and info .eq. 0 . */
/* to compute inverse(a) * c where c is a matrix */
/* with p columns */
/* call dpoco(a,lda,n,rcond,z,info) */
/* if (rcond is too small .or. info .ne. 0) go to ... */
/* do 10 j = 1, p */
/* call dposl(a,lda,n,c(1,j)) */
/* 10 continue */
/* linpack. this version dated 08/14/78 . */
/* cleve moler, university of new mexico, argonne national lab. */
/* subroutines and functions */
/* blas daxpy,ddot */
/* internal variables */
/* solve trans(r)*y = b */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--b;
/* Function Body */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
t = ddot_(&i__2, &a[k * a_dim1 + 1], &c__1, &b[1], &c__1);
b[k] = (b[k] - t) / a[k + k * a_dim1];
/* L10: */
}
/* solve r*x = y */
i__1 = *n;
for (kb = 1; kb <= i__1; ++kb) {
k = *n + 1 - kb;
b[k] /= a[k + k * a_dim1];
t = -b[k];
i__2 = k - 1;
daxpy_(&i__2, &t, &a[k * a_dim1 + 1], &c__1, &b[1], &c__1);
/* L20: */
}
return 0;
} /* dposl_ */
/*< SUBROUTINE LPDP(A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, IS) >*/
/* Subroutine */ int lpdp_(doublereal *a, integer *mda, integer *m, integer *
n1, integer *n2, doublereal *prgopt, doublereal *x, doublereal *wnorm,
integer *mode, doublereal *ws, integer *is)
{
/* Initialized data */
static doublereal zero = 0.;
static doublereal one = 1.;
static doublereal fac = .1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer i__, j, l, n;
doublereal sc;
integer iw, ix, np1;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *), dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
integer modew;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal rnorm;
extern /* Subroutine */ int wnnls_(doublereal *, integer *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *);
doublereal ynorm;
/* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */
/* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */
/* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */
/* (START EDITING AT LINE WITH C++ IN COLS. 1-3.) */
/* /REAL (12 BLANKS)/DOUBLE PRECISION/,/DNRM2/DNRM2/,/DDOT/DDOT/, */
/* /DCOPY/DCOPY/,/DSCAL/DSCAL/,/DABS(/DABS(/, DABS/, DABS/,/D0/D0/ */
/* DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), */
/* WHERE N=N1+N2. THIS IS A SLIGHT OVERESTIMATE FOR WS(*). */
/* WRITTEN BY R. J. HANSON AND K. H. HASKELL, SANDIA LABS */
/* REVISED OCT. 1, 1981. */
/* DETERMINE AN N1-VECTOR W, AND */
/* AN N2-VECTOR Z */
/* WHICH MINIMIZES THE EUCLIDEAN LENGTH OF W */
/* SUBJECT TO G*W+H*Z .GE. Y. */
/* THIS IS THE LEAST PROJECTED DISTANCE PROBLEM, LPDP. */
/* THE MATRICES G AND H ARE OF RESPECTIVE */
/* DIMENSIONS M BY N1 AND M BY N2. */
/* CALLED BY SUBPROGRAM LSI( ). */
/* THE MATRIX */
/* (G H Y) */
/* OCCUPIES ROWS 1,...,M AND COLS 1,...,N1+N2+1 OF A(*,*). */
/* THE SOLUTION (W) IS RETURNED IN X(*). */
/* (Z) */
/* THE VALUE OF MODE INDICATES THE STATUS OF */
/* THE COMPUTATION AFTER RETURNING TO THE USER. */
/* MODE=1 THE SOLUTION WAS SUCCESSFULLY OBTAINED. */
/* MODE=2 THE INEQUALITIES ARE INCONSISTENT. */
/* SUBROUTINES CALLED */
/* WNNLS SOLVES A NONNEGATIVELY CONSTRAINED LINEAR LEAST */
/* SQUARES PROBLEM WITH LINEAR EQUALITY CONSTRAINTS. */
/* PART OF THIS PACKAGE. */
/* ++ */
/* DDOT, SUBROUTINES FROM THE BLAS PACKAGE. */
/* DSCAL,DNRM2, SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308. */
/* DCOPY */
/*< DOUBLE PRECISION A(MDA,1), PRGOPT(1), WS(1), WNORM, X(1) >*/
/*< INTEGER IS(1) >*/
/*< DOUBLE PRECISION FAC, ONE, RNORM, SC, YNORM, ZERO >*/
/*< DOUBLE PRECISION DDOT, DNRM2, DABS >*/
/*< DATA ZERO, ONE /0.D0,1.D0/, FAC /0.1E0/ >*/
#line 56 "../fortran/lpdp.f"
/* Parameter adjustments */
#line 56 "../fortran/lpdp.f"
a_dim1 = *mda;
#line 56 "../fortran/lpdp.f"
a_offset = 1 + a_dim1;
#line 56 "../fortran/lpdp.f"
a -= a_offset;
#line 56 "../fortran/lpdp.f"
--prgopt;
#line 56 "../fortran/lpdp.f"
--x;
#line 56 "../fortran/lpdp.f"
--ws;
#line 56 "../fortran/lpdp.f"
--is;
#line 56 "../fortran/lpdp.f"
#line 56 "../fortran/lpdp.f"
/* Function Body */
/*< N = N1 + N2 >*/
#line 57 "../fortran/lpdp.f"
n = *n1 + *n2;
/*< MODE = 1 >*/
#line 58 "../fortran/lpdp.f"
*mode = 1;
/*< IF (.NOT.(M.LE.0)) GO TO 20 >*/
#line 59 "../fortran/lpdp.f"
if (! (*m <= 0)) {
#line 59 "../fortran/lpdp.f"
goto L20;
#line 59 "../fortran/lpdp.f"
}
/*< IF (.NOT.(N.GT.0)) GO TO 10 >*/
#line 60 "../fortran/lpdp.f"
if (! (n > 0)) {
#line 60 "../fortran/lpdp.f"
goto L10;
#line 60 "../fortran/lpdp.f"
}
/*< X(1) = ZERO >*/
#line 61 "../fortran/lpdp.f"
x[1] = zero;
/*< CALL DCOPY(N, X, 0, X, 1) >*/
#line 62 "../fortran/lpdp.f"
dcopy_(&n, &x[1], &c__0, &x[1], &c__1);
/*< 10 WNORM = ZERO >*/
#line 63 "../fortran/lpdp.f"
L10:
#line 63 "../fortran/lpdp.f"
*wnorm = zero;
/*< RETURN >*/
#line 64 "../fortran/lpdp.f"
return 0;
/*< 20 NP1 = N + 1 >*/
#line 65 "../fortran/lpdp.f"
L20:
#line 65 "../fortran/lpdp.f"
np1 = n + 1;
/* SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. */
/*< DO 40 I=1,M >*/
#line 68 "../fortran/lpdp.f"
i__1 = *m;
#line 68 "../fortran/lpdp.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< SC = DNRM2(N,A(I,1),MDA) >*/
#line 69 "../fortran/lpdp.f"
sc = dnrm2_(&n, &a[i__ + a_dim1], mda);
/*< IF (.NOT.(SC.NE.ZERO)) GO TO 30 >*/
#line 70 "../fortran/lpdp.f"
if (! (sc != zero)) {
#line 70 "../fortran/lpdp.f"
goto L30;
#line 70 "../fortran/lpdp.f"
}
/*< SC = ONE/SC >*/
#line 71 "../fortran/lpdp.f"
sc = one / sc;
/*< CALL DSCAL(NP1, SC, A(I,1), MDA) >*/
#line 72 "../fortran/lpdp.f"
dscal_(&np1, &sc, &a[i__ + a_dim1], mda);
/*< 30 CONTINUE >*/
#line 73 "../fortran/lpdp.f"
L30:
/*< 40 CONTINUE >*/
#line 74 "../fortran/lpdp.f"
/* L40: */
#line 74 "../fortran/lpdp.f"
;
#line 74 "../fortran/lpdp.f"
}
/* SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). */
/*< YNORM = DNRM2(M,A(1,NP1),1) >*/
#line 77 "../fortran/lpdp.f"
ynorm = dnrm2_(m, &a[np1 * a_dim1 + 1], &c__1);
/*< IF (.NOT.(YNORM.NE.ZERO)) GO TO 50 >*/
#line 78 "../fortran/lpdp.f"
if (! (ynorm != zero)) {
#line 78 "../fortran/lpdp.f"
goto L50;
#line 78 "../fortran/lpdp.f"
}
/*< SC = ONE/YNORM >*/
#line 79 "../fortran/lpdp.f"
sc = one / ynorm;
/*< CALL DSCAL(M, SC, A(1,NP1), 1) >*/
#line 80 "../fortran/lpdp.f"
dscal_(m, &sc, &a[np1 * a_dim1 + 1], &c__1);
/* SCALE COLS OF MATRIX H. */
/*< 50 J = N1 + 1 >*/
#line 83 "../fortran/lpdp.f"
L50:
#line 83 "../fortran/lpdp.f"
j = *n1 + 1;
/*< 60 IF (.NOT.(J.LE.N)) GO TO 70 >*/
#line 84 "../fortran/lpdp.f"
L60:
#line 84 "../fortran/lpdp.f"
if (! (j <= n)) {
#line 84 "../fortran/lpdp.f"
goto L70;
#line 84 "../fortran/lpdp.f"
}
/*< SC = DNRM2(M,A(1,J),1) >*/
#line 85 "../fortran/lpdp.f"
sc = dnrm2_(m, &a[j * a_dim1 + 1], &c__1);
/*< IF (SC.NE.ZERO) SC = ONE/SC >*/
#line 86 "../fortran/lpdp.f"
if (sc != zero) {
#line 86 "../fortran/lpdp.f"
sc = one / sc;
#line 86 "../fortran/lpdp.f"
}
/*< CALL DSCAL(M, SC, A(1,J), 1) >*/
#line 87 "../fortran/lpdp.f"
dscal_(m, &sc, &a[j * a_dim1 + 1], &c__1);
/*< X(J) = SC >*/
#line 88 "../fortran/lpdp.f"
x[j] = sc;
/*< J = J + 1 >*/
#line 89 "../fortran/lpdp.f"
++j;
/*< GO TO 60 >*/
#line 90 "../fortran/lpdp.f"
goto L60;
/*< 70 IF (.NOT.(N1.GT.0)) GO TO 130 >*/
#line 91 "../fortran/lpdp.f"
L70:
#line 91 "../fortran/lpdp.f"
if (! (*n1 > 0)) {
#line 91 "../fortran/lpdp.f"
goto L130;
#line 91 "../fortran/lpdp.f"
}
/* COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). */
/*< IW = 0 >*/
#line 94 "../fortran/lpdp.f"
iw = 0;
/*< DO 80 I=1,M >*/
#line 95 "../fortran/lpdp.f"
i__1 = *m;
#line 95 "../fortran/lpdp.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/* MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. */
/*< CALL DCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1) >*/
#line 98 "../fortran/lpdp.f"
dcopy_(n2, &a[i__ + (*n1 + 1) * a_dim1], mda, &ws[iw + 1], &c__1);
/*< IW = IW + N2 >*/
#line 99 "../fortran/lpdp.f"
iw += *n2;
/* MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. */
/*< CALL DCOPY(N1, A(I,1), MDA, WS(IW+1), 1) >*/
#line 102 "../fortran/lpdp.f"
dcopy_(n1, &a[i__ + a_dim1], mda, &ws[iw + 1], &c__1);
/*< IW = IW + N1 >*/
#line 103 "../fortran/lpdp.f"
iw += *n1;
/* MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. */
/*< WS(IW+1) = A(I,NP1) >*/
#line 106 "../fortran/lpdp.f"
ws[iw + 1] = a[i__ + np1 * a_dim1];
/*< IW = IW + 1 >*/
#line 107 "../fortran/lpdp.f"
++iw;
/*< 80 CONTINUE >*/
#line 108 "../fortran/lpdp.f"
/* L80: */
#line 108 "../fortran/lpdp.f"
}
/*< WS(IW+1) = ZERO >*/
#line 109 "../fortran/lpdp.f"
ws[iw + 1] = zero;
/*< CALL DCOPY(N, WS(IW+1), 0, WS(IW+1), 1) >*/
#line 110 "../fortran/lpdp.f"
dcopy_(&n, &ws[iw + 1], &c__0, &ws[iw + 1], &c__1);
/*< IW = IW + N >*/
#line 111 "../fortran/lpdp.f"
iw += n;
/*< WS(IW+1) = ONE >*/
#line 112 "../fortran/lpdp.f"
ws[iw + 1] = one;
/*< IW = IW + 1 >*/
#line 113 "../fortran/lpdp.f"
++iw;
/* SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE */
/* MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR */
/* F = TRANSPOSE OF (0,...,0,1). */
/*< IX = IW + 1 >*/
#line 118 "../fortran/lpdp.f"
ix = iw + 1;
/*< IW = IW + M >*/
#line 119 "../fortran/lpdp.f"
iw += *m;
/* DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ). */
/*< IS(1) = 0 >*/
#line 122 "../fortran/lpdp.f"
is[1] = 0;
/*< IS(2) = 0 >*/
#line 123 "../fortran/lpdp.f"
is[2] = 0;
/*< >*/
#line 124 "../fortran/lpdp.f"
i__1 = np1 - *n2;
#line 124 "../fortran/lpdp.f"
wnnls_(&ws[1], &np1, n2, &i__1, m, &c__0, &prgopt[1], &ws[ix], &rnorm, &
modew, &is[1], &ws[iw + 1]);
/* COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. */
/*< SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) >*/
#line 128 "../fortran/lpdp.f"
sc = one - ddot_(m, &a[np1 * a_dim1 + 1], &c__1, &ws[ix], &c__1);
/*< IF (.NOT.(ONE+FAC*DABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 110 >*/
#line 129 "../fortran/lpdp.f"
if (! (one + fac * abs(sc) != one && rnorm > zero)) {
#line 129 "../fortran/lpdp.f"
goto L110;
#line 129 "../fortran/lpdp.f"
}
/*< SC = ONE/SC >*/
#line 130 "../fortran/lpdp.f"
sc = one / sc;
/*< DO 90 J=1,N1 >*/
#line 131 "../fortran/lpdp.f"
i__1 = *n1;
#line 131 "../fortran/lpdp.f"
for (j = 1; j <= i__1; ++j) {
/*< X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) >*/
#line 132 "../fortran/lpdp.f"
x[j] = sc * ddot_(m, &a[j * a_dim1 + 1], &c__1, &ws[ix], &c__1);
/*< 90 CONTINUE >*/
#line 133 "../fortran/lpdp.f"
/* L90: */
#line 133 "../fortran/lpdp.f"
}
/* COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS VECTOR. */
/*< DO 100 I=1,M >*/
#line 136 "../fortran/lpdp.f"
i__1 = *m;
#line 136 "../fortran/lpdp.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) >*/
#line 137 "../fortran/lpdp.f"
a[i__ + np1 * a_dim1] -= ddot_(n1, &a[i__ + a_dim1], mda, &x[1], &
c__1);
/*< 100 CONTINUE >*/
#line 138 "../fortran/lpdp.f"
/* L100: */
#line 138 "../fortran/lpdp.f"
}
/*< GO TO 120 >*/
#line 139 "../fortran/lpdp.f"
goto L120;
/*< 110 MODE = 2 >*/
#line 140 "../fortran/lpdp.f"
L110:
#line 140 "../fortran/lpdp.f"
*mode = 2;
/*< RETURN >*/
#line 141 "../fortran/lpdp.f"
return 0;
/*< 120 CONTINUE >*/
#line 142 "../fortran/lpdp.f"
L120:
/*< 130 IF (.NOT.(N2.GT.0)) GO TO 180 >*/
#line 143 "../fortran/lpdp.f"
L130:
#line 143 "../fortran/lpdp.f"
if (! (*n2 > 0)) {
#line 143 "../fortran/lpdp.f"
goto L180;
#line 143 "../fortran/lpdp.f"
}
/* COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). */
/*< IW = 0 >*/
#line 146 "../fortran/lpdp.f"
iw = 0;
/*< DO 140 I=1,M >*/
#line 147 "../fortran/lpdp.f"
i__1 = *m;
#line 147 "../fortran/lpdp.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< CALL DCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1) >*/
#line 148 "../fortran/lpdp.f"
dcopy_(n2, &a[i__ + (*n1 + 1) * a_dim1], mda, &ws[iw + 1], &c__1);
/*< IW = IW + N2 >*/
#line 149 "../fortran/lpdp.f"
iw += *n2;
/*< WS(IW+1) = A(I,NP1) >*/
#line 150 "../fortran/lpdp.f"
ws[iw + 1] = a[i__ + np1 * a_dim1];
/*< IW = IW + 1 >*/
#line 151 "../fortran/lpdp.f"
++iw;
/*< 140 CONTINUE >*/
#line 152 "../fortran/lpdp.f"
/* L140: */
#line 152 "../fortran/lpdp.f"
}
/*< WS(IW+1) = ZERO >*/
#line 153 "../fortran/lpdp.f"
ws[iw + 1] = zero;
/*< CALL DCOPY(N2, WS(IW+1), 0, WS(IW+1), 1) >*/
#line 154 "../fortran/lpdp.f"
dcopy_(n2, &ws[iw + 1], &c__0, &ws[iw + 1], &c__1);
/*< IW = IW + N2 >*/
#line 155 "../fortran/lpdp.f"
iw += *n2;
/*< WS(IW+1) = ONE >*/
#line 156 "../fortran/lpdp.f"
ws[iw + 1] = one;
/*< IW = IW + 1 >*/
#line 157 "../fortran/lpdp.f"
++iw;
/*< IX = IW + 1 >*/
#line 158 "../fortran/lpdp.f"
ix = iw + 1;
/*< IW = IW + M >*/
#line 159 "../fortran/lpdp.f"
iw += *m;
/* SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE */
/* OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE */
/* OF (0,...,0,1)). */
/* DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ). */
/*< IS(1) = 0 >*/
#line 166 "../fortran/lpdp.f"
is[1] = 0;
/*< IS(2) = 0 >*/
#line 167 "../fortran/lpdp.f"
is[2] = 0;
/*< >*/
#line 168 "../fortran/lpdp.f"
i__1 = *n2 + 1;
#line 168 "../fortran/lpdp.f"
i__2 = *n2 + 1;
#line 168 "../fortran/lpdp.f"
wnnls_(&ws[1], &i__1, &c__0, &i__2, m, &c__0, &prgopt[1], &ws[ix], &rnorm,
&modew, &is[1], &ws[iw + 1]);
/* COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. */
/*< SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) >*/
#line 172 "../fortran/lpdp.f"
sc = one - ddot_(m, &a[np1 * a_dim1 + 1], &c__1, &ws[ix], &c__1);
/*< IF (.NOT.(ONE+FAC*DABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 160 >*/
#line 173 "../fortran/lpdp.f"
if (! (one + fac * abs(sc) != one && rnorm > zero)) {
#line 173 "../fortran/lpdp.f"
goto L160;
#line 173 "../fortran/lpdp.f"
}
/*< SC = ONE/SC >*/
#line 174 "../fortran/lpdp.f"
sc = one / sc;
/*< DO 150 J=1,N2 >*/
#line 175 "../fortran/lpdp.f"
i__1 = *n2;
#line 175 "../fortran/lpdp.f"
for (j = 1; j <= i__1; ++j) {
/*< L = N1 + J >*/
#line 176 "../fortran/lpdp.f"
l = *n1 + j;
/*< X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) >*/
#line 177 "../fortran/lpdp.f"
x[l] = sc * ddot_(m, &a[l * a_dim1 + 1], &c__1, &ws[ix], &c__1) * x[l]
;
/*< 150 CONTINUE >*/
#line 178 "../fortran/lpdp.f"
/* L150: */
#line 178 "../fortran/lpdp.f"
}
/*< GO TO 170 >*/
#line 179 "../fortran/lpdp.f"
goto L170;
/*< 160 MODE = 2 >*/
#line 180 "../fortran/lpdp.f"
L160:
#line 180 "../fortran/lpdp.f"
*mode = 2;
/*< RETURN >*/
#line 181 "../fortran/lpdp.f"
return 0;
/*< 170 CONTINUE >*/
#line 182 "../fortran/lpdp.f"
L170:
/* ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. */
/*< 180 CALL DSCAL(N, YNORM, X, 1) >*/
#line 185 "../fortran/lpdp.f"
L180:
#line 185 "../fortran/lpdp.f"
dscal_(&n, &ynorm, &x[1], &c__1);
/*< WNORM = DNRM2(N1,X,1) >*/
#line 186 "../fortran/lpdp.f"
*wnorm = dnrm2_(n1, &x[1], &c__1);
/*< RETURN >*/
#line 187 "../fortran/lpdp.f"
return 0;
/*< END >*/
} /* lpdp_ */
int dlaic1_(int *job, int *j, double *x,
double *sest, double *w, double *gamma, double *
sestpr, double *s, double *c__)
{
/* System generated locals */
double d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt(double), d_sign(double *, double *);
/* Local variables */
double b, t, s1, s2, eps, tmp;
extern double ddot_(int *, double *, int *, double *,
int *);
double sine, test, zeta1, zeta2, alpha, norma;
extern double dlamch_(char *);
double absgam, absalp, cosine, absest;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAIC1 applies one step of incremental condition estimation in */
/* its simplest version: */
/* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */
/* lower triangular matrix L, such that */
/* twonorm(L*x) = sest */
/* Then DLAIC1 computes sestpr, s, c such that */
/* the vector */
/* [ s*x ] */
/* xhat = [ c ] */
/* is an approximate singular vector of */
/* [ L 0 ] */
/* Lhat = [ w' gamma ] */
/* in the sense that */
/* twonorm(Lhat*xhat) = sestpr. */
/* Depending on JOB, an estimate for the largest or smallest singular */
/* value is computed. */
/* Note that [s c]' and sestpr**2 is an eigenpair of the system */
/* diag(sest*sest, 0) + [alpha gamma] * [ alpha ] */
/* [ gamma ] */
/* where alpha = x'*w. */
/* Arguments */
/* ========= */
/* JOB (input) INTEGER */
/* = 1: an estimate for the largest singular value is computed. */
/* = 2: an estimate for the smallest singular value is computed. */
/* J (input) INTEGER */
/* Length of X and W */
/* X (input) DOUBLE PRECISION array, dimension (J) */
/* The j-vector x. */
/* SEST (input) DOUBLE PRECISION */
/* Estimated singular value of j by j matrix L */
/* W (input) DOUBLE PRECISION array, dimension (J) */
/* The j-vector w. */
/* GAMMA (input) DOUBLE PRECISION */
/* The diagonal element gamma. */
/* SESTPR (output) DOUBLE PRECISION */
/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */
/* S (output) DOUBLE PRECISION */
/* Sine needed in forming xhat. */
/* C (output) DOUBLE PRECISION */
/* Cosine needed in forming xhat. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--w;
--x;
/* Function Body */
eps = dlamch_("Epsilon");
alpha = ddot_(j, &x[1], &c__1, &w[1], &c__1);
absalp = ABS(alpha);
absgam = ABS(*gamma);
absest = ABS(*sest);
if (*job == 1) {
/* Estimating largest singular value */
/* special cases */
if (*sest == 0.) {
s1 = MAX(absgam,absalp);
if (s1 == 0.) {
*s = 0.;
*c__ = 1.;
*sestpr = 0.;
} else {
*s = alpha / s1;
*c__ = *gamma / s1;
tmp = sqrt(*s * *s + *c__ * *c__);
*s /= tmp;
*c__ /= tmp;
*sestpr = s1 * tmp;
}
return 0;
} else if (absgam <= eps * absest) {
*s = 1.;
*c__ = 0.;
tmp = MAX(absest,absalp);
s1 = absest / tmp;
s2 = absalp / tmp;
*sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
*s = 1.;
*c__ = 0.;
*sestpr = s2;
} else {
*s = 0.;
*c__ = 1.;
*sestpr = s1;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
*s = sqrt(tmp * tmp + 1.);
*sestpr = s2 * *s;
*c__ = *gamma / s2 / *s;
*s = d_sign(&c_b5, &alpha) / *s;
} else {
tmp = s2 / s1;
*c__ = sqrt(tmp * tmp + 1.);
*sestpr = s1 * *c__;
*s = alpha / s1 / *c__;
*c__ = d_sign(&c_b5, gamma) / *c__;
}
return 0;
} else {
/* normal case */
zeta1 = alpha / absest;
zeta2 = *gamma / absest;
b = (1. - zeta1 * zeta1 - zeta2 * zeta2) * .5;
*c__ = zeta1 * zeta1;
if (b > 0.) {
t = *c__ / (b + sqrt(b * b + *c__));
} else {
t = sqrt(b * b + *c__) - b;
}
sine = -zeta1 / t;
cosine = -zeta2 / (t + 1.);
tmp = sqrt(sine * sine + cosine * cosine);
*s = sine / tmp;
*c__ = cosine / tmp;
*sestpr = sqrt(t + 1.) * absest;
return 0;
}
} else if (*job == 2) {
/* Estimating smallest singular value */
/* special cases */
if (*sest == 0.) {
*sestpr = 0.;
if (MAX(absgam,absalp) == 0.) {
sine = 1.;
cosine = 0.;
} else {
sine = -(*gamma);
cosine = alpha;
}
/* Computing MAX */
d__1 = ABS(sine), d__2 = ABS(cosine);
s1 = MAX(d__1,d__2);
*s = sine / s1;
*c__ = cosine / s1;
tmp = sqrt(*s * *s + *c__ * *c__);
*s /= tmp;
*c__ /= tmp;
return 0;
} else if (absgam <= eps * absest) {
*s = 0.;
*c__ = 1.;
*sestpr = absgam;
return 0;
} else if (absalp <= eps * absest) {
s1 = absgam;
s2 = absest;
if (s1 <= s2) {
*s = 0.;
*c__ = 1.;
*sestpr = s1;
} else {
*s = 1.;
*c__ = 0.;
*sestpr = s2;
}
return 0;
} else if (absest <= eps * absalp || absest <= eps * absgam) {
s1 = absgam;
s2 = absalp;
if (s1 <= s2) {
tmp = s1 / s2;
*c__ = sqrt(tmp * tmp + 1.);
*sestpr = absest * (tmp / *c__);
*s = -(*gamma / s2) / *c__;
*c__ = d_sign(&c_b5, &alpha) / *c__;
} else {
tmp = s2 / s1;
*s = sqrt(tmp * tmp + 1.);
*sestpr = absest / *s;
*c__ = alpha / s1 / *s;
*s = -d_sign(&c_b5, gamma) / *s;
}
return 0;
} else {
/* normal case */
zeta1 = alpha / absest;
zeta2 = *gamma / absest;
/* Computing MAX */
d__3 = zeta1 * zeta1 + 1. + (d__1 = zeta1 * zeta2, ABS(d__1)),
d__4 = (d__2 = zeta1 * zeta2, ABS(d__2)) + zeta2 * zeta2;
norma = MAX(d__3,d__4);
/* See if root is closer to zero or to ONE */
test = (zeta1 - zeta2) * 2. * (zeta1 + zeta2) + 1.;
if (test >= 0.) {
/* root is close to zero, compute directly */
b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.) * .5;
*c__ = zeta2 * zeta2;
t = *c__ / (b + sqrt((d__1 = b * b - *c__, ABS(d__1))));
sine = zeta1 / (1. - t);
cosine = -zeta2 / t;
*sestpr = sqrt(t + eps * 4. * eps * norma) * absest;
} else {
/* root is closer to ONE, shift by that amount */
b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.) * .5;
*c__ = zeta1 * zeta1;
if (b >= 0.) {
t = -(*c__) / (b + sqrt(b * b + *c__));
} else {
t = b - sqrt(b * b + *c__);
}
sine = -zeta1 / t;
cosine = -zeta2 / (t + 1.);
*sestpr = sqrt(t + 1. + eps * 4. * eps * norma) * absest;
}
tmp = sqrt(sine * sine + cosine * cosine);
*s = sine / tmp;
*c__ = cosine / tmp;
return 0;
}
}
return 0;
/* End of DLAIC1 */
} /* dlaic1_ */