/* Subroutine */ int zzlgin_(real *xt, real *pwrten, integer *nlog)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
double r_lg10(real *), pow_ri(real *, integer *);
/* Local variables */
static integer nl;
static real xl;
/* Return PWRTEN and NTEN such that */
/* PWRTEN .LE. XT .LT. 10*PWRTEN AND PWRTEN = 10**NLOG */
/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*/
xl = r_lg10(xt) + 1e-5f;
/* Computing MAX */
i__1 = (integer) xl;
nl = max(i__1,-36);
if (xl < 0.f) {
--nl;
}
*pwrten = pow_ri(&c_b2, &nl);
*nlog = nl;
return 0;
} /* zzlgin_ */
integer nv2inirect_(integer *ifunc, integer *iparms)
{
/* System generated locals */
integer ret_val;
char ch__1[4];
/* Builtin functions */
double pow_ri(real *, integer *), pow_di(doublereal *, integer *);
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer ipowdele, ipowdlin;
static real r__;
extern integer lit_(char *, ftnlen);
static doublereal decc, drad;
extern /* Character */ VOID clit_(char *, ftnlen, integer *);
extern /* Subroutine */ int llopt_(doublereal *, doublereal *, integer *,
integer *);
static integer ipowecc, ipowrad, ipowlat, ipowlon;
/* Degrees Per Line Power */
/* Degrees Per Element Power */
/* Degrees Radian power */
/* Eccentricity Power */
/* ,ULLON */
/* Parameter adjustments */
--iparms;
/* Function Body */
if (*ifunc == 1) {
if (iparms[1] != lit_("RECT", (ftnlen)4)) {
goto L900;
}
rctcomrectnv2_1.itype = 1;
rctcomrectnv2_1.xrow = (real) iparms[2];
ipowlat = iparms[12];
if (ipowlat == 0) {
ipowlat = 4;
}
/* default is 10000 (10^4) */
rctcomrectnv2_1.zslat = iparms[3] / pow_ri(&c_b4, &ipowlat);
/* REAL Latitude */
rctcomrectnv2_1.xcol = (real) iparms[4];
ipowlon = iparms[13];
if (ipowlon == 0) {
ipowlon = 4;
}
rctcomrectnv2_1.zslon = iparms[5] / pow_ri(&c_b4, &ipowlon);
/* REAL Longitude */
ipowdlin = iparms[14];
if (ipowdlin == 0) {
ipowdlin = 4;
}
rctcomrectnv2_1.zdlat = iparms[6] / pow_ri(&c_b4, &ipowdlin);
/* REAL Degrees_per_line_latitude */
ipowdele = iparms[15];
if (ipowdele == 0) {
ipowdele = 4;
}
rctcomrectnv2_1.zdlon = iparms[7] / pow_ri(&c_b4, &ipowdele);
/* REAL Degrees_per_line_longitude */
ipowrad = iparms[16];
if (ipowrad == 0) {
ipowrad = 3;
}
drad = iparms[8] / pow_di(&c_b8, &ipowrad);
/* REAL Radius of the planet in mete */
r__ = drad;
ipowecc = iparms[17];
if (ipowecc == 0) {
ipowecc = 6;
}
decc = iparms[9] / pow_di(&c_b8, &ipowecc);
/* REAL Eccentricity */
rctcomrectnv2_1.iwest = iparms[11];
/* West positive vs. West negative */
if (rctcomrectnv2_1.iwest >= 0) {
rctcomrectnv2_1.iwest = 1;
}
llopt_(&drad, &decc, &rctcomrectnv2_1.iwest, &iparms[10]);
/* Initialze LLCART c */
if (rctcomrectnv2_1.xcol == 1.f) {
/* special case of XCOL not located at ima */
rctcomrectnv2_1.zslon -= rctcomrectnv2_1.iwest * 180.f;
/* -- so assume it's the left edge(duh) */
}
} else if (*ifunc == 2) {
clit_(ch__1, (ftnlen)4, &iparms[1]);
if (i_indx(ch__1, "XY", (ftnlen)4, (ftnlen)2) != 0) {
rctcomrectnv2_1.itype = 1;
}
clit_(ch__1, (ftnlen)4, &iparms[1]);
if (i_indx(ch__1, "LL", (ftnlen)4, (ftnlen)2) != 0) {
rctcomrectnv2_1.itype = 2;
}
}
ret_val = 0;
return ret_val;
L900:
ret_val = -1;
return ret_val;
} /* nv2inirect_ */
/*< SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) >*/
/* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real *
eps, integer *emin, real *rmin, integer *emax, real *rmax)
{
/* Initialized data */
static logical first = TRUE_; /* runtime-initialized constant */
static logical iwarn = FALSE_; /* runtime-initialized constant */
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double pow_ri(real *, integer *);
/* Local variables */
real a, b, c__;
integer i__;
static integer lt; /* runtime-initialized constant */
real one, two;
logical ieee;
real half;
logical lrnd = 0; //variable 'lrnd' is used uninitialized whenever 'if' condition is false [-Wsometimes-uninitialized]
static real leps; /* runtime-initialized constant */
real zero;
static integer lbeta; /* runtime-initialized constant */
real rbase;
static integer lemin, lemax; /* runtime-initialized constant */
integer gnmin;
real small;
integer gpmin;
real third;
static real lrmin, lrmax; /* runtime-initialized constant */
real sixth;
logical lieee1;
extern /* Subroutine */ int slamc1_(integer *, integer *, logical *,
logical *);
extern doublereal slamc3_(real *, real *);
extern /* Subroutine */ int slamc4_(integer *, real *, integer *),
slamc5_(integer *, integer *, integer *, logical *, integer *,
real *);
integer ngnmin, ngpmin;
/* -- LAPACK auxiliary routine (version 1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/*< LOGICAL RND >*/
/*< INTEGER BETA, EMAX, EMIN, T >*/
/*< REAL EPS, RMAX, RMIN >*/
/* .. */
/* Purpose */
/* ======= */
/* SLAMC2 determines the machine parameters specified in its argument */
/* list. */
/* Arguments */
/* ========= */
/* BETA (output) INTEGER */
/* The base of the machine. */
/* T (output) INTEGER */
/* The number of ( BETA ) digits in the mantissa. */
/* RND (output) LOGICAL */
/* Specifies whether proper rounding ( RND = .TRUE. ) or */
/* chopping ( RND = .FALSE. ) occurs in addition. This may not */
/* be a reliable guide to the way in which the machine performs */
/* its arithmetic. */
/* EPS (output) REAL */
/* The smallest positive number such that */
/* fl( 1.0 - EPS ) .LT. 1.0, */
/* where fl denotes the computed value. */
/* EMIN (output) INTEGER */
/* The minimum exponent before (gradual) underflow occurs. */
/* RMIN (output) REAL */
/* The smallest normalized number for the machine, given by */
/* BASE**( EMIN - 1 ), where BASE is the floating point value */
/* of BETA. */
/* EMAX (output) INTEGER */
/* The maximum exponent before overflow occurs. */
/* RMAX (output) REAL */
/* The largest positive number for the machine, given by */
/* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */
/* value of BETA. */
/* Further Details */
/* =============== */
/* The computation of EPS is based on a routine PARANOIA by */
/* W. Kahan of the University of California at Berkeley. */
/* ===================================================================== */
/* .. Local Scalars .. */
/*< LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND >*/
/*< >*/
/*< >*/
/* .. */
/* .. External Functions .. */
/*< REAL SLAMC3 >*/
/*< EXTERNAL SLAMC3 >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL SLAMC1, SLAMC4, SLAMC5 >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, MAX, MIN >*/
/* .. */
/* .. Save statement .. */
/*< >*/
/* .. */
/* .. Data statements .. */
/*< DATA FIRST / .TRUE. / , IWARN / .FALSE. / >*/
/* .. */
/* .. Executable Statements .. */
/*< IF( FIRST ) THEN >*/
if (first) {
/*< FIRST = .FALSE. >*/
first = FALSE_;
/*< ZERO = 0 >*/
zero = (float)0.;
/*< ONE = 1 >*/
one = (float)1.;
/*< TWO = 2 >*/
two = (float)2.;
/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */
/* BETA, T, RND, EPS, EMIN and RMIN. */
/* Throughout this routine we use the function SLAMC3 to ensure */
/* that relevant values are stored and not held in registers, or */
/* are not affected by optimizers. */
/* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */
/*< CALL SLAMC1( LBETA, LT, LRND, LIEEE1 ) >*/
slamc1_(&lbeta, <, &lrnd, &lieee1);
/* Start to find EPS. */
/*< B = LBETA >*/
b = (real) lbeta;
/*< A = B**( -LT ) >*/
i__1 = -lt;
a = pow_ri(&b, &i__1);
/*< LEPS = A >*/
leps = a;
/* Try some tricks to see whether or not this is the correct EPS. */
/*< B = TWO / 3 >*/
b = two / 3;
/*< HALF = ONE / 2 >*/
half = one / 2;
/*< SIXTH = SLAMC3( B, -HALF ) >*/
r__1 = -half;
sixth = slamc3_(&b, &r__1);
/*< THIRD = SLAMC3( SIXTH, SIXTH ) >*/
third = slamc3_(&sixth, &sixth);
/*< B = SLAMC3( THIRD, -HALF ) >*/
r__1 = -half;
b = slamc3_(&third, &r__1);
/*< B = SLAMC3( B, SIXTH ) >*/
b = slamc3_(&b, &sixth);
/*< B = ABS( B ) >*/
b = dabs(b);
/*< >*/
if (b < leps) {
b = leps;
}
/*< LEPS = 1 >*/
leps = (float)1.;
/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
/*< 10 CONTINUE >*/
L10:
/*< IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN >*/
if (leps > b && b > zero) {
/*< LEPS = B >*/
leps = b;
/*< C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) >*/
r__1 = half * leps;
/* Computing 5th power */
r__3 = two, r__4 = r__3, r__3 *= r__3;
/* Computing 2nd power */
r__5 = leps;
r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
c__ = slamc3_(&r__1, &r__2);
/*< C = SLAMC3( HALF, -C ) >*/
r__1 = -c__;
c__ = slamc3_(&half, &r__1);
/*< B = SLAMC3( HALF, C ) >*/
b = slamc3_(&half, &c__);
/*< C = SLAMC3( HALF, -B ) >*/
r__1 = -b;
c__ = slamc3_(&half, &r__1);
/*< B = SLAMC3( HALF, C ) >*/
b = slamc3_(&half, &c__);
/*< GO TO 10 >*/
goto L10;
/*< END IF >*/
}
/* + END WHILE */
/*< >*/
if (a < leps) {
leps = a;
}
/* Computation of EPS complete. */
/* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */
/* Keep dividing A by BETA until (gradual) underflow occurs. This */
/* is detected when we cannot recover the previous A. */
/*< RBASE = ONE / LBETA >*/
rbase = one / lbeta;
/*< SMALL = ONE >*/
small = one;
/*< DO 20 I = 1, 3 >*/
for (i__ = 1; i__ <= 3; ++i__) {
/*< SMALL = SLAMC3( SMALL*RBASE, ZERO ) >*/
r__1 = small * rbase;
small = slamc3_(&r__1, &zero);
/*< 20 CONTINUE >*/
/* L20: */
}
/*< A = SLAMC3( ONE, SMALL ) >*/
a = slamc3_(&one, &small);
/*< CALL SLAMC4( NGPMIN, ONE, LBETA ) >*/
slamc4_(&ngpmin, &one, &lbeta);
/*< CALL SLAMC4( NGNMIN, -ONE, LBETA ) >*/
r__1 = -one;
slamc4_(&ngnmin, &r__1, &lbeta);
/*< CALL SLAMC4( GPMIN, A, LBETA ) >*/
slamc4_(&gpmin, &a, &lbeta);
/*< CALL SLAMC4( GNMIN, -A, LBETA ) >*/
r__1 = -a;
slamc4_(&gnmin, &r__1, &lbeta);
/*< IEEE = .FALSE. >*/
ieee = FALSE_;
/*< IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN >*/
if (ngpmin == ngnmin && gpmin == gnmin) {
/*< IF( NGPMIN.EQ.GPMIN ) THEN >*/
if (ngpmin == gpmin) {
/*< LEMIN = NGPMIN >*/
lemin = ngpmin;
/* ( Non twos-complement machines, no gradual underflow; */
/* e.g., VAX ) */
/*< ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN >*/
} else if (gpmin - ngpmin == 3) {
/*< LEMIN = NGPMIN - 1 + LT >*/
lemin = ngpmin - 1 + lt;
/*< IEEE = .TRUE. >*/
ieee = TRUE_;
/* ( Non twos-complement machines, with gradual underflow; */
/* e.g., IEEE standard followers ) */
/*< ELSE >*/
} else {
/*< LEMIN = MIN( NGPMIN, GPMIN ) >*/
lemin = min(ngpmin,gpmin);
/* ( A guess; no known machine ) */
/*< IWARN = .TRUE. >*/
iwarn = TRUE_;
/*< END IF >*/
}
/*< ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN >*/
} else if (ngpmin == gpmin && ngnmin == gnmin) {
/*< IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN >*/
if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
/*< LEMIN = MAX( NGPMIN, NGNMIN ) >*/
lemin = max(ngpmin,ngnmin);
/* ( Twos-complement machines, no gradual underflow; */
/* e.g., CYBER 205 ) */
/*< ELSE >*/
} else {
/*< LEMIN = MIN( NGPMIN, NGNMIN ) >*/
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
/*< IWARN = .TRUE. >*/
iwarn = TRUE_;
/*< END IF >*/
}
/*< >*/
} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
{
/*< IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN >*/
if (gpmin - min(ngpmin,ngnmin) == 3) {
/*< LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT >*/
lemin = max(ngpmin,ngnmin) - 1 + lt;
/* ( Twos-complement machines with gradual underflow; */
/* no known machine ) */
/*< ELSE >*/
} else {
/*< LEMIN = MIN( NGPMIN, NGNMIN ) >*/
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
/*< IWARN = .TRUE. >*/
iwarn = TRUE_;
/*< END IF >*/
}
/*< ELSE >*/
} else {
/*< LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) >*/
/* Computing MIN */
i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
lemin = min(i__1,gnmin);
/* ( A guess; no known machine ) */
/*< IWARN = .TRUE. >*/
iwarn = TRUE_;
/*< END IF >*/
}
/* ** */
/* Comment out this if block if EMIN is ok */
/*< IF( IWARN ) THEN >*/
if (iwarn) {
/*< FIRST = .TRUE. >*/
first = TRUE_;
/*< WRITE( 6, FMT = 9999 )LEMIN >*/
printf("\n\n WARNING. The value EMIN may be incorrect: - ");
printf("EMIN = %8li\n",lemin);
printf("If, after inspection, the value EMIN looks acceptable");
printf(" please comment out\n the IF block as marked within the");
printf(" code of routine SLAMC2,\n otherwise supply EMIN");
printf(" explicitly.\n");
/*< END IF >*/
}
/* ** */
/* Assume IEEE arithmetic if we found denormalised numbers above, */
/* or if arithmetic seems to round in the IEEE style, determined */
/* in routine SLAMC1. A true IEEE machine should have both things */
/* true; however, faulty machines may have one or the other. */
/*< IEEE = IEEE .OR. LIEEE1 >*/
ieee = ieee || lieee1;
/* Compute RMIN by successive division by BETA. We could compute */
/* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */
/* this computation. */
/*< LRMIN = 1 >*/
lrmin = (float)1.;
/*< DO 30 I = 1, 1 - LEMIN >*/
i__1 = 1 - lemin;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< LRMIN = SLAMC3( LRMIN*RBASE, ZERO ) >*/
r__1 = lrmin * rbase;
lrmin = slamc3_(&r__1, &zero);
/*< 30 CONTINUE >*/
/* L30: */
}
/* Finally, call SLAMC5 to compute EMAX and RMAX. */
/*< CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) >*/
slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
/*< END IF >*/
}
/*< BETA = LBETA >*/
*beta = lbeta;
/*< T = LT >*/
*t = lt;
/*< RND = LRND >*/
*rnd = lrnd;
/*< EPS = LEPS >*/
*eps = leps;
/*< EMIN = LEMIN >*/
*emin = lemin;
/*< RMIN = LRMIN >*/
*rmin = lrmin;
/*< EMAX = LEMAX >*/
*emax = lemax;
/*< RMAX = LRMAX >*/
*rmax = lrmax;
/*< RETURN >*/
return 0;
/*< 9 >*/
/* End of SLAMC2 */
/*< END >*/
} /* slamc2_ */
/* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real *
eps, integer *emin, real *rmin, integer *emax, real *rmax)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
SLAMC2 determines the machine parameters specified in its argument
list.
Arguments
=========
BETA (output) INTEGER
The base of the machine.
T (output) INTEGER
The number of ( BETA ) digits in the mantissa.
RND (output) LOGICAL
Specifies whether proper rounding ( RND = .TRUE. ) or
chopping ( RND = .FALSE. ) occurs in addition. This may not
be a reliable guide to the way in which the machine performs
its arithmetic.
EPS (output) REAL
The smallest positive number such that
fl( 1.0 - EPS ) .LT. 1.0,
where fl denotes the computed value.
EMIN (output) INTEGER
The minimum exponent before (gradual) underflow occurs.
RMIN (output) REAL
The smallest normalized number for the machine, given by
BASE**( EMIN - 1 ), where BASE is the floating point value
of BETA.
EMAX (output) INTEGER
The maximum exponent before overflow occurs.
RMAX (output) REAL
The largest positive number for the machine, given by
BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
value of BETA.
Further Details
===============
The computation of EPS is based on a routine PARANOIA by
W. Kahan of the University of California at Berkeley.
=====================================================================
*/
/* Table of constant values */
static integer c__1 = 1;
/* Initialized data */
static logical first = TRUE_;
static logical iwarn = FALSE_;
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double pow_ri(real *, integer *);
/* Local variables */
static logical ieee;
static real half;
static logical lrnd;
static real leps, zero, a, b, c;
static integer i, lbeta;
static real rbase;
static integer lemin, lemax, gnmin;
static real small;
static integer gpmin;
static real third, lrmin, lrmax, sixth;
static logical lieee1;
extern /* Subroutine */ int slamc1_(integer *, integer *, logical *,
logical *);
extern doublereal slamc3_(real *, real *);
extern /* Subroutine */ int slamc4_(integer *, real *, integer *),
slamc5_(integer *, integer *, integer *, logical *, integer *,
real *);
static integer lt, ngnmin, ngpmin;
static real one, two;
if (first) {
first = FALSE_;
zero = 0.f;
one = 1.f;
two = 2.f;
/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values
of
BETA, T, RND, EPS, EMIN and RMIN.
Throughout this routine we use the function SLAMC3 to ens
ure
that relevant values are stored and not held in registers,
or
are not affected by optimizers.
SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
*/
slamc1_(&lbeta, <, &lrnd, &lieee1);
/* Start to find EPS. */
b = (real) lbeta;
i__1 = -lt;
a = pow_ri(&b, &i__1);
leps = a;
/* Try some tricks to see whether or not this is the correct E
PS. */
b = two / 3;
half = one / 2;
r__1 = -(doublereal)half;
sixth = slamc3_(&b, &r__1);
third = slamc3_(&sixth, &sixth);
r__1 = -(doublereal)half;
b = slamc3_(&third, &r__1);
b = slamc3_(&b, &sixth);
b = dabs(b);
if (b < leps) {
b = leps;
}
leps = 1.f;
/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
L10:
if (leps > b && b > zero) {
leps = b;
r__1 = half * leps;
/* Computing 5th power */
r__3 = two, r__4 = r__3, r__3 *= r__3;
/* Computing 2nd power */
r__5 = leps;
r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
c = slamc3_(&r__1, &r__2);
r__1 = -(doublereal)c;
c = slamc3_(&half, &r__1);
b = slamc3_(&half, &c);
r__1 = -(doublereal)b;
c = slamc3_(&half, &r__1);
b = slamc3_(&half, &c);
goto L10;
}
/* + END WHILE */
if (a < leps) {
leps = a;
}
/* Computation of EPS complete.
Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3
)).
Keep dividing A by BETA until (gradual) underflow occurs. T
his
is detected when we cannot recover the previous A. */
rbase = one / lbeta;
small = one;
for (i = 1; i <= 3; ++i) {
r__1 = small * rbase;
small = slamc3_(&r__1, &zero);
/* L20: */
}
a = slamc3_(&one, &small);
slamc4_(&ngpmin, &one, &lbeta);
r__1 = -(doublereal)one;
slamc4_(&ngnmin, &r__1, &lbeta);
slamc4_(&gpmin, &a, &lbeta);
r__1 = -(doublereal)a;
slamc4_(&gnmin, &r__1, &lbeta);
ieee = FALSE_;
if (ngpmin == ngnmin && gpmin == gnmin) {
if (ngpmin == gpmin) {
lemin = ngpmin;
/* ( Non twos-complement machines, no gradual under
flow;
e.g., VAX ) */
} else if (gpmin - ngpmin == 3) {
lemin = ngpmin - 1 + lt;
ieee = TRUE_;
/* ( Non twos-complement machines, with gradual und
erflow;
e.g., IEEE standard followers ) */
} else {
lemin = min(ngpmin,gpmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if (ngpmin == gpmin && ngnmin == gnmin) {
if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
lemin = max(ngpmin,ngnmin);
/* ( Twos-complement machines, no gradual underflow
;
e.g., CYBER 205 ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
{
if (gpmin - min(ngpmin,ngnmin) == 3) {
lemin = max(ngpmin,ngnmin) - 1 + lt;
/* ( Twos-complement machines with gradual underflo
w;
no known machine ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else {
/* Computing MIN */
i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
lemin = min(i__1,gnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
/* **
Comment out this if block if EMIN is ok */
if (iwarn) {
first = TRUE_;
printf("\n\n WARNING. The value EMIN may be incorrect:- ");
printf("EMIN = %8i\n",lemin);
printf("If, after inspection, the value EMIN looks acceptable");
printf("please comment out \n the IF block as marked within the");
printf("code of routine SLAMC2, \n otherwise supply EMIN");
printf("explicitly.\n");
}
/* **
Assume IEEE arithmetic if we found denormalised numbers abo
ve,
or if arithmetic seems to round in the IEEE style, determi
ned
in routine SLAMC1. A true IEEE machine should have both thi
ngs
true; however, faulty machines may have one or the other. */
ieee = ieee || lieee1;
/* Compute RMIN by successive division by BETA. We could comp
ute
RMIN as BASE**( EMIN - 1 ), but some machines underflow dur
ing
this computation. */
lrmin = 1.f;
i__1 = 1 - lemin;
for (i = 1; i <= 1-lemin; ++i) {
r__1 = lrmin * rbase;
lrmin = slamc3_(&r__1, &zero);
/* L30: */
}
/* Finally, call SLAMC5 to compute EMAX and RMAX. */
slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
}
*beta = lbeta;
*t = lt;
*rnd = lrnd;
*eps = leps;
*emin = lemin;
*rmin = lrmin;
*emax = lemax;
*rmax = lrmax;
return 0;
/* End of SLAMC2 */
} /* slamc2_ */
/* Subroutine */ int slatm4_(integer *itype, integer *n, integer *nz1,
integer *nz2, integer *isign, real *amagn, real *rcond, real *triang,
integer *idist, integer *iseed, real *a, integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
doublereal d__1, d__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), pow_ri(real *, integer *), log(
doublereal), exp(doublereal), sqrt(doublereal);
/* Local variables */
static integer kbeg, isdb, kend, ioff, isde, klen;
static real temp;
static integer i__, k;
static real alpha;
static integer jc, jd;
static real cl, cr;
static integer jr;
static real sl, sr;
extern doublereal slamch_(char *);
static real safmin;
extern doublereal slaran_(integer *), slarnd_(integer *, integer *);
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
static real sv1, sv2;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK auxiliary test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SLATM4 generates basic square matrices, which may later be
multiplied by others in order to produce test matrices. It is
intended mainly to be used to test the generalized eigenvalue
routines.
It first generates the diagonal and (possibly) subdiagonal,
according to the value of ITYPE, NZ1, NZ2, ISIGN, AMAGN, and RCOND.
It then fills in the upper triangle with random numbers, if TRIANG is
non-zero.
Arguments
=========
ITYPE (input) INTEGER
The "type" of matrix on the diagonal and sub-diagonal.
If ITYPE < 0, then type abs(ITYPE) is generated and then
swapped end for end (A(I,J) := A'(N-J,N-I).) See also
the description of AMAGN and ISIGN.
Special types:
= 0: the zero matrix.
= 1: the identity.
= 2: a transposed Jordan block.
= 3: If N is odd, then a k+1 x k+1 transposed Jordan block
followed by a k x k identity block, where k=(N-1)/2.
If N is even, then k=(N-2)/2, and a zero diagonal entry
is tacked onto the end.
Diagonal types. The diagonal consists of NZ1 zeros, then
k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE
specifies the nonzero diagonal entries as follows:
= 4: 1, ..., k
= 5: 1, RCOND, ..., RCOND
= 6: 1, ..., 1, RCOND
= 7: 1, a, a^2, ..., a^(k-1)=RCOND
= 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
= 9: random numbers chosen from (RCOND,1)
= 10: random numbers with distribution IDIST (see SLARND.)
N (input) INTEGER
The order of the matrix.
NZ1 (input) INTEGER
If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
be zero.
NZ2 (input) INTEGER
If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
be zero.
ISIGN (input) INTEGER
= 0: The sign of the diagonal and subdiagonal entries will
be left unchanged.
= 1: The diagonal and subdiagonal entries will have their
sign changed at random.
= 2: If ITYPE is 2 or 3, then the same as ISIGN=1.
Otherwise, with probability 0.5, odd-even pairs of
diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be
converted to a 2x2 block by pre- and post-multiplying
by distinct random orthogonal rotations. The remaining
diagonal entries will have their sign changed at random.
AMAGN (input) REAL
The diagonal and subdiagonal entries will be multiplied by
AMAGN.
RCOND (input) REAL
If abs(ITYPE) > 4, then the smallest diagonal entry will be
entry will be RCOND. RCOND must be between 0 and 1.
TRIANG (input) REAL
The entries above the diagonal will be random numbers with
magnitude bounded by TRIANG (i.e., random numbers multiplied
by TRIANG.)
IDIST (input) INTEGER
Specifies the type of distribution to be used to generate a
random matrix.
= 1: UNIFORM( 0, 1 )
= 2: UNIFORM( -1, 1 )
= 3: NORMAL ( 0, 1 )
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The values of ISEED are changed on exit, and can
be used in the next call to SLATM4 to continue the same
random number sequence.
Note: ISEED(4) should be odd, for the random number generator
used at present.
A (output) REAL array, dimension (LDA, N)
Array to be computed.
LDA (input) INTEGER
Leading dimension of A. Must be at least 1 and at least N.
=====================================================================
Parameter adjustments */
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
slaset_("Full", n, n, &c_b3, &c_b3, &a[a_offset], lda);
/* Insure a correct ISEED */
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
and RCOND */
if (*itype != 0) {
if (abs(*itype) >= 4) {
/* Computing MAX
Computing MIN */
i__3 = *n, i__4 = *nz1 + 1;
i__1 = 1, i__2 = min(i__3,i__4);
kbeg = max(i__1,i__2);
/* Computing MAX
Computing MIN */
i__3 = *n, i__4 = *n - *nz2;
i__1 = kbeg, i__2 = min(i__3,i__4);
kend = max(i__1,i__2);
klen = kend + 1 - kbeg;
} else {
kbeg = 1;
kend = *n;
klen = *n;
}
isdb = 1;
isde = 0;
switch (abs(*itype)) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L80;
case 5: goto L100;
case 6: goto L120;
case 7: goto L140;
case 8: goto L160;
case 9: goto L180;
case 10: goto L200;
}
/* |ITYPE| = 1: Identity */
L10:
i__1 = *n;
for (jd = 1; jd <= i__1; ++jd) {
a_ref(jd, jd) = 1.f;
/* L20: */
}
goto L220;
/* |ITYPE| = 2: Transposed Jordan block */
L30:
i__1 = *n - 1;
for (jd = 1; jd <= i__1; ++jd) {
a_ref(jd + 1, jd) = 1.f;
/* L40: */
}
isdb = 1;
isde = *n - 1;
goto L220;
/* |ITYPE| = 3: Transposed Jordan block, followed by the identity. */
L50:
k = (*n - 1) / 2;
i__1 = k;
for (jd = 1; jd <= i__1; ++jd) {
a_ref(jd + 1, jd) = 1.f;
/* L60: */
}
isdb = 1;
isde = k;
i__1 = (k << 1) + 1;
for (jd = k + 2; jd <= i__1; ++jd) {
a_ref(jd, jd) = 1.f;
/* L70: */
}
goto L220;
/* |ITYPE| = 4: 1,...,k */
L80:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = (real) (jd - *nz1);
/* L90: */
}
goto L220;
/* |ITYPE| = 5: One large D value: */
L100:
i__1 = kend;
for (jd = kbeg + 1; jd <= i__1; ++jd) {
a_ref(jd, jd) = *rcond;
/* L110: */
}
a_ref(kbeg, kbeg) = 1.f;
goto L220;
/* |ITYPE| = 6: One small D value: */
L120:
i__1 = kend - 1;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = 1.f;
/* L130: */
}
a_ref(kend, kend) = *rcond;
goto L220;
/* |ITYPE| = 7: Exponentially distributed D values: */
L140:
a_ref(kbeg, kbeg) = 1.f;
if (klen > 1) {
d__1 = (doublereal) (*rcond);
d__2 = (doublereal) (1.f / (real) (klen - 1));
alpha = pow_dd(&d__1, &d__2);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
a_ref(*nz1 + i__, *nz1 + i__) = pow_ri(&alpha, &i__2);
/* L150: */
}
}
goto L220;
/* |ITYPE| = 8: Arithmetically distributed D values: */
L160:
a_ref(kbeg, kbeg) = 1.f;
if (klen > 1) {
alpha = (1.f - *rcond) / (real) (klen - 1);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
a_ref(*nz1 + i__, *nz1 + i__) = (real) (klen - i__) * alpha +
*rcond;
/* L170: */
}
}
goto L220;
/* |ITYPE| = 9: Randomly distributed D values on ( RCOND, 1): */
L180:
alpha = log(*rcond);
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = exp(alpha * slaran_(&iseed[1]));
/* L190: */
}
goto L220;
/* |ITYPE| = 10: Randomly distributed D values from DIST */
L200:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = slarnd_(idist, &iseed[1]);
/* L210: */
}
L220:
/* Scale by AMAGN */
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
a_ref(jd, jd) = *amagn * a_ref(jd, jd);
/* L230: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
a_ref(jd + 1, jd) = *amagn * a_ref(jd + 1, jd);
/* L240: */
}
/* If ISIGN = 1 or 2, assign random signs to diagonal and
subdiagonal */
if (*isign > 0) {
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
if (a_ref(jd, jd) != 0.f) {
if (slaran_(&iseed[1]) > .5f) {
a_ref(jd, jd) = -a_ref(jd, jd);
}
}
/* L250: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
if (a_ref(jd + 1, jd) != 0.f) {
if (slaran_(&iseed[1]) > .5f) {
a_ref(jd + 1, jd) = -a_ref(jd + 1, jd);
}
}
/* L260: */
}
}
/* Reverse if ITYPE < 0 */
if (*itype < 0) {
i__1 = (kbeg + kend - 1) / 2;
for (jd = kbeg; jd <= i__1; ++jd) {
temp = a_ref(jd, jd);
a_ref(jd, jd) = a_ref(kbeg + kend - jd, kbeg + kend - jd);
a_ref(kbeg + kend - jd, kbeg + kend - jd) = temp;
/* L270: */
}
i__1 = (*n - 1) / 2;
for (jd = 1; jd <= i__1; ++jd) {
temp = a_ref(jd + 1, jd);
a_ref(jd + 1, jd) = a_ref(*n + 1 - jd, *n - jd);
a_ref(*n + 1 - jd, *n - jd) = temp;
/* L280: */
}
}
/* If ISIGN = 2, and no subdiagonals already, then apply
random rotations to make 2x2 blocks. */
if (*isign == 2 && *itype != 2 && *itype != 3) {
safmin = slamch_("S");
i__1 = kend - 1;
for (jd = kbeg; jd <= i__1; jd += 2) {
if (slaran_(&iseed[1]) > .5f) {
/* Rotation on left. */
cl = slaran_(&iseed[1]) * 2.f - 1.f;
sl = slaran_(&iseed[1]) * 2.f - 1.f;
/* Computing MAX
Computing 2nd power */
r__3 = cl;
/* Computing 2nd power */
r__4 = sl;
r__1 = safmin, r__2 = sqrt(r__3 * r__3 + r__4 * r__4);
temp = 1.f / dmax(r__1,r__2);
cl *= temp;
sl *= temp;
/* Rotation on right. */
cr = slaran_(&iseed[1]) * 2.f - 1.f;
sr = slaran_(&iseed[1]) * 2.f - 1.f;
/* Computing MAX
Computing 2nd power */
r__3 = cr;
/* Computing 2nd power */
r__4 = sr;
r__1 = safmin, r__2 = sqrt(r__3 * r__3 + r__4 * r__4);
temp = 1.f / dmax(r__1,r__2);
cr *= temp;
sr *= temp;
/* Apply */
sv1 = a_ref(jd, jd);
sv2 = a_ref(jd + 1, jd + 1);
a_ref(jd, jd) = cl * cr * sv1 + sl * sr * sv2;
a_ref(jd + 1, jd) = -sl * cr * sv1 + cl * sr * sv2;
a_ref(jd, jd + 1) = -cl * sr * sv1 + sl * cr * sv2;
a_ref(jd + 1, jd + 1) = sl * sr * sv1 + cl * cr * sv2;
}
/* L290: */
}
}
}
/* Fill in upper triangle (except for 2x2 blocks) */
if (*triang != 0.f) {
if (*isign != 2 || *itype == 2 || *itype == 3) {
ioff = 1;
} else {
ioff = 2;
i__1 = *n - 1;
for (jr = 1; jr <= i__1; ++jr) {
if (a_ref(jr + 1, jr) == 0.f) {
a_ref(jr, jr + 1) = *triang * slarnd_(idist, &iseed[1]);
}
/* L300: */
}
}
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
i__2 = jc - ioff;
for (jr = 1; jr <= i__2; ++jr) {
a_ref(jr, jc) = *triang * slarnd_(idist, &iseed[1]);
/* L310: */
}
/* L320: */
}
}
return 0;
/* End of SLATM4 */
} /* slatm4_ */
/* Subroutine */
int sgbequb_(integer *m, integer *n, integer *kl, integer * ku, real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3;
/* Builtin functions */
double log(doublereal), pow_ri(real *, integer *);
/* Local variables */
integer i__, j, kd;
real radix, rcmin, rcmax;
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
real bignum, logrdx, smlnum;
/* -- 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 .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--r__;
--c__;
/* Function Body */
*info = 0;
if (*m < 0)
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*kl < 0)
{
*info = -3;
}
else if (*ku < 0)
{
*info = -4;
}
else if (*ldab < *kl + *ku + 1)
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SGBEQUB", &i__1);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0)
{
*rowcnd = 1.f;
*colcnd = 1.f;
*amax = 0.f;
return 0;
}
/* Get machine constants. Assume SMLNUM is a power of the radix. */
smlnum = slamch_("S");
bignum = 1.f / smlnum;
radix = slamch_("B");
logrdx = log(radix);
/* Compute row scale factors. */
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
r__[i__] = 0.f;
/* L10: */
}
/* Find the maximum element in each row. */
kd = *ku + 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__2 = j - *ku;
/* Computing MIN */
i__4 = j + *kl;
i__3 = min(i__4,*m);
for (i__ = max(i__2,1);
i__ <= i__3;
++i__)
{
/* Computing MAX */
r__2 = r__[i__];
r__3 = (r__1 = ab[kd + i__ - j + j * ab_dim1], f2c_abs(r__1)); // , expr subst
r__[i__] = max(r__2,r__3);
/* L20: */
}
/* L30: */
}
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (r__[i__] > 0.f)
{
i__3 = (integer) (log(r__[i__]) / logrdx);
r__[i__] = pow_ri(&radix, &i__3);
}
}
/* Find the maximum and minimum scale factors. */
rcmin = bignum;
rcmax = 0.f;
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Computing MAX */
r__1 = rcmax;
r__2 = r__[i__]; // , expr subst
rcmax = max(r__1,r__2);
/* Computing MIN */
r__1 = rcmin;
r__2 = r__[i__]; // , expr subst
rcmin = min(r__1,r__2);
/* L40: */
}
*amax = rcmax;
if (rcmin == 0.f)
{
/* Find the first zero scale factor and return an error code. */
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
if (r__[i__] == 0.f)
{
*info = i__;
return 0;
}
/* L50: */
}
}
else
{
/* Invert the scale factors. */
i__1 = *m;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Computing MIN */
/* Computing MAX */
r__2 = r__[i__];
r__1 = max(r__2,smlnum);
r__[i__] = 1.f / min(r__1,bignum);
/* L60: */
}
/* Compute ROWCND = min(R(I)) / max(R(I)). */
*rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
}
/* Compute column scale factors. */
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
c__[j] = 0.f;
/* L70: */
}
/* Find the maximum element in each column, */
/* assuming the row scaling computed above. */
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MAX */
i__3 = j - *ku;
/* Computing MIN */
i__4 = j + *kl;
i__2 = min(i__4,*m);
for (i__ = max(i__3,1);
i__ <= i__2;
++i__)
{
/* Computing MAX */
r__2 = c__[j];
r__3 = (r__1 = ab[kd + i__ - j + j * ab_dim1], f2c_abs( r__1)) * r__[i__]; // , expr subst
c__[j] = max(r__2,r__3);
/* L80: */
}
if (c__[j] > 0.f)
{
i__2 = (integer) (log(c__[j]) / logrdx);
c__[j] = pow_ri(&radix, &i__2);
}
/* L90: */
}
/* Find the maximum and minimum scale factors. */
rcmin = bignum;
rcmax = 0.f;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
r__1 = rcmin;
r__2 = c__[j]; // , expr subst
rcmin = min(r__1,r__2);
/* Computing MAX */
r__1 = rcmax;
r__2 = c__[j]; // , expr subst
rcmax = max(r__1,r__2);
/* L100: */
}
if (rcmin == 0.f)
{
/* Find the first zero scale factor and return an error code. */
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
if (c__[j] == 0.f)
{
*info = *m + j;
return 0;
}
/* L110: */
}
}
else
{
/* Invert the scale factors. */
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
/* Computing MAX */
r__2 = c__[j];
r__1 = max(r__2,smlnum);
c__[j] = 1.f / min(r__1,bignum);
/* L120: */
}
/* Compute COLCND = min(C(J)) / max(C(J)). */
*colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
}
return 0;
/* End of SGBEQUB */
}
/* DECK CHU */
doublereal chu_(real *a, real *b, real *x)
{
/* Initialized data */
static real pi = 3.14159265358979324f;
static real eps = 0.f;
/* System generated locals */
integer i__1;
real ret_val, r__1, r__2, r__3;
doublereal d__1, d__2;
/* Local variables */
static integer i__, m, n;
static real t, a0, b0, c0, xi, xn, xi1, sum;
extern doublereal gamr_(real *);
static real beps;
extern doublereal poch_(real *, real *);
static real alnx, pch1i;
extern doublereal poch1_(real *, real *), r9chu_(real *, real *, real *);
static real xeps1;
extern doublereal gamma_(real *);
static real aintb;
static integer istrt;
static real pch1ai;
extern doublereal r1mach_(integer *);
static real gamri1, pochai, gamrni, factor;
extern doublereal exprel_(real *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static real xtoeps;
/* ***BEGIN PROLOGUE CHU */
/* ***PURPOSE Compute the logarithmic confluent hypergeometric function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C11 */
/* ***TYPE SINGLE PRECISION (CHU-S, DCHU-D) */
/* ***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* CHU computes the logarithmic confluent hypergeometric function, */
/* U(A,B,X). */
/* Input Parameters: */
/* A real */
/* B real */
/* X real and positive */
/* This routine is not valid when 1+A-B is close to zero if X is small. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED EXPREL, GAMMA, GAMR, POCH, POCH1, R1MACH, R9CHU, */
/* XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770801 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* ***END PROLOGUE CHU */
/* ***FIRST EXECUTABLE STATEMENT CHU */
if (eps == 0.f) {
eps = r1mach_(&c__3);
}
if (*x == 0.f) {
xermsg_("SLATEC", "CHU", "X IS ZERO SO CHU IS INFINITE", &c__1, &c__2,
(ftnlen)6, (ftnlen)3, (ftnlen)28);
}
if (*x < 0.f) {
xermsg_("SLATEC", "CHU", "X IS NEGATIVE, USE CCHU", &c__2, &c__2, (
ftnlen)6, (ftnlen)3, (ftnlen)23);
}
/* Computing MAX */
r__2 = dabs(*a);
/* Computing MAX */
r__3 = (r__1 = *a + 1.f - *b, dabs(r__1));
if (dmax(r__2,1.f) * dmax(r__3,1.f) < dabs(*x) * .99f) {
goto L120;
}
/* THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL */
/* APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE. */
if ((r__1 = *a + 1.f - *b, dabs(r__1)) < sqrt(eps)) {
xermsg_("SLATEC", "CHU", "ALGORITHM IS BAD WHEN 1+A-B IS NEAR ZERO F"
"OR SMALL X", &c__10, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
}
r__1 = *b + .5f;
aintb = r_int(&r__1);
if (*b < 0.f) {
r__1 = *b - .5f;
aintb = r_int(&r__1);
}
beps = *b - aintb;
n = aintb;
alnx = log(*x);
xtoeps = exp(-beps * alnx);
/* EVALUATE THE FINITE SUM. ----------------------------------------- */
if (n >= 1) {
goto L40;
}
/* CONSIDER THE CASE B .LT. 1.0 FIRST. */
sum = 1.f;
if (n == 0) {
goto L30;
}
t = 1.f;
m = -n;
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi1 = (real) (i__ - 1);
t = t * (*a + xi1) * *x / ((*b + xi1) * (xi1 + 1.f));
sum += t;
/* L20: */
}
L30:
r__1 = *a + 1.f - *b;
r__2 = -(*a);
sum = poch_(&r__1, &r__2) * sum;
goto L70;
/* NOW CONSIDER THE CASE B .GE. 1.0. */
L40:
sum = 0.f;
m = n - 2;
if (m < 0) {
goto L70;
}
t = 1.f;
sum = 1.f;
if (m == 0) {
goto L60;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi = (real) i__;
t = t * (*a - *b + xi) * *x / ((1.f - *b + xi) * xi);
sum += t;
/* L50: */
}
L60:
r__1 = *b - 1.f;
i__1 = 1 - n;
sum = gamma_(&r__1) * gamr_(a) * pow_ri(x, &i__1) * xtoeps * sum;
/* NOW EVALUATE THE INFINITE SUM. ----------------------------------- */
L70:
istrt = 0;
if (n < 1) {
istrt = 1 - n;
}
xi = (real) istrt;
r__1 = *a + 1.f - *b;
factor = pow_ri(&c_b25, &n) * gamr_(&r__1) * pow_ri(x, &istrt);
if (beps != 0.f) {
factor = factor * beps * pi / sin(beps * pi);
}
pochai = poch_(a, &xi);
r__1 = xi + 1.f;
gamri1 = gamr_(&r__1);
r__1 = aintb + xi;
gamrni = gamr_(&r__1);
r__1 = xi - beps;
r__2 = xi + 1.f - beps;
b0 = factor * poch_(a, &r__1) * gamrni * gamr_(&r__2);
if ((r__1 = xtoeps - 1.f, dabs(r__1)) > .5f) {
goto L90;
}
/* X**(-BEPS) IS CLOSE TO 1.0, SO WE MUST BE CAREFUL IN EVALUATING */
/* THE DIFFERENCES */
r__1 = *a + xi;
r__2 = -beps;
pch1ai = poch1_(&r__1, &r__2);
r__1 = xi + 1.f - beps;
pch1i = poch1_(&r__1, &beps);
r__1 = *b + xi;
r__2 = -beps;
c0 = factor * pochai * gamrni * gamri1 * (-poch1_(&r__1, &r__2) + pch1ai
- pch1i + beps * pch1ai * pch1i);
/* XEPS1 = (1.0 - X**(-BEPS)) / BEPS */
r__1 = -beps * alnx;
xeps1 = alnx * exprel_(&r__1);
ret_val = sum + c0 + xeps1 * b0;
xn = (real) n;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (real) (istrt + i__);
xi1 = (real) (istrt + i__ - 1);
b0 = (*a + xi1 - beps) * b0 * *x / ((xn + xi1) * (xi - beps));
c0 = (*a + xi1) * c0 * *x / ((*b + xi1) * xi) - ((*a - 1.f) * (xn +
xi * 2.f - 1.f) + xi * (xi - beps)) * b0 / (xi * (*b + xi1) *
(*a + xi1 - beps));
t = c0 + xeps1 * b0;
ret_val += t;
if (dabs(t) < eps * dabs(ret_val)) {
goto L130;
}
/* L80: */
}
xermsg_("SLATEC", "CHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING "
"SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
/* X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD */
/* FORMULATION IS STABLE. */
L90:
r__1 = *b + xi;
a0 = factor * pochai * gamr_(&r__1) * gamri1 / beps;
b0 = xtoeps * b0 / beps;
ret_val = sum + a0 - b0;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (real) (istrt + i__);
xi1 = (real) (istrt + i__ - 1);
a0 = (*a + xi1) * a0 * *x / ((*b + xi1) * xi);
b0 = (*a + xi1 - beps) * b0 * *x / ((aintb + xi1) * (xi - beps));
t = a0 - b0;
ret_val += t;
if (dabs(t) < eps * dabs(ret_val)) {
goto L130;
}
/* L100: */
}
xermsg_("SLATEC", "CHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING "
"SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
/* USE LUKE-S RATIONAL APPROX IN THE ASYMPTOTIC REGION. */
L120:
d__1 = (doublereal) (*x);
d__2 = (doublereal) (-(*a));
ret_val = pow_dd(&d__1, &d__2) * r9chu_(a, b, x);
L130:
return ret_val;
} /* chu_ */
int csyequb_(char *uplo, int *n, complex *a, int *
lda, float *s, float *scond, float *amax, complex *work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
float r__1, r__2, r__3, r__4;
double d__1;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *), sqrt(double), log(double), pow_ri(float *
, int *);
/* Local variables */
float d__;
int i__, j;
float t, u, c0, c1, c2, si;
int up;
float avg, std, tol, base;
int iter;
float smin, smax, scale;
extern int lsame_(char *, char *);
float sumsq;
extern double slamch_(char *);
extern int xerbla_(char *, int *);
float bignum;
extern int classq_(int *, complex *, int *, float
*, float *);
float smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSYEQUB computes row and column scalings intended to equilibrate a */
/* symmetric matrix A and reduce its condition number */
/* (with respect to the two-norm). S contains the scale factors, */
/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
/* choice of S puts the condition number of B within a factor N of the */
/* smallest possible condition number over all possible diagonal */
/* scalings. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The N-by-N symmetric matrix whose scaling */
/* factors are to be computed. Only the diagonal elements of A */
/* are referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* S (output) REAL array, dimension (N) */
/* If INFO = 0, S contains the scale factors for A. */
/* SCOND (output) REAL */
/* If INFO = 0, S contains the ratio of the smallest S(i) to */
/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
/* large nor too small, it is not worth scaling by S. */
/* AMAX (output) REAL */
/* Absolute value of largest matrix element. If AMAX is very */
/* close to overflow or very close to underflow, the matrix */
/* should be scaled. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
/* Further Details */
/* ======= ======= */
/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */
/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */
/* DOI 10.1023/B:NUMA.0000016606.32820.69 */
/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* Statement Function Definitions */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
--work;
/* Function Body */
*info = 0;
if (! (lsame_(uplo, "U") || 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_("CSYEQUB", &i__1);
return 0;
}
up = lsame_(uplo, "U");
*amax = 0.f;
/* Quick return if possible. */
if (*n == 0) {
*scond = 1.f;
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
s[i__] = 0.f;
}
*amax = 0.f;
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = s[i__], r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
s[i__] = MAX(r__3,r__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = s[j], r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
s[j] = MAX(r__3,r__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = *amax, r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
*amax = MAX(r__3,r__4);
}
/* Computing MAX */
i__2 = j + j * a_dim1;
r__3 = s[j], r__4 = (r__1 = a[i__2].r, ABS(r__1)) + (r__2 =
r_imag(&a[j + j * a_dim1]), ABS(r__2));
s[j] = MAX(r__3,r__4);
/* Computing MAX */
i__2 = j + j * a_dim1;
r__3 = *amax, r__4 = (r__1 = a[i__2].r, ABS(r__1)) + (r__2 =
r_imag(&a[j + j * a_dim1]), ABS(r__2));
*amax = MAX(r__3,r__4);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j + j * a_dim1;
r__3 = s[j], r__4 = (r__1 = a[i__2].r, ABS(r__1)) + (r__2 =
r_imag(&a[j + j * a_dim1]), ABS(r__2));
s[j] = MAX(r__3,r__4);
/* Computing MAX */
i__2 = j + j * a_dim1;
r__3 = *amax, r__4 = (r__1 = a[i__2].r, ABS(r__1)) + (r__2 =
r_imag(&a[j + j * a_dim1]), ABS(r__2));
*amax = MAX(r__3,r__4);
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = s[i__], r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
s[i__] = MAX(r__3,r__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = s[j], r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
s[j] = MAX(r__3,r__4);
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = *amax, r__4 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), ABS(r__2));
*amax = MAX(r__3,r__4);
}
}
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = 1.f / s[j];
}
tol = 1.f / sqrt(*n * 2.f);
for (iter = 1; iter <= 100; ++iter) {
scale = 0.f;
sumsq = 0.f;
/* beta = |A|s */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
work[i__2].r = 0.f, work[i__2].i = 0.f;
}
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[
i__ + j * a_dim1]), ABS(r__2));
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
r__3 = ((r__1 = a[i__5].r, ABS(r__1)) + (r__2 = r_imag(&
a[i__ + j * a_dim1]), ABS(r__2))) * s[j];
q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
i__3 = j;
i__4 = j;
i__5 = i__ + j * a_dim1;
r__3 = ((r__1 = a[i__5].r, ABS(r__1)) + (r__2 = r_imag(&
a[i__ + j * a_dim1]), ABS(r__2))) * s[i__];
q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
r__3 = ((r__1 = a[i__4].r, ABS(r__1)) + (r__2 = r_imag(&a[j
+ j * a_dim1]), ABS(r__2))) * s[j];
q__1.r = work[i__3].r + r__3, q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
i__3 = j;
i__4 = j + j * a_dim1;
r__3 = ((r__1 = a[i__4].r, ABS(r__1)) + (r__2 = r_imag(&a[j
+ j * a_dim1]), ABS(r__2))) * s[j];
q__1.r = work[i__3].r + r__3, q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[
i__ + j * a_dim1]), ABS(r__2));
i__3 = i__;
i__4 = i__;
i__5 = i__ + j * a_dim1;
r__3 = ((r__1 = a[i__5].r, ABS(r__1)) + (r__2 = r_imag(&
a[i__ + j * a_dim1]), ABS(r__2))) * s[j];
q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
i__3 = j;
i__4 = j;
i__5 = i__ + j * a_dim1;
r__3 = ((r__1 = a[i__5].r, ABS(r__1)) + (r__2 = r_imag(&
a[i__ + j * a_dim1]), ABS(r__2))) * s[i__];
q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
}
}
/* avg = s^T beta / n */
avg = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__;
q__2.r = s[i__2] * work[i__3].r, q__2.i = s[i__2] * work[i__3].i;
q__1.r = avg + q__2.r, q__1.i = q__2.i;
avg = q__1.r;
}
avg /= *n;
std = 0.f;
i__1 = *n << 1;
for (i__ = *n + 1; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ - *n;
i__4 = i__ - *n;
q__2.r = s[i__3] * work[i__4].r, q__2.i = s[i__3] * work[i__4].i;
q__1.r = q__2.r - avg, q__1.i = q__2.i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
}
classq_(n, &work[*n + 1], &c__1, &scale, &sumsq);
std = scale * sqrt(sumsq / *n);
if (std < tol * avg) {
goto L999;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
t = (r__1 = a[i__2].r, ABS(r__1)) + (r__2 = r_imag(&a[i__ + i__ *
a_dim1]), ABS(r__2));
si = s[i__];
c2 = (*n - 1) * t;
i__2 = *n - 2;
i__3 = i__;
r__1 = t * si;
q__2.r = work[i__3].r - r__1, q__2.i = work[i__3].i;
d__1 = (double) i__2;
q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i;
c1 = q__1.r;
r__1 = -(t * si) * si;
i__2 = i__;
d__1 = 2.;
q__4.r = d__1 * work[i__2].r, q__4.i = d__1 * work[i__2].i;
q__3.r = si * q__4.r, q__3.i = si * q__4.i;
q__2.r = r__1 + q__3.r, q__2.i = q__3.i;
r__2 = *n * avg;
q__1.r = q__2.r - r__2, q__1.i = q__2.i;
c0 = q__1.r;
d__ = c1 * c1 - c0 * 4 * c2;
if (d__ <= 0.f) {
*info = -1;
return 0;
}
si = c0 * -2 / (c1 + sqrt(d__));
d__ = si - s[i__];
u = 0.f;
if (up) {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[j
+ i__ * a_dim1]), ABS(r__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
r__1 = d__ * t;
q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[
i__ + j * a_dim1]), ABS(r__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
r__1 = d__ * t;
q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
} else {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[
i__ + j * a_dim1]), ABS(r__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
r__1 = d__ * t;
q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
t = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[j
+ i__ * a_dim1]), ABS(r__2));
u += s[j] * t;
i__3 = j;
i__4 = j;
r__1 = d__ * t;
q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
}
}
i__2 = i__;
q__4.r = u + work[i__2].r, q__4.i = work[i__2].i;
q__3.r = d__ * q__4.r, q__3.i = d__ * q__4.i;
d__1 = (double) (*n);
q__2.r = q__3.r / d__1, q__2.i = q__3.i / d__1;
q__1.r = avg + q__2.r, q__1.i = q__2.i;
avg = q__1.r;
s[i__] = si;
}
}
L999:
smlnum = slamch_("SAFEMIN");
bignum = 1.f / smlnum;
smin = bignum;
smax = 0.f;
t = 1.f / sqrt(avg);
base = slamch_("B");
u = 1.f / log(base);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = (int) (u * log(s[i__] * t));
s[i__] = pow_ri(&base, &i__2);
/* Computing MIN */
r__1 = smin, r__2 = s[i__];
smin = MIN(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[i__];
smax = MAX(r__1,r__2);
}
*scond = MAX(smin,smlnum) / MIN(smax,bignum);
return 0;
} /* csyequb_ */
integer rdcalgmskb3_(integer *calb, integer *idir, integer *iband, integer *
itab)
{
/* Initialized data */
static real wnfctr[3] = { .7903f,.7874f,.8676f };
/* System generated locals */
address a__1[2];
integer ret_val, i__1, i__2, i__3[2];
real r__1;
char ch__1[55], ch__2[73], ch__3[42];
/* Builtin functions */
double r_sign(real *, real *), pow_ri(real *, integer *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double r_mod(real *, real *);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static real c__, g;
static integer i__, j, k;
static real r__, v, c0, v0;
static integer v1, v2, ig[3], iv, ic0[3], iv0[3], ida, dir[512], ihr, imn,
imo, iok, jok;
extern integer lit_(char *, ftnlen), lwix_(char *, integer *, integer *,
integer *, ftnlen);
static integer iss;
static real riv;
static integer iyr, ixv, ifac;
static real beta[21] /* was [7][3] */;
static integer ltab, ioff;
extern real gmtradgmskb3_(real *, integer *);
static integer kend;
extern /* Subroutine */ int gmpfcogmskb3_(char *, integer *, ftnlen);
static integer nlen;
extern /* Subroutine */ int movb_();
static real rrem;
static integer kbyt;
extern integer ksys_(integer *);
static integer idcal;
static char calbl[1*7168];
static integer iarea;
static char cfile[12], cname[4];
static integer ibeta[21] /* was [7][3] */, idate[2], ifact[3], idsen;
extern /* Subroutine */ int edestX_(char *, integer *, ftnlen);
static integer ntabs, istat;
extern /* Subroutine */ int sysin_(integer *, integer *);
static integer icalbl[1792];
extern /* Subroutine */ int swbyt4_(integer *, integer *), araget_(
integer *, integer *, integer *, integer *);
static integer ispare[3], lbstart, nbstart;
/* All variables must be declared */
/* from each line header for IBUF dat */
/* Input array of calibration constants */
/* for GMS, since the area calibratio */
/* block must be accessed locally) */
/* Area directory buffer (this is mandat */
/* Band number of data in area */
/* absolute radiation temperature */
/* Lookup table containing albedo or */
/* (defines NUMAREAOPTIONS) */
/* Global declarations for McIDAS areas */
/* Copyright(c) 1997, Space Science and Engineering Center, UW-Madison */
/* Refer to "McIDAS Software Acquisition and Distribution Policies" */
/* in the file mcidas/data/license.txt */
/* *** $Id: areaparm.inc,v 1.1 2000/07/12 13:12:23 gad Exp $ *** */
/* area subsystem parameters */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* IF YOU CHANGE THESE VALUES, YOU MUST ALSO CHANGE THEM IN */
/* MCIDAS.H !! */
/* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
/* MAXGRIDPT maximum number of grid points */
/* MAX_BANDS maximum number of bands within an area */
/* MAXDFELEMENTS maximum number of elements that DF can handle */
/* in an area line */
/* MAXOPENAREAS maximum number of areas that the library can */
/* have open (formerly called `NA') */
/* NUMAREAOPTIONS number of options settable through ARAOPT() */
/* It is presently 5 because there are five options */
/* that ARAOPT() knows about: */
/* 'PREC','SPAC','UNIT','SCAL','CALB' */
/* (formerly called `NB') */
/* --- Size (number of words) in an area directory */
/* MAX_AUXBLOCK_SIZE size (in bytes) of the internal buffers */
/* used to recieve AUX blocks during an */
/* ADDE transaction */
/* ----- MAX_AREA_NUMBER Maximum area number allowed on system */
/* ----- MAXAREARQSTLEN - max length of area request string */
/* Flag identifying conversion code */
/* Source pixel size in bytes */
/* Destination pixel size in bytes */
/* Flag specifying how to construct ITAB */
/* Calibration parameters for conve */
/* Radiance table for GMS-5 */
/* We use only IVAL to pass back */
/* the calibration option used */
/* and rename ITAB because its */
/* address is passed as an arg */
/* platform or compiler depend */
/* too, and might be susceptab */
/* ID number of calibration table */
/* byte offset into GMSCAL file(s) */
/* Logical .AND. function */
/* Acquire SYSVAL value */
/* LW file read */
/* Converts CHAR*4 to INTEGER */
/* Real MOD function */
/* Converts GMS-5 TEMP to RAD */
/* index variable */
/* index variable */
/* index variable */
/* Length of arbitrary block in byt */
/* End word count of a block */
/* Input block starting byte count */
/* Output block starting byte count */
/* Input index value */
/* Interpolated data output index v */
/* First table value */
/* Second table value */
/* area number from IDIR array */
/* spacecraft/sensor ID from IDIR a */
/* LWI status returned */
/* Year */
/* Month */
/* Day of month */
/* Hour of day (GMT) */
/* Minute of hour */
/* (from first word in file) */
/* number of tables in the GMSCAL f */
/* Default GMSCAL table directory */
/* GMS-5 McIDAS Calibration block */
/* Calibration ID from data block */
/* (YY,YY,MM,DD,HH,mm) */
/* Six-byte date data block was gen */
/* (1=primary, 2=redundant) */
/* Sensor selector byte */
/* (significant if non-zero) */
/* bad radiance value counter */
/* (significant if non-zero) */
/* error flag for GMP_FCO function */
/* Byte address of CNAME block */
/* IR bands for converting DN to */
/* sensor output voltage (scaled */
/* Calibration constants for the th */
/* the series expansion for each */
/* Number of calibration constants */
/* G constant for each IR band */
/* V0 constant for each IR band */
/* C0 constant for each IR band */
/* Unused spare location in table */
/* the series expansion to be use */
/* Number of calibration constants */
/* Real input index value IV */
/* Remainder mod 1.0 */
/* IR bands for converting DN to */
/* sensor output voltage */
/* Calibration constants for the th */
/* (volts/watt/cm**2/sr) */
/* G constant to be used */
/* (zero level voltage) */
/* V0 constant to be used */
/* C0 constant to be used */
/* series expansion */
/* Intermediate "DN" value used in */
/* Output voltage from series expan */
/* (watts/cm**2/sr) */
/* Radiance from voltage and G cons */
/* W/cm**2/sr to W/etc/cm**-1 */
/* for the GMS-5 IR bands */
/* Wave number factor to convert fr */
/* calibration tables */
/* Input file containing default */
/* GMS-5 McIDAS Calibration block */
/* Table Name in calibration data b */
/* Parameter adjustments */
--itab;
--idir;
--calb;
/* Function Body */
iss = idir[3];
iarea = idir[33];
ltab = 0;
if (idir[3] == 12) {
ltab = 1;
} else if (idir[3] == 13) {
ltab = 3;
} else if (idir[3] == 82 && *iband == 1) {
ltab = 1;
} else if (idir[3] == 82 && *iband == 2) {
ltab = 3;
} else if (idir[3] == 82 && *iband == 8) {
ltab = 3;
} else if (idir[3] == 83 && *iband == 1) {
ltab = 4;
} else if (idir[3] == 83 && *iband == 2) {
ltab = 5;
} else if (idir[3] == 83 && *iband == 3) {
ltab = 6;
} else if (idir[3] == 83 && *iband == 4) {
ltab = 7;
} else if (idir[3] == 83 && *iband == 8) {
ltab = 5;
} else {
edestX_("RD_CAL: Unrecognized data band or SS", &c__0, (ftnlen)36);
ret_val = -1;
goto L500;
}
if (gmsxxgmskb3_1.kopt <= 0 || gmsxxgmskb3_1.kopt > 15) {
gmsxxgmskb3_1.kopt = ksys_(&c__151);
}
if (gmsxxgmskb3_1.kopt <= 0 || gmsxxgmskb3_1.kopt > 15) {
gmsxxgmskb3_1.kopt = 7;
if (idir[3] <= 82) {
gmsxxgmskb3_1.kopt = 3;
}
}
if (idir[3] <= 82 && gmsxxgmskb3_1.kopt > 3) {
edestX_("Invalid calibration option for SS=", &idir[3], (ftnlen)34);
edestX_(" ...was ", &gmsxxgmskb3_1.kopt, (ftnlen)12);
gmsxxgmskb3_1.kopt = 3;
edestX_(" ...reset to ", &gmsxxgmskb3_1.kopt, (ftnlen)17);
edestX_("Options > 3 valid for GMS-5 and later only!", &c__0, (ftnlen)
43);
}
debuggmskb3_2.ival = 0;
idsen = 0;
if ((gmsxxgmskb3_1.kopt & 12) != 0) {
araget_(&iarea, &idir[63], &c__7168, icalbl);
if (icalbl[0] != lit_("GMS5", (ftnlen)4) || icalbl[1] > 90) {
edestX_("Calibration block is not GMS-5 format.", &c__0, (ftnlen)
38);
edestX_("It cannot be used by the GMS calibration module.", &c__0,
(ftnlen)48);
edestX_("Will attempt to use GMSCAL file tables instead.", &c__0, (
ftnlen)47);
goto L200;
}
nlen = icalbl[1];
if (icalbl[2] == lit_("COEF", (ftnlen)4)) {
movb_(&c__256, icalbl, calbl, &c__0, (ftnlen)1);
for (i__ = 1; i__ <= 60; i__ += 3) {
i__1 = i__ + 2;
for (j = i__; j <= i__1; ++j) {
for (k = -3; k <= 0; ++k) {
if (*(unsigned char *)&calbl[(j << 2) + k - 1] < 32 ||
*(unsigned char *)&calbl[(j << 2) + k - 1] >
126) {
*(unsigned char *)&calbl[(j << 2) + k - 1] = '*';
}
}
}
}
movb_(&c__256, &icalbl[icalbl[3] / 4], calbl, &c__0, (ftnlen)1);
movb_(&c__4, calbl, &idcal, &c__0);
movb_(&c__6, calbl + 4, idate, &c__0, (ftnlen)1);
iyr = idate[0] / 65536;
imo = (idate[0] - (iyr << 16)) / 256;
ida = idate[0] - (iyr << 16) - (imo << 8);
ihr = idate[1] / 65536 / 256;
imn = idate[1] / 65536 - (ihr << 8);
movb_(&c__1, calbl + 10, &idsen, &c__0, (ftnlen)1);
idsen /= 16777216;
/* shift right 3 bytes */
ifact[0] = *(unsigned char *)&calbl[11];
movb_(&c__4, calbl + 12, ibeta, &c__0, (ftnlen)1);
movb_(&c__4, calbl + 16, &ibeta[1], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 20, &ibeta[2], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 24, &ibeta[3], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 28, &ibeta[4], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 32, &ibeta[5], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 36, &ibeta[6], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 40, ig, &c__0, (ftnlen)1);
movb_(&c__4, calbl + 44, iv0, &c__0, (ftnlen)1);
movb_(&c__4, calbl + 48, ic0, &c__0, (ftnlen)1);
movb_(&c__4, calbl + 52, ispare, &c__0, (ftnlen)1);
ifact[1] = *(unsigned char *)&calbl[56];
movb_(&c__4, calbl + 57, &ibeta[7], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 61, &ibeta[8], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 65, &ibeta[9], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 69, &ibeta[10], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 73, &ibeta[11], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 77, &ibeta[12], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 81, &ibeta[13], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 85, &ig[1], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 89, &iv0[1], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 93, &ic0[1], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 97, &ispare[1], &c__0, (ftnlen)1);
ifact[2] = *(unsigned char *)&calbl[101];
movb_(&c__4, calbl + 102, &ibeta[14], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 106, &ibeta[15], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 110, &ibeta[16], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 114, &ibeta[17], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 118, &ibeta[18], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 122, &ibeta[19], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 126, &ibeta[20], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 130, &ig[2], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 134, &iv0[2], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 138, &ic0[2], &c__0, (ftnlen)1);
movb_(&c__4, calbl + 142, &ispare[2], &c__0, (ftnlen)1);
if (*iband > 1 && *iband <= 4) {
g = (ig[*iband - 2] & 2147483647) * 1e-6f;
v0 = (iv0[*iband - 2] & 2147483647) * 1e-6f;
c0 = (ic0[*iband - 2] & 2147483647) * 1e-6f;
r__1 = (real) ig[*iband - 2];
g = r_sign(&g, &r__1);
r__1 = (real) iv0[*iband - 2];
v0 = r_sign(&v0, &r__1);
r__1 = (real) ic0[*iband - 2];
c0 = r_sign(&c0, &r__1);
ifac = ifact[*iband - 2] + 1;
if (ifac < 1 || ifac > 7) {
ifac = 7;
}
for (i__ = 1; i__ <= 3; ++i__) {
i__1 = ifac;
for (j = 1; j <= i__1; ++j) {
beta[j + i__ * 7 - 8] = (ibeta[j + i__ * 7 - 8] &
2147483647) * 1e-6f;
r__1 = (real) ibeta[j + i__ * 7 - 8];
beta[j + i__ * 7 - 8] = r_sign(&beta[j + i__ * 7 - 8],
&r__1);
}
}
for (j = 1; j <= 255; ++j) {
/* index on S-VISSR DN l */
c__ = 255.f - j + c0;
/* convert to instrument */
v = 0.f;
i__1 = ifac;
for (k = 1; k <= i__1; ++k) {
/* do the series expansi */
i__2 = k - 1;
v += beta[k + (*iband - 1) * 7 - 8] * pow_ri(&c__, &
i__2);
}
r__ = (v - v0) / g;
/* convert to radiance W */
r__ = r__ * .5f / wnfctr[*iband - 2];
/* convert to mW/etc./cm */
radgmskb3_1.ktab[j - 1] = (integer) (r__ * 1e3f);
/* the KTAB table as */
/* scale by 1000 and put */
}
iok = 0;
for (j = 2; j <= 255; ++j) {
if (radgmskb3_1.ktab[j - 1] < 0 || radgmskb3_1.ktab[j - 1]
> 190000) {
++iok;
}
}
}
} else {
goto L100;
}
if (ltab <= 3) {
goto L100;
}
if (ltab == 4) {
s_copy(cname, "5VIS", (ftnlen)4, (ftnlen)4);
}
if (ltab == 5) {
s_copy(cname, "5IR1", (ftnlen)4, (ftnlen)4);
}
if (ltab == 6) {
s_copy(cname, "5IR2", (ftnlen)4, (ftnlen)4);
}
if (ltab == 7) {
s_copy(cname, "5IR3", (ftnlen)4, (ftnlen)4);
}
if (ltab >= 8) {
goto L100;
}
kbyt = 0;
kend = nlen / 4;
if (kend > 22) {
edestX_("RD_CAL: Bad directory structure. KEND=", &kend, (ftnlen)
39);
kend = 22;
}
i__1 = kend;
for (j = 5; j <= i__1; ++j) {
if (icalbl[j - 1] == lit_(cname, (ftnlen)4)) {
kbyt = icalbl[j];
}
}
if (kbyt != 0) {
movb_(&c__1024, &icalbl[kbyt / 4], &itab[1], &c__0);
itab[1] = itab[2];
itab[256] = itab[255];
} else {
edestX_("KBYT cannot be set -- no table exists", &c__0, (ftnlen)37)
;
goto L100;
}
if (*iband != 1) {
goto L80;
}
for (i__ = 4; i__ >= 1; --i__) {
lbstart = (i__ - 1 << 6) + 1;
nbstart = i__ - 1 << 8;
for (ixv = 256; ixv >= 1; --ixv) {
riv = (real) (ixv - 1) / 252.f * 63.f;
iv = riv;
v1 = itab[lbstart + iv];
v2 = itab[lbstart + iv + 1];
if (iv == 63) {
v2 = 1000000;
}
rrem = r_mod(&riv, &c_b208);
itab[nbstart + ixv] = v1 + (v2 - v1) * rrem + .5f;
}
}
L80:
debuggmskb3_2.ival = 8;
if (iok > 5 && (gmsxxgmskb3_1.kopt & 15) == 8) {
edestX_("Too many of the real-time power series radiances are", &
c__0, (ftnlen)52);
edestX_("outside expected limits and are likely to be in error.", &
c__0, (ftnlen)54);
goto L100;
}
if ((gmsxxgmskb3_1.kopt & 4) == 0) {
goto L400;
}
}
L100:
if ((gmsxxgmskb3_1.kopt & 4) != 0) {
if (iss == 83) {
if (idsen != 2) {
gmpfcogmskb3_("A", &jok, (ftnlen)1);
}
if (idsen == 2) {
gmpfcogmskb3_("B", &jok, (ftnlen)1);
}
if (jok == 0) {
goto L300;
}
for (j = 1; j <= 256; ++j) {
r__1 = itab[j] * .001f;
radgmskb3_1.ktab[j - 1] = gmtradgmskb3_(&r__1, iband) * 1e3f;
}
} else {
goto L200;
}
debuggmskb3_2.ival = 4;
goto L400;
}
L200:
if ((gmsxxgmskb3_1.kopt & 2) != 0) {
s_copy(cfile, "GMSCALU", (ftnlen)12, (ftnlen)7);
istat = lwix_(cfile, &c__0, &c__512, dir, (ftnlen)12);
swbyt4_(dir, &c__512);
if (istat != 0 && (gmsxxgmskb3_1.kopt & 1) == 0) {
/* Writing concatenation */
i__3[0] = 43, a__1[0] = "ERROR reading calibration tables from f"
"ile ";
i__3[1] = 12, a__1[1] = cfile;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)55);
edestX_(ch__1, &c__0, (ftnlen)55);
goto L300;
}
ntabs = dir[0];
ioff = (ltab - 1 << 8) + 512;
if (ltab > ntabs) {
goto L300;
}
istat = lwix_(cfile, &ioff, &c__256, &itab[1], (ftnlen)12);
swbyt4_(&itab[1], &c__256);
for (j = 1; j <= 256; ++j) {
itab[j + 256] = itab[j];
itab[j + 512] = itab[j];
itab[j + 768] = itab[j];
}
if (istat != 0) {
goto L300;
}
if (iss == 83) {
if (idsen != 2) {
gmpfcogmskb3_("A", &jok, (ftnlen)1);
}
if (idsen == 2) {
gmpfcogmskb3_("B", &jok, (ftnlen)1);
}
if (jok == 0) {
goto L300;
}
for (j = 1; j <= 256; ++j) {
r__1 = itab[j] * .001f;
radgmskb3_1.ktab[j - 1] = gmtradgmskb3_(&r__1, iband) * 1e3f;
}
}
debuggmskb3_2.ival = 2;
goto L400;
}
L300:
if ((gmsxxgmskb3_1.kopt & 1) != 0) {
s_copy(cfile, "GMSCAL", (ftnlen)12, (ftnlen)6);
istat = lwix_(cfile, &c__0, &c__512, dir, (ftnlen)12);
swbyt4_(dir, &c__512);
if (istat != 0) {
/* Writing concatenation */
i__3[0] = 43, a__1[0] = "ERROR reading calibration tables from f"
"ile ";
i__3[1] = 12, a__1[1] = cfile;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)55);
edestX_(ch__1, &c__0, (ftnlen)55);
ret_val = -1;
goto L500;
}
ntabs = dir[0];
ioff = (ltab - 1 << 8) + 512;
if (ltab > ntabs) {
edestX_("RD_CAL ERROR -- Unrecognized Table ID=", <ab, (ftnlen)
38);
/* Writing concatenation */
i__3[0] = 61, a__1[0] = "The table index is greater than number "
"of tables in the file ";
i__3[1] = 12, a__1[1] = cfile;
s_cat(ch__2, a__1, i__3, &c__2, (ftnlen)73);
edestX_(ch__2, &c__0, (ftnlen)73);
edestX_("Check SS and band number for consistency with the table "
"ID", &c__0, (ftnlen)58);
edestX_(" SS=", &idir[3], (
ftnlen)38);
edestX_(" Band=", iband, (ftnlen)
38);
ret_val = -1;
goto L500;
}
istat = lwix_(cfile, &ioff, &c__256, &itab[1], (ftnlen)12);
swbyt4_(&itab[1], &c__256);
for (j = 1; j <= 256; ++j) {
itab[j + 256] = itab[j];
itab[j + 512] = itab[j];
itab[j + 768] = itab[j];
}
if (istat != 0) {
/* Writing concatenation */
i__3[0] = 30, a__1[0] = "File status error reading file";
i__3[1] = 12, a__1[1] = cfile;
s_cat(ch__3, a__1, i__3, &c__2, (ftnlen)42);
edestX_(ch__3, &istat, (ftnlen)42);
ret_val = -1;
goto L500;
}
if (iss == 83) {
if (idsen != 2) {
gmpfcogmskb3_("A", &jok, (ftnlen)1);
}
if (idsen == 2) {
gmpfcogmskb3_("B", &jok, (ftnlen)1);
}
if (jok == 0) {
ret_val = -1;
goto L500;
}
for (j = 1; j <= 256; ++j) {
r__1 = itab[j] * .001f;
radgmskb3_1.ktab[j - 1] = gmtradgmskb3_(&r__1, iband) * 1e3f;
}
}
debuggmskb3_2.ival = 1;
goto L400;
}
ret_val = -1;
goto L500;
L400:
if (debuggmskb3_2.ival == 0) {
ret_val = -1;
} else {
ret_val = 0;
}
L500:
sysin_(&c__152, &debuggmskb3_2.ival);
for (i__ = 1; i__ <= 1024; ++i__) {
debuggmskb3_2.itabr[i__ - 1] = itab[i__];
}
return ret_val;
} /* rdcalgmskb3_ */
/* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real *
eps, integer *emin, real *rmin, integer *emax, real *rmax)
{
/* Initialized data */
static logical first = TRUE_;
static logical iwarn = FALSE_;
/* Format strings */
static char fmt_9999[] = "(//\002 WARNING. The value EMIN may be incorre"
"ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the va"
"lue EMIN looks\002,\002 acceptable please comment out \002,/\002"
" the IF block as marked within the code of routine\002,\002 SLAM"
"C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)";
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double pow_ri(real *, integer *);
//integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
real a, b, c__;
integer i__;
static integer lt;
real one, two;
logical ieee;
real half;
logical lrnd;
static real leps;
real zero;
static integer lbeta;
real rbase;
static integer lemin, lemax;
integer gnmin;
real small;
integer gpmin;
real third;
static real lrmin, lrmax;
real sixth;
logical lieee1;
extern /* Subroutine */ int slamc1_(integer *, integer *, logical *,
logical *);
extern doublereal slamc3_(real *, real *);
extern /* Subroutine */ int slamc4_(integer *, real *, integer *),
slamc5_(integer *, integer *, integer *, logical *, integer *,
real *);
integer ngnmin, ngpmin;
/* Fortran I/O blocks */
static cilist io___58 = { 0, 6, 0, fmt_9999, 0 };
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAMC2 determines the machine parameters specified in its argument */
/* list. */
/* Arguments */
/* ========= */
/* BETA (output) INTEGER */
/* The base of the machine. */
/* T (output) INTEGER */
/* The number of ( BETA ) digits in the mantissa. */
/* RND (output) LOGICAL */
/* Specifies whether proper rounding ( RND = .TRUE. ) or */
/* chopping ( RND = .FALSE. ) occurs in addition. This may not */
/* be a reliable guide to the way in which the machine performs */
/* its arithmetic. */
/* EPS (output) REAL */
/* The smallest positive number such that */
/* fl( 1.0 - EPS ) .LT. 1.0, */
/* where fl denotes the computed value. */
/* EMIN (output) INTEGER */
/* The minimum exponent before (gradual) underflow occurs. */
/* RMIN (output) REAL */
/* The smallest normalized number for the machine, given by */
/* BASE**( EMIN - 1 ), where BASE is the floating point value */
/* of BETA. */
/* EMAX (output) INTEGER */
/* The maximum exponent before overflow occurs. */
/* RMAX (output) REAL */
/* The largest positive number for the machine, given by */
/* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */
/* value of BETA. */
/* Further Details */
/* =============== */
/* The computation of EPS is based on a routine PARANOIA by */
/* W. Kahan of the University of California at Berkeley. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Save statement .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
if (first) {
zero = 0.f;
one = 1.f;
two = 2.f;
/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */
/* BETA, T, RND, EPS, EMIN and RMIN. */
/* Throughout this routine we use the function SLAMC3 to ensure */
/* that relevant values are stored and not held in registers, or */
/* are not affected by optimizers. */
/* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */
slamc1_(&lbeta, <, &lrnd, &lieee1);
/* Start to find EPS. */
b = (real) lbeta;
i__1 = -lt;
a = pow_ri(&b, &i__1);
leps = a;
/* Try some tricks to see whether or not this is the correct EPS. */
b = two / 3;
half = one / 2;
r__1 = -half;
sixth = slamc3_(&b, &r__1);
third = slamc3_(&sixth, &sixth);
r__1 = -half;
b = slamc3_(&third, &r__1);
b = slamc3_(&b, &sixth);
b = dabs(b);
if (b < leps) {
b = leps;
}
leps = 1.f;
/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
L10:
if (leps > b && b > zero) {
leps = b;
r__1 = half * leps;
/* Computing 5th power */
r__3 = two, r__4 = r__3, r__3 *= r__3;
/* Computing 2nd power */
r__5 = leps;
r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
c__ = slamc3_(&r__1, &r__2);
r__1 = -c__;
c__ = slamc3_(&half, &r__1);
b = slamc3_(&half, &c__);
r__1 = -b;
c__ = slamc3_(&half, &r__1);
b = slamc3_(&half, &c__);
goto L10;
}
/* + END WHILE */
if (a < leps) {
leps = a;
}
/* Computation of EPS complete. */
/* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */
/* Keep dividing A by BETA until (gradual) underflow occurs. This */
/* is detected when we cannot recover the previous A. */
rbase = one / lbeta;
small = one;
for (i__ = 1; i__ <= 3; ++i__) {
r__1 = small * rbase;
small = slamc3_(&r__1, &zero);
/* L20: */
}
a = slamc3_(&one, &small);
slamc4_(&ngpmin, &one, &lbeta);
r__1 = -one;
slamc4_(&ngnmin, &r__1, &lbeta);
slamc4_(&gpmin, &a, &lbeta);
r__1 = -a;
slamc4_(&gnmin, &r__1, &lbeta);
ieee = FALSE_;
if (ngpmin == ngnmin && gpmin == gnmin) {
if (ngpmin == gpmin) {
lemin = ngpmin;
/* ( Non twos-complement machines, no gradual underflow; */
/* e.g., VAX ) */
} else if (gpmin - ngpmin == 3) {
lemin = ngpmin - 1 + lt;
ieee = TRUE_;
/* ( Non twos-complement machines, with gradual underflow; */
/* e.g., IEEE standard followers ) */
} else {
lemin = min(ngpmin,gpmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if (ngpmin == gpmin && ngnmin == gnmin) {
if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
lemin = max(ngpmin,ngnmin);
/* ( Twos-complement machines, no gradual underflow; */
/* e.g., CYBER 205 ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
{
if (gpmin - min(ngpmin,ngnmin) == 3) {
lemin = max(ngpmin,ngnmin) - 1 + lt;
/* ( Twos-complement machines with gradual underflow; */
/* no known machine ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else {
/* Computing MIN */
i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
lemin = min(i__1,gnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
first = FALSE_;
/* ** */
/* Comment out this if block if EMIN is ok */
if (iwarn) {
first = TRUE_;
printf("\n\n WARNING. The value EMIN may be incorrect:- ");
printf("EMIN = %8i\n",lemin);
printf("If, after inspection, the value EMIN looks acceptable");
printf("please comment out \n the IF block as marked within the");
printf("code of routine SLAMC2, \n otherwise supply EMIN");
printf("explicitly.\n");
/*
s_wsfe(&io___58);
do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer));
e_wsfe();
*/
}
/* ** */
/* Assume IEEE arithmetic if we found denormalised numbers above, */
/* or if arithmetic seems to round in the IEEE style, determined */
/* in routine SLAMC1. A true IEEE machine should have both things */
/* true; however, faulty machines may have one or the other. */
ieee = ieee || lieee1;
/* Compute RMIN by successive division by BETA. We could compute */
/* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */
/* this computation. */
lrmin = 1.f;
i__1 = 1 - lemin;
for (i__ = 1; i__ <= i__1; ++i__) {
r__1 = lrmin * rbase;
lrmin = slamc3_(&r__1, &zero);
/* L30: */
}
/* Finally, call SLAMC5 to compute EMAX and RMAX. */
slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
}
*beta = lbeta;
*t = lt;
*rnd = lrnd;
*eps = leps;
*emin = lemin;
*rmin = lrmin;
*emax = lemax;
*rmax = lrmax;
return 0;
/* End of SLAMC2 */
} /* slamc2_ */
doublereal slamch_(char *cmach)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1;
real ret_val;
/* Builtin functions */
double pow_ri(real *, integer *);
/* Local variables */
static real t;
integer it;
static real rnd, eps, base;
integer beta;
static real emin, prec, emax;
integer imin, imax;
logical lrnd;
static real rmin, rmax;
real rmach;
extern logical lsame_(char *, char *);
real small;
static real sfmin;
extern /* Subroutine */ int slamc2_(integer *, integer *, logical *, real
*, integer *, real *, integer *, real *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAMCH determines single precision machine parameters. */
/* Arguments */
/* ========= */
/* CMACH (input) CHARACTER*1 */
/* Specifies the value to be returned by SLAMCH: */
/* = 'E' or 'e', SLAMCH := eps */
/* = 'S' or 's , SLAMCH := sfmin */
/* = 'B' or 'b', SLAMCH := base */
/* = 'P' or 'p', SLAMCH := eps*base */
/* = 'N' or 'n', SLAMCH := t */
/* = 'R' or 'r', SLAMCH := rnd */
/* = 'M' or 'm', SLAMCH := emin */
/* = 'U' or 'u', SLAMCH := rmin */
/* = 'L' or 'l', SLAMCH := emax */
/* = 'O' or 'o', SLAMCH := rmax */
/* where */
/* eps = relative machine precision */
/* sfmin = safe minimum, such that 1/sfmin does not overflow */
/* base = base of the machine */
/* prec = eps*base */
/* t = number of (base) digits in the mantissa */
/* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise */
/* emin = minimum exponent before (gradual) underflow */
/* rmin = underflow threshold - base**(emin-1) */
/* emax = largest exponent before overflow */
/* rmax = overflow threshold - (base**emax)*(1-eps) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Save statement .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
if (first) {
slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
base = (real) beta;
t = (real) it;
if (lrnd) {
rnd = 1.f;
i__1 = 1 - it;
eps = pow_ri(&base, &i__1) / 2;
} else {
rnd = 0.f;
i__1 = 1 - it;
eps = pow_ri(&base, &i__1);
}
prec = eps * base;
emin = (real) imin;
emax = (real) imax;
sfmin = rmin;
small = 1.f / rmax;
if (small >= sfmin) {
/* Use SMALL plus a bit, to avoid the possibility of rounding */
/* causing overflow when computing 1/sfmin. */
sfmin = small * (eps + 1.f);
}
}
if (lsame_(cmach, "E")) {
rmach = eps;
} else if (lsame_(cmach, "S")) {
rmach = sfmin;
} else if (lsame_(cmach, "B")) {
rmach = base;
} else if (lsame_(cmach, "P")) {
rmach = prec;
} else if (lsame_(cmach, "N")) {
rmach = t;
} else if (lsame_(cmach, "R")) {
rmach = rnd;
} else if (lsame_(cmach, "M")) {
rmach = emin;
} else if (lsame_(cmach, "U")) {
rmach = rmin;
} else if (lsame_(cmach, "L")) {
rmach = emax;
} else if (lsame_(cmach, "O")) {
rmach = rmax;
}
ret_val = rmach;
first = FALSE_;
return ret_val;
/* End of SLAMCH */
} /* slamch_ */
/* Subroutine */ int slatm1_(integer *mode, real *cond, integer *irsign,
integer *idist, integer *iseed, real *d__, integer *n, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), pow_ri(real *, integer *), log(
doublereal), exp(doublereal);
/* Local variables */
integer i__;
real temp, alpha;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal slaran_(integer *);
extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
*);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLATM1 computes the entries of D(1..N) as specified by */
/* MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
/* of random numbers. SLATM1 is called by SLATMR to generate */
/* random test matrices for LAPACK programs. */
/* Arguments */
/* ========= */
/* MODE - INTEGER */
/* On entry describes how D is to be computed: */
/* MODE = 0 means do not change D. */
/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
/* MODE = 5 sets D to random numbers in the range */
/* ( 1/COND , 1 ) such that their logarithms */
/* are uniformly distributed. */
/* MODE = 6 set D to random numbers from same distribution */
/* as the rest of the matrix. */
/* MODE < 0 has the same meaning as ABS(MODE), except that */
/* the order of the elements of D is reversed. */
/* Thus if MODE is positive, D has entries ranging from */
/* 1 to 1/COND, if negative, from 1/COND to 1, */
/* Not modified. */
/* COND - REAL */
/* On entry, used as described under MODE above. */
/* If used, it must be >= 1. Not modified. */
/* IRSIGN - INTEGER */
/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
/* entries of D */
/* 0 => leave entries of D unchanged */
/* 1 => multiply each entry of D by 1 or -1 with probability .5 */
/* IDIST - CHARACTER*1 */
/* On entry, IDIST specifies the type of distribution to be */
/* used to generate a random matrix . */
/* 1 => UNIFORM( 0, 1 ) */
/* 2 => UNIFORM( -1, 1 ) */
/* 3 => NORMAL( 0, 1 ) */
/* Not modified. */
/* ISEED - INTEGER array, dimension ( 4 ) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The random number generator uses a */
/* linear congruential sequence limited to small */
/* integers, and so should produce machine independent */
/* random numbers. The values of ISEED are changed on */
/* exit, and can be used in the next call to SLATM1 */
/* to continue the same random number sequence. */
/* Changed on exit. */
/* D - REAL array, dimension ( MIN( M , N ) ) */
/* Array to be computed according to MODE, COND and IRSIGN. */
/* May be changed on exit if MODE is nonzero. */
/* N - INTEGER */
/* Number of entries of D. Not modified. */
/* INFO - INTEGER */
/* 0 => normal termination */
/* -1 => if MODE not in range -6 to 6 */
/* -2 => if MODE neither -6, 0 nor 6, and */
/* IRSIGN neither 0 nor 1 */
/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
/* -7 => if N negative */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test the input parameters. Initialize flags & seed. */
/* Parameter adjustments */
--d__;
--iseed;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Set INFO if an error */
if (*mode < -6 || *mode > 6) {
*info = -1;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
irsign != 1)) {
*info = -2;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) {
*info = -3;
} else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
*info = -4;
} else if (*n < 0) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLATM1", &i__1);
return 0;
}
/* Compute D according to COND and MODE */
if (*mode != 0) {
switch (abs(*mode)) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L70;
case 5: goto L90;
case 6: goto L110;
}
/* One large D value: */
L10:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = 1.f / *cond;
/* L20: */
}
d__[1] = 1.f;
goto L120;
/* One small D value: */
L30:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = 1.f;
/* L40: */
}
d__[*n] = 1.f / *cond;
goto L120;
/* Exponentially distributed D values: */
L50:
d__[1] = 1.f;
if (*n > 1) {
d__1 = (doublereal) (*cond);
d__2 = (doublereal) (-1.f / (real) (*n - 1));
alpha = pow_dd(&d__1, &d__2);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
d__[i__] = pow_ri(&alpha, &i__2);
/* L60: */
}
}
goto L120;
/* Arithmetically distributed D values: */
L70:
d__[1] = 1.f;
if (*n > 1) {
temp = 1.f / *cond;
alpha = (1.f - temp) / (real) (*n - 1);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
d__[i__] = (real) (*n - i__) * alpha + temp;
/* L80: */
}
}
goto L120;
/* Randomly distributed D values on ( 1/COND , 1): */
L90:
alpha = log(1.f / *cond);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = exp(alpha * slaran_(&iseed[1]));
/* L100: */
}
goto L120;
/* Randomly distributed D values from IDIST */
L110:
slarnv_(idist, &iseed[1], n, &d__[1]);
L120:
/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
/* random signs to D */
if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = slaran_(&iseed[1]);
if (temp > .5f) {
d__[i__] = -d__[i__];
}
/* L130: */
}
}
/* Reverse if MODE < 0 */
if (*mode < 0) {
i__1 = *n / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = d__[i__];
d__[i__] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = temp;
/* L140: */
}
}
}
return 0;
/* End of SLATM1 */
} /* slatm1_ */
/* Subroutine */ int clatm4_(integer *itype, integer *n, integer *nz1,
integer *nz2, logical *rsign, real *amagn, real *rcond, real *triang,
integer *idist, integer *iseed, complex *a, integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
real r__1;
doublereal d__1, d__2;
complex q__1, q__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), pow_ri(real *, integer *), log(
doublereal), exp(doublereal), c_abs(complex *);
/* Local variables */
static integer kbeg, isdb, kend, isde, klen, i__, k;
static real alpha;
static complex ctemp;
static integer jc, jd, jr;
extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
extern doublereal slaran_(integer *);
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
/* -- LAPACK auxiliary test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLATM4 generates basic square matrices, which may later be
multiplied by others in order to produce test matrices. It is
intended mainly to be used to test the generalized eigenvalue
routines.
It first generates the diagonal and (possibly) subdiagonal,
according to the value of ITYPE, NZ1, NZ2, RSIGN, AMAGN, and RCOND.
It then fills in the upper triangle with random numbers, if TRIANG is
non-zero.
Arguments
=========
ITYPE (input) INTEGER
The "type" of matrix on the diagonal and sub-diagonal.
If ITYPE < 0, then type abs(ITYPE) is generated and then
swapped end for end (A(I,J) := A'(N-J,N-I).) See also
the description of AMAGN and RSIGN.
Special types:
= 0: the zero matrix.
= 1: the identity.
= 2: a transposed Jordan block.
= 3: If N is odd, then a k+1 x k+1 transposed Jordan block
followed by a k x k identity block, where k=(N-1)/2.
If N is even, then k=(N-2)/2, and a zero diagonal entry
is tacked onto the end.
Diagonal types. The diagonal consists of NZ1 zeros, then
k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE
specifies the nonzero diagonal entries as follows:
= 4: 1, ..., k
= 5: 1, RCOND, ..., RCOND
= 6: 1, ..., 1, RCOND
= 7: 1, a, a^2, ..., a^(k-1)=RCOND
= 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
= 9: random numbers chosen from (RCOND,1)
= 10: random numbers with distribution IDIST (see CLARND.)
N (input) INTEGER
The order of the matrix.
NZ1 (input) INTEGER
If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
be zero.
NZ2 (input) INTEGER
If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
be zero.
RSIGN (input) LOGICAL
= .TRUE.: The diagonal and subdiagonal entries will be
multiplied by random numbers of magnitude 1.
= .FALSE.: The diagonal and subdiagonal entries will be
left as they are (usually non-negative real.)
AMAGN (input) REAL
The diagonal and subdiagonal entries will be multiplied by
AMAGN.
RCOND (input) REAL
If abs(ITYPE) > 4, then the smallest diagonal entry will be
RCOND. RCOND must be between 0 and 1.
TRIANG (input) REAL
The entries above the diagonal will be random numbers with
magnitude bounded by TRIANG (i.e., random numbers multiplied
by TRIANG.)
IDIST (input) INTEGER
On entry, DIST specifies the type of distribution to be used
to generate a random matrix .
= 1: real and imaginary parts each UNIFORM( 0, 1 )
= 2: real and imaginary parts each UNIFORM( -1, 1 )
= 3: real and imaginary parts each NORMAL( 0, 1 )
= 4: complex number uniform in DISK( 0, 1 )
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The values of ISEED are changed on exit, and can
be used in the next call to CLATM4 to continue the same
random number sequence.
Note: ISEED(4) should be odd, for the random number generator
used at present.
A (output) COMPLEX array, dimension (LDA, N)
Array to be computed.
LDA (input) INTEGER
Leading dimension of A. Must be at least 1 and at least N.
=====================================================================
Parameter adjustments */
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
claset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda);
/* Insure a correct ISEED */
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
and RCOND */
if (*itype != 0) {
if (abs(*itype) >= 4) {
/* Computing MAX
Computing MIN */
i__3 = *n, i__4 = *nz1 + 1;
i__1 = 1, i__2 = min(i__3,i__4);
kbeg = max(i__1,i__2);
/* Computing MAX
Computing MIN */
i__3 = *n, i__4 = *n - *nz2;
i__1 = kbeg, i__2 = min(i__3,i__4);
kend = max(i__1,i__2);
klen = kend + 1 - kbeg;
} else {
kbeg = 1;
kend = *n;
klen = *n;
}
isdb = 1;
isde = 0;
switch (abs(*itype)) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L80;
case 5: goto L100;
case 6: goto L120;
case 7: goto L140;
case 8: goto L160;
case 9: goto L180;
case 10: goto L200;
}
/* |ITYPE| = 1: Identity */
L10:
i__1 = *n;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = a_subscr(jd, jd);
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* L20: */
}
goto L220;
/* |ITYPE| = 2: Transposed Jordan block */
L30:
i__1 = *n - 1;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = a_subscr(jd + 1, jd);
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* L40: */
}
isdb = 1;
isde = *n - 1;
goto L220;
/* |ITYPE| = 3: Transposed Jordan block, followed by the identity. */
L50:
k = (*n - 1) / 2;
i__1 = k;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = a_subscr(jd + 1, jd);
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* L60: */
}
isdb = 1;
isde = k;
i__1 = (k << 1) + 1;
for (jd = k + 2; jd <= i__1; ++jd) {
i__2 = a_subscr(jd, jd);
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* L70: */
}
goto L220;
/* |ITYPE| = 4: 1,...,k */
L80:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = a_subscr(jd, jd);
i__3 = jd - *nz1;
q__1.r = (real) i__3, q__1.i = 0.f;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L90: */
}
goto L220;
/* |ITYPE| = 5: One large D value: */
L100:
i__1 = kend;
for (jd = kbeg + 1; jd <= i__1; ++jd) {
i__2 = a_subscr(jd, jd);
q__1.r = *rcond, q__1.i = 0.f;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L110: */
}
i__1 = a_subscr(kbeg, kbeg);
a[i__1].r = 1.f, a[i__1].i = 0.f;
goto L220;
/* |ITYPE| = 6: One small D value: */
L120:
i__1 = kend - 1;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = a_subscr(jd, jd);
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* L130: */
}
i__1 = a_subscr(kend, kend);
q__1.r = *rcond, q__1.i = 0.f;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
goto L220;
/* |ITYPE| = 7: Exponentially distributed D values: */
L140:
i__1 = a_subscr(kbeg, kbeg);
a[i__1].r = 1.f, a[i__1].i = 0.f;
if (klen > 1) {
d__1 = (doublereal) (*rcond);
d__2 = (doublereal) (1.f / (real) (klen - 1));
alpha = pow_dd(&d__1, &d__2);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = a_subscr(*nz1 + i__, *nz1 + i__);
i__3 = i__ - 1;
r__1 = pow_ri(&alpha, &i__3);
q__1.r = r__1, q__1.i = 0.f;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L150: */
}
}
goto L220;
/* |ITYPE| = 8: Arithmetically distributed D values: */
L160:
i__1 = a_subscr(kbeg, kbeg);
a[i__1].r = 1.f, a[i__1].i = 0.f;
if (klen > 1) {
alpha = (1.f - *rcond) / (real) (klen - 1);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = a_subscr(*nz1 + i__, *nz1 + i__);
r__1 = (real) (klen - i__) * alpha + *rcond;
q__1.r = r__1, q__1.i = 0.f;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L170: */
}
}
goto L220;
/* |ITYPE| = 9: Randomly distributed D values on ( RCOND, 1): */
L180:
alpha = log(*rcond);
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = a_subscr(jd, jd);
r__1 = exp(alpha * slaran_(&iseed[1]));
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L190: */
}
goto L220;
/* |ITYPE| = 10: Randomly distributed D values from DIST */
L200:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = a_subscr(jd, jd);
clarnd_(&q__1, idist, &iseed[1]);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* L210: */
}
L220:
/* Scale by AMAGN */
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = a_subscr(jd, jd);
i__3 = a_subscr(jd, jd);
r__1 = *amagn * a[i__3].r;
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L230: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
i__2 = a_subscr(jd + 1, jd);
i__3 = a_subscr(jd + 1, jd);
r__1 = *amagn * a[i__3].r;
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L240: */
}
/* If RSIGN = .TRUE., assign random signs to diagonal and
subdiagonal */
if (*rsign) {
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = a_subscr(jd, jd);
if (a[i__2].r != 0.f) {
clarnd_(&q__1, &c__3, &iseed[1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
r__1 = c_abs(&ctemp);
q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__2 = a_subscr(jd, jd);
i__3 = a_subscr(jd, jd);
r__1 = a[i__3].r;
q__1.r = r__1 * ctemp.r, q__1.i = r__1 * ctemp.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
/* L250: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
i__2 = a_subscr(jd + 1, jd);
if (a[i__2].r != 0.f) {
clarnd_(&q__1, &c__3, &iseed[1]);
ctemp.r = q__1.r, ctemp.i = q__1.i;
r__1 = c_abs(&ctemp);
q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
ctemp.r = q__1.r, ctemp.i = q__1.i;
i__2 = a_subscr(jd + 1, jd);
i__3 = a_subscr(jd + 1, jd);
r__1 = a[i__3].r;
q__1.r = r__1 * ctemp.r, q__1.i = r__1 * ctemp.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
/* L260: */
}
}
/* Reverse if ITYPE < 0 */
if (*itype < 0) {
i__1 = (kbeg + kend - 1) / 2;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = a_subscr(jd, jd);
ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
i__2 = a_subscr(jd, jd);
i__3 = a_subscr(kbeg + kend - jd, kbeg + kend - jd);
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
i__2 = a_subscr(kbeg + kend - jd, kbeg + kend - jd);
a[i__2].r = ctemp.r, a[i__2].i = ctemp.i;
/* L270: */
}
i__1 = (*n - 1) / 2;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = a_subscr(jd + 1, jd);
ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
i__2 = a_subscr(jd + 1, jd);
i__3 = a_subscr(*n + 1 - jd, *n - jd);
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
i__2 = a_subscr(*n + 1 - jd, *n - jd);
a[i__2].r = ctemp.r, a[i__2].i = ctemp.i;
/* L280: */
}
}
}
/* Fill in upper triangle */
if (*triang != 0.f) {
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
i__2 = jc - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = a_subscr(jr, jc);
clarnd_(&q__2, idist, &iseed[1]);
q__1.r = *triang * q__2.r, q__1.i = *triang * q__2.i;
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L290: */
}
/* L300: */
}
}
return 0;
/* End of CLATM4 */
} /* clatm4_ */
/* Subroutine */ int clargv_(integer *n, complex *x, integer *incx, complex *
y, integer *incy, real *c__, integer *incc)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
complex q__1, q__2, q__3;
/* Builtin functions */
double log(doublereal), pow_ri(real *, integer *), r_imag(complex *),
sqrt(doublereal);
void r_cnjg(complex *, complex *);
/* Local variables */
real d__;
complex f, g;
integer i__, j;
complex r__;
real f2, g2;
integer ic;
real di;
complex ff;
real cs, dr;
complex fs, gs;
integer ix, iy;
complex sn;
real f2s, g2s, eps, scale;
integer count;
real safmn2, safmx2;
extern doublereal slapy2_(real *, real *), slamch_(char *);
real safmin;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARGV generates a vector of complex plane rotations with real */
/* cosines, determined by elements of the complex vectors x and y. */
/* For i = 1,2,...,n */
/* ( c(i) s(i) ) ( x(i) ) = ( r(i) ) */
/* ( -conjg(s(i)) c(i) ) ( y(i) ) = ( 0 ) */
/* where c(i)**2 + ABS(s(i))**2 = 1 */
/* The following conventions are used (these are the same as in CLARTG, */
/* but differ from the BLAS1 routine CROTG): */
/* If y(i)=0, then c(i)=1 and s(i)=0. */
/* If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of plane rotations to be generated. */
/* X (input/output) COMPLEX array, dimension (1+(N-1)*INCX) */
/* On entry, the vector x. */
/* On exit, x(i) is overwritten by r(i), for i = 1,...,n. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY) */
/* On entry, the vector y. */
/* On exit, the sines of the plane rotations. */
/* INCY (input) INTEGER */
/* The increment between elements of Y. INCY > 0. */
/* C (output) REAL array, dimension (1+(N-1)*INCC) */
/* The cosines of the plane rotations. */
/* INCC (input) INTEGER */
/* The increment between elements of C. INCC > 0. */
/* Further Details */
/* ======= ======= */
/* 6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel */
/* This version has a few statements commented out for thread safety */
/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* LOGICAL FIRST */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Save statement .. */
/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
/* .. */
/* .. Data statements .. */
/* DATA FIRST / .TRUE. / */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* IF( FIRST ) THEN */
/* FIRST = .FALSE. */
/* Parameter adjustments */
--c__;
--y;
--x;
/* Function Body */
safmin = slamch_("S");
eps = slamch_("E");
r__1 = slamch_("B");
i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f);
safmn2 = pow_ri(&r__1, &i__1);
safmx2 = 1.f / safmn2;
/* END IF */
ix = 1;
iy = 1;
ic = 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = ix;
f.r = x[i__2].r, f.i = x[i__2].i;
i__2 = iy;
g.r = y[i__2].r, g.i = y[i__2].i;
/* Use identical algorithm as in CLARTG */
/* Computing MAX */
/* Computing MAX */
r__7 = (r__1 = f.r, dabs(r__1)), r__8 = (r__2 = r_imag(&f), dabs(r__2)
);
/* Computing MAX */
r__9 = (r__3 = g.r, dabs(r__3)), r__10 = (r__4 = r_imag(&g), dabs(
r__4));
r__5 = dmax(r__7,r__8), r__6 = dmax(r__9,r__10);
scale = dmax(r__5,r__6);
fs.r = f.r, fs.i = f.i;
gs.r = g.r, gs.i = g.i;
count = 0;
if (scale >= safmx2) {
L10:
++count;
q__1.r = safmn2 * fs.r, q__1.i = safmn2 * fs.i;
fs.r = q__1.r, fs.i = q__1.i;
q__1.r = safmn2 * gs.r, q__1.i = safmn2 * gs.i;
gs.r = q__1.r, gs.i = q__1.i;
scale *= safmn2;
if (scale >= safmx2) {
goto L10;
}
} else if (scale <= safmn2) {
if (g.r == 0.f && g.i == 0.f) {
cs = 1.f;
sn.r = 0.f, sn.i = 0.f;
r__.r = f.r, r__.i = f.i;
goto L50;
}
L20:
--count;
q__1.r = safmx2 * fs.r, q__1.i = safmx2 * fs.i;
fs.r = q__1.r, fs.i = q__1.i;
q__1.r = safmx2 * gs.r, q__1.i = safmx2 * gs.i;
gs.r = q__1.r, gs.i = q__1.i;
scale *= safmx2;
if (scale <= safmn2) {
goto L20;
}
}
/* Computing 2nd power */
r__1 = fs.r;
/* Computing 2nd power */
r__2 = r_imag(&fs);
f2 = r__1 * r__1 + r__2 * r__2;
/* Computing 2nd power */
r__1 = gs.r;
/* Computing 2nd power */
r__2 = r_imag(&gs);
g2 = r__1 * r__1 + r__2 * r__2;
if (f2 <= dmax(g2,1.f) * safmin) {
/* This is a rare case: F is very small. */
if (f.r == 0.f && f.i == 0.f) {
cs = 0.f;
r__2 = g.r;
r__3 = r_imag(&g);
r__1 = slapy2_(&r__2, &r__3);
r__.r = r__1, r__.i = 0.f;
/* Do complex/real division explicitly with two real */
/* divisions */
r__1 = gs.r;
r__2 = r_imag(&gs);
d__ = slapy2_(&r__1, &r__2);
r__1 = gs.r / d__;
r__2 = -r_imag(&gs) / d__;
q__1.r = r__1, q__1.i = r__2;
sn.r = q__1.r, sn.i = q__1.i;
goto L50;
}
r__1 = fs.r;
r__2 = r_imag(&fs);
f2s = slapy2_(&r__1, &r__2);
/* G2 and G2S are accurate */
/* G2 is at least SAFMIN, and G2S is at least SAFMN2 */
g2s = sqrt(g2);
/* Error in CS from underflow in F2S is at most */
/* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS */
/* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, */
/* and so CS .lt. sqrt(SAFMIN) */
/* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN */
/* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) */
/* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S */
cs = f2s / g2s;
/* Make sure abs(FF) = 1 */
/* Do complex/real division explicitly with 2 real divisions */
/* Computing MAX */
r__3 = (r__1 = f.r, dabs(r__1)), r__4 = (r__2 = r_imag(&f), dabs(
r__2));
if (dmax(r__3,r__4) > 1.f) {
r__1 = f.r;
r__2 = r_imag(&f);
d__ = slapy2_(&r__1, &r__2);
r__1 = f.r / d__;
r__2 = r_imag(&f) / d__;
q__1.r = r__1, q__1.i = r__2;
ff.r = q__1.r, ff.i = q__1.i;
} else {
dr = safmx2 * f.r;
di = safmx2 * r_imag(&f);
d__ = slapy2_(&dr, &di);
r__1 = dr / d__;
r__2 = di / d__;
q__1.r = r__1, q__1.i = r__2;
ff.r = q__1.r, ff.i = q__1.i;
}
r__1 = gs.r / g2s;
r__2 = -r_imag(&gs) / g2s;
q__2.r = r__1, q__2.i = r__2;
q__1.r = ff.r * q__2.r - ff.i * q__2.i, q__1.i = ff.r * q__2.i +
ff.i * q__2.r;
sn.r = q__1.r, sn.i = q__1.i;
q__2.r = cs * f.r, q__2.i = cs * f.i;
q__3.r = sn.r * g.r - sn.i * g.i, q__3.i = sn.r * g.i + sn.i *
g.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
r__.r = q__1.r, r__.i = q__1.i;
} else {
/* This is the most common case. */
/* Neither F2 nor F2/G2 are less than SAFMIN */
/* F2S cannot overflow, and it is accurate */
f2s = sqrt(g2 / f2 + 1.f);
/* Do the F2S(real)*FS(complex) multiply with two real */
/* multiplies */
r__1 = f2s * fs.r;
r__2 = f2s * r_imag(&fs);
q__1.r = r__1, q__1.i = r__2;
r__.r = q__1.r, r__.i = q__1.i;
cs = 1.f / f2s;
d__ = f2 + g2;
/* Do complex/real division explicitly with two real divisions */
r__1 = r__.r / d__;
r__2 = r_imag(&r__) / d__;
q__1.r = r__1, q__1.i = r__2;
sn.r = q__1.r, sn.i = q__1.i;
r_cnjg(&q__2, &gs);
q__1.r = sn.r * q__2.r - sn.i * q__2.i, q__1.i = sn.r * q__2.i +
sn.i * q__2.r;
sn.r = q__1.r, sn.i = q__1.i;
if (count != 0) {
if (count > 0) {
i__2 = count;
for (j = 1; j <= i__2; ++j) {
q__1.r = safmx2 * r__.r, q__1.i = safmx2 * r__.i;
r__.r = q__1.r, r__.i = q__1.i;
/* L30: */
}
} else {
i__2 = -count;
for (j = 1; j <= i__2; ++j) {
q__1.r = safmn2 * r__.r, q__1.i = safmn2 * r__.i;
r__.r = q__1.r, r__.i = q__1.i;
/* L40: */
}
}
}
}
L50:
c__[ic] = cs;
i__2 = iy;
y[i__2].r = sn.r, y[i__2].i = sn.i;
i__2 = ix;
x[i__2].r = r__.r, x[i__2].i = r__.i;
ic += *incc;
iy += *incy;
ix += *incx;
/* L60: */
}
return 0;
/* End of CLARGV */
} /* clargv_ */
/*! \brief
<pre>
Purpose
=======
SLAMC2 determines the machine parameters specified in its argument
list.
Arguments
=========
BETA (output) INT
The base of the machine.
T (output) INT
The number of ( BETA ) digits in the mantissa.
RND (output) INT
Specifies whether proper rounding ( RND = .TRUE. ) or
chopping ( RND = .FALSE. ) occurs in addition. This may not
be a reliable guide to the way in which the machine performs
its arithmetic.
EPS (output) FLOAT
The smallest positive number such that
fl( 1.0 - EPS ) .LT. 1.0,
where fl denotes the computed value.
EMIN (output) INT
The minimum exponent before (gradual) underflow occurs.
RMIN (output) FLOAT
The smallest normalized number for the machine, given by
BASE**( EMIN - 1 ), where BASE is the floating point value
of BETA.
EMAX (output) INT
The maximum exponent before overflow occurs.
RMAX (output) FLOAT
The largest positive number for the machine, given by
BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
value of BETA.
Further Details
===============
The computation of EPS is based on a routine PARANOIA by
W. Kahan of the University of California at Berkeley.
=====================================================================
</pre>
*/
int slamc2_(int *beta, int *t, int *rnd, float *
eps, int *emin, float *rmin, int *emax, float *rmax)
{
/* Table of constant values */
static int c__1 = 1;
/* Initialized data */
static int first = TRUE_;
static int iwarn = FALSE_;
/* System generated locals */
int i__1;
float r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double pow_ri(float *, int *);
/* Local variables */
static int ieee;
static float half;
static int lrnd;
static float leps, zero, a, b, c;
static int i, lbeta;
static float rbase;
static int lemin, lemax, gnmin;
static float small;
static int gpmin;
static float third, lrmin, lrmax, sixth;
static int lieee1;
extern /* Subroutine */ int slamc1_(int *, int *, int *,
int *);
extern double slamc3_(float *, float *);
extern /* Subroutine */ int slamc4_(int *, float *, int *),
slamc5_(int *, int *, int *, int *, int *,
float *);
static int lt, ngnmin, ngpmin;
static float one, two;
if (first) {
first = FALSE_;
zero = 0.f;
one = 1.f;
two = 2.f;
/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values
of
BETA, T, RND, EPS, EMIN and RMIN.
Throughout this routine we use the function SLAMC3 to ens
ure
that relevant values are stored and not held in registers,
or
are not affected by optimizers.
SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
*/
slamc1_(&lbeta, <, &lrnd, &lieee1);
/* Start to find EPS. */
b = (float) lbeta;
i__1 = -lt;
a = pow_ri(&b, &i__1);
leps = a;
/* Try some tricks to see whether or not this is the correct E
PS. */
b = two / 3;
half = one / 2;
r__1 = -(double)half;
sixth = slamc3_(&b, &r__1);
third = slamc3_(&sixth, &sixth);
r__1 = -(double)half;
b = slamc3_(&third, &r__1);
b = slamc3_(&b, &sixth);
b = dabs(b);
if (b < leps) {
b = leps;
}
leps = 1.f;
/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
L10:
if (leps > b && b > zero) {
leps = b;
r__1 = half * leps;
/* Computing 5th power */
r__3 = two, r__4 = r__3, r__3 *= r__3;
/* Computing 2nd power */
r__5 = leps;
r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
c = slamc3_(&r__1, &r__2);
r__1 = -(double)c;
c = slamc3_(&half, &r__1);
b = slamc3_(&half, &c);
r__1 = -(double)b;
c = slamc3_(&half, &r__1);
b = slamc3_(&half, &c);
goto L10;
}
/* + END WHILE */
if (a < leps) {
leps = a;
}
/* Computation of EPS complete.
Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3
)).
Keep dividing A by BETA until (gradual) underflow occurs. T
his
is detected when we cannot recover the previous A. */
rbase = one / lbeta;
small = one;
for (i = 1; i <= 3; ++i) {
r__1 = small * rbase;
small = slamc3_(&r__1, &zero);
/* L20: */
}
a = slamc3_(&one, &small);
slamc4_(&ngpmin, &one, &lbeta);
r__1 = -(double)one;
slamc4_(&ngnmin, &r__1, &lbeta);
slamc4_(&gpmin, &a, &lbeta);
r__1 = -(double)a;
slamc4_(&gnmin, &r__1, &lbeta);
ieee = FALSE_;
if (ngpmin == ngnmin && gpmin == gnmin) {
if (ngpmin == gpmin) {
lemin = ngpmin;
/* ( Non twos-complement machines, no gradual under
flow;
e.g., VAX ) */
} else if (gpmin - ngpmin == 3) {
lemin = ngpmin - 1 + lt;
ieee = TRUE_;
/* ( Non twos-complement machines, with gradual und
erflow;
e.g., IEEE standard followers ) */
} else {
lemin = min(ngpmin,gpmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if (ngpmin == gpmin && ngnmin == gnmin) {
if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
lemin = max(ngpmin,ngnmin);
/* ( Twos-complement machines, no gradual underflow
;
e.g., CYBER 205 ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
{
if (gpmin - min(ngpmin,ngnmin) == 3) {
lemin = max(ngpmin,ngnmin) - 1 + lt;
/* ( Twos-complement machines with gradual underflo
w;
no known machine ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else {
/* Computing MIN */
i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
lemin = min(i__1,gnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
/* **
Comment out this if block if EMIN is ok */
if (iwarn) {
first = TRUE_;
printf("\n\n WARNING. The value EMIN may be incorrect:- ");
printf("EMIN = %8i\n",lemin);
printf("If, after inspection, the value EMIN looks acceptable");
printf("please comment out \n the IF block as marked within the");
printf("code of routine SLAMC2, \n otherwise supply EMIN");
printf("explicitly.\n");
}
/* **
Assume IEEE arithmetic if we found denormalised numbers abo
ve,
or if arithmetic seems to round in the IEEE style, determi
ned
in routine SLAMC1. A true IEEE machine should have both thi
ngs
true; however, faulty machines may have one or the other. */
ieee = ieee || lieee1;
/* Compute RMIN by successive division by BETA. We could comp
ute
RMIN as BASE**( EMIN - 1 ), but some machines underflow dur
ing
this computation. */
lrmin = 1.f;
i__1 = 1 - lemin;
for (i = 1; i <= 1-lemin; ++i) {
r__1 = lrmin * rbase;
lrmin = slamc3_(&r__1, &zero);
/* L30: */
}
/* Finally, call SLAMC5 to compute EMAX and RMAX. */
slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
}
*beta = lbeta;
*t = lt;
*rnd = lrnd;
*eps = leps;
*emin = lemin;
*rmin = lrmin;
*emax = lemax;
*rmax = lrmax;
return 0;
/* End of SLAMC2 */
} /* slamc2_ */
/* Subroutine */ int ssyequb_(char *uplo, integer *n, real *a, integer *lda,
real *s, real *scond, real *amax, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1, r__2, r__3;
/* Local variables */
real d__;
integer i__, j;
real t, u, c0, c1, c2, si;
logical up;
real avg, std, tol, base;
integer iter;
real smin, smax, scale;
real sumsq;
real bignum;
real smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* Purpose */
/* ======= */
/* SSYEQUB computes row and column scalings intended to equilibrate a */
/* symmetric matrix A and reduce its condition number */
/* (with respect to the two-norm). S contains the scale factors, */
/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
/* choice of S puts the condition number of B within a factor N of the */
/* smallest possible condition number over all possible diagonal */
/* scalings. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The N-by-N symmetric matrix whose scaling */
/* factors are to be computed. Only the diagonal elements of A */
/* are referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* S (output) REAL array, dimension (N) */
/* If INFO = 0, S contains the scale factors for A. */
/* SCOND (output) REAL */
/* If INFO = 0, S contains the ratio of the smallest S(i) to */
/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
/* large nor too small, it is not worth scaling by S. */
/* AMAX (output) REAL */
/* Absolute value of largest matrix element. If AMAX is very */
/* close to overflow or very close to underflow, the matrix */
/* should be scaled. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
/* Further Details */
/* ======= ======= */
/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */
/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */
/* DOI 10.1023/B:NUMA.0000016606.32820.69 */
/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */
/* ===================================================================== */
/* Test input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
--work;
/* Function Body */
*info = 0;
if (! (lsame_(uplo, "U") || 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_("SSYEQUB", &i__1);
return 0;
}
up = lsame_(uplo, "U");
*amax = 0.f;
/* Quick return if possible. */
if (*n == 0) {
*scond = 1.f;
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
s[i__] = 0.f;
}
*amax = 0.f;
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = s[i__], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1))
;
s[i__] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = s[j], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
s[j] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = *amax, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
*amax = dmax(r__2,r__3);
}
/* Computing MAX */
r__2 = s[j], r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
s[j] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = *amax, r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
*amax = dmax(r__2,r__3);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = s[j], r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
s[j] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = *amax, r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
*amax = dmax(r__2,r__3);
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = s[i__], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1))
;
s[i__] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = s[j], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
s[j] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = *amax, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
*amax = dmax(r__2,r__3);
}
}
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = 1.f / s[j];
}
tol = 1.f / sqrt(*n * 2.f);
for (iter = 1; iter <= 100; ++iter) {
scale = 0.f;
sumsq = 0.f;
/* BETA = |A|S */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
}
if (up) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
j];
work[j] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
i__];
}
work[j] += (r__1 = a[j + j * a_dim1], dabs(r__1)) * s[j];
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[j] += (r__1 = a[j + j * a_dim1], dabs(r__1)) * s[j];
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
j];
work[j] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
i__];
}
}
}
/* avg = s^T beta / n */
avg = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
avg += s[i__] * work[i__];
}
avg /= *n;
std = 0.f;
i__1 = *n * 3;
for (i__ = (*n << 1) + 1; i__ <= i__1; ++i__) {
work[i__] = s[i__ - (*n << 1)] * work[i__ - (*n << 1)] - avg;
}
slassq_(n, &work[(*n << 1) + 1], &c__1, &scale, &sumsq);
std = scale * sqrt(sumsq / *n);
if (std < tol * avg) {
goto L999;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
t = (r__1 = a[i__ + i__ * a_dim1], dabs(r__1));
si = s[i__];
c2 = (*n - 1) * t;
c1 = (*n - 2) * (work[i__] - t * si);
c0 = -(t * si) * si + work[i__] * 2 * si - *n * avg;
d__ = c1 * c1 - c0 * 4 * c2;
if (d__ <= 0.f) {
*info = -1;
return 0;
}
si = c0 * -2 / (c1 + sqrt(d__));
d__ = si - s[i__];
u = 0.f;
if (up) {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
u += s[j] * t;
work[j] += d__ * t;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
u += s[j] * t;
work[j] += d__ * t;
}
} else {
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
u += s[j] * t;
work[j] += d__ * t;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
t = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
u += s[j] * t;
work[j] += d__ * t;
}
}
avg += (u + work[i__]) * d__ / *n;
s[i__] = si;
}
}
L999:
smlnum = slamch_("SAFEMIN");
bignum = 1.f / smlnum;
smin = bignum;
smax = 0.f;
t = 1.f / sqrt(avg);
base = slamch_("B");
u = 1.f / log(base);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = (integer) (u * log(s[i__] * t));
s[i__] = pow_ri(&base, &i__2);
/* Computing MIN */
r__1 = smin, r__2 = s[i__];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[i__];
smax = dmax(r__1,r__2);
}
*scond = dmax(smin,smlnum) / dmin(smax,bignum);
return 0;
} /* ssyequb_ */
/*! \brief
<pre>
Purpose
=======
SLAMCH determines single precision machine parameters.
Arguments
=========
CMACH (input) CHARACTER*1
Specifies the value to be returned by SLAMCH:
= 'E' or 'e', SLAMCH := eps
= 'S' or 's , SLAMCH := sfmin
= 'B' or 'b', SLAMCH := base
= 'P' or 'p', SLAMCH := eps*base
= 'N' or 'n', SLAMCH := t
= 'R' or 'r', SLAMCH := rnd
= 'M' or 'm', SLAMCH := emin
= 'U' or 'u', SLAMCH := rmin
= 'L' or 'l', SLAMCH := emax
= 'O' or 'o', SLAMCH := rmax
where
eps = relative machine precision
sfmin = safe minimum, such that 1/sfmin does not overflow
base = base of the machine
prec = eps*base
t = number of (base) digits in the mantissa
rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
emin = minimum exponent before (gradual) underflow
rmin = underflow threshold - base**(emin-1)
emax = largest exponent before overflow
rmax = overflow threshold - (base**emax)*(1-eps)
=====================================================================
</pre>
*/
float slamch_(char *cmach)
{
/* >>Start of File<<
Initialized data */
static int first = TRUE_;
/* System generated locals */
int i__1;
float ret_val;
/* Builtin functions */
double pow_ri(float *, int *);
/* Local variables */
static float base;
static int beta;
static float emin, prec, emax;
static int imin, imax;
static int lrnd;
static float rmin, rmax, t, rmach;
extern int lsame_(char *, char *);
static float small, sfmin;
extern /* Subroutine */ int slamc2_(int *, int *, int *, float
*, int *, float *, int *, float *);
static int it;
static float rnd, eps;
if (first) {
first = FALSE_;
slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
base = (float) beta;
t = (float) it;
if (lrnd) {
rnd = 1.f;
i__1 = 1 - it;
eps = pow_ri(&base, &i__1) / 2;
} else {
rnd = 0.f;
i__1 = 1 - it;
eps = pow_ri(&base, &i__1);
}
prec = eps * base;
emin = (float) imin;
emax = (float) imax;
sfmin = rmin;
small = 1.f / rmax;
if (small >= sfmin) {
/* Use SMALL plus a bit, to avoid the possibility of rou
nding
causing overflow when computing 1/sfmin. */
sfmin = small * (eps + 1.f);
}
}
if (lsame_(cmach, "E")) {
rmach = eps;
} else if (lsame_(cmach, "S")) {
rmach = sfmin;
} else if (lsame_(cmach, "B")) {
rmach = base;
} else if (lsame_(cmach, "P")) {
rmach = prec;
} else if (lsame_(cmach, "N")) {
rmach = t;
} else if (lsame_(cmach, "R")) {
rmach = rnd;
} else if (lsame_(cmach, "M")) {
rmach = emin;
} else if (lsame_(cmach, "U")) {
rmach = rmin;
} else if (lsame_(cmach, "L")) {
rmach = emax;
} else if (lsame_(cmach, "O")) {
rmach = rmax;
}
ret_val = rmach;
return ret_val;
/* End of SLAMCH */
} /* slamch_ */
/* DECK PSIFN */
/* Subroutine */ int psifn_(real *x, integer *n, integer *kode, integer *m,
real *ans, integer *nz, integer *ierr)
{
/* Initialized data */
static integer nmax = 100;
static real b[22] = { 1.f,-.5f,.166666666666666667f,
-.0333333333333333333f,.0238095238095238095f,
-.0333333333333333333f,.0757575757575757576f,
-.253113553113553114f,1.16666666666666667f,-7.09215686274509804f,
54.9711779448621554f,-529.124242424242424f,6192.1231884057971f,
-86580.2531135531136f,1425517.16666666667f,-27298231.067816092f,
601580873.900642368f,-15116315767.0921569f,429614643061.166667f,
-13711655205088.3328f,488332318973593.167f,-19296579341940068.1f }
;
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Local variables */
static integer i__, j, k;
static real s, t, t1, t2, fn, ta;
static integer mm, nn, np;
static real fx, tk;
static integer mx, nx;
static real xm, tt, xq, den, arg, fln, fnp, r1m4, r1m5, fns, eps, rln,
tol, xln, trm[22], tss, tst, elim, xinc, xmin, tols, xdmy, yint,
trmr[100], rxsq, slope, xdmln, wdtol;
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE PSIFN */
/* ***PURPOSE Compute derivatives of the Psi function. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C7C */
/* ***TYPE SINGLE PRECISION (PSIFN-S, DPSIFN-D) */
/* ***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, */
/* PSI FUNCTION */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* The following definitions are used in PSIFN: */
/* Definition 1 */
/* PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of */
/* the LOG GAMMA function. */
/* Definition 2 */
/* K K */
/* PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). */
/* ___________________________________________________________________ */
/* PSIFN computes a sequence of SCALED derivatives of */
/* the PSI function; i.e. for fixed X and M it computes */
/* the M-member sequence */
/* ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) */
/* for K = N,...,N+M-1 */
/* where PSI(K,X) is as defined above. For KODE=1, PSIFN returns */
/* the scaled derivatives as described. KODE=2 is operative only */
/* when K=0 and in that case PSIFN returns -PSI(X) + LN(X). That */
/* is, the logarithmic behavior for large X is removed when KODE=1 */
/* and K=0. When sums or differences of PSI functions are computed */
/* the logarithmic terms can be combined analytically and computed */
/* separately to help retain significant digits. */
/* Note that CALL PSIFN(X,0,1,1,ANS) results in */
/* ANS = -PSI(X) */
/* Input */
/* X - Argument, X .gt. 0.0E0 */
/* N - First member of the sequence, 0 .le. N .le. 100 */
/* N=0 gives ANS(1) = -PSI(X) for KODE=1 */
/* -PSI(X)+LN(X) for KODE=2 */
/* KODE - Selection parameter */
/* KODE=1 returns scaled derivatives of the PSI */
/* function. */
/* KODE=2 returns scaled derivatives of the PSI */
/* function EXCEPT when N=0. In this case, */
/* ANS(1) = -PSI(X) + LN(X) is returned. */
/* M - Number of members of the sequence, M .ge. 1 */
/* Output */
/* ANS - A vector of length at least M whose first M */
/* components contain the sequence of derivatives */
/* scaled according to KODE. */
/* NZ - Underflow flag */
/* NZ.eq.0, A normal return */
/* NZ.ne.0, Underflow, last NZ components of ANS are */
/* set to zero, ANS(M-K+1)=0.0, K=1,...,NZ */
/* IERR - Error flag */
/* IERR=0, A normal return, computation completed */
/* IERR=1, Input error, no computation */
/* IERR=2, Overflow, X too small or N+M-1 too */
/* large or both */
/* IERR=3, Error, N too large. Dimensioned */
/* array TRMR(NMAX) is not large enough for N */
/* The nominal computational accuracy is the maximum of unit */
/* roundoff (=R1MACH(4)) and 1.0E-18 since critical constants */
/* are given to only 18 digits. */
/* DPSIFN is the Double Precision version of PSIFN. */
/* *Long Description: */
/* The basic method of evaluation is the asymptotic expansion */
/* for large X.ge.XMIN followed by backward recursion on a two */
/* term recursion relation */
/* W(X+1) + X**(-N-1) = W(X). */
/* This is supplemented by a series */
/* SUM( (X+K)**(-N-1) , K=0,1,2,... ) */
/* which converges rapidly for large N. Both XMIN and the */
/* number of terms of the series are calculated from the unit */
/* roundoff of the machine environment. */
/* ***REFERENCES Handbook of Mathematical Functions, National Bureau */
/* of Standards Applied Mathematics Series 55, edited */
/* by M. Abramowitz and I. A. Stegun, equations 6.3.5, */
/* 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. */
/* D. E. Amos, A portable Fortran subroutine for */
/* derivatives of the Psi function, Algorithm 610, ACM */
/* Transactions on Mathematical Software 9, 4 (1983), */
/* pp. 494-502. */
/* ***ROUTINES CALLED I1MACH, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 820601 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE PSIFN */
/* Parameter adjustments */
--ans;
/* Function Body */
/* ----------------------------------------------------------------------- */
/* BERNOULLI NUMBERS */
/* ----------------------------------------------------------------------- */
/* ***FIRST EXECUTABLE STATEMENT PSIFN */
*ierr = 0;
*nz = 0;
if (*x <= 0.f) {
*ierr = 1;
}
if (*n < 0) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*m < 1) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
mm = *m;
/* Computing MIN */
i__1 = -i1mach_(&c__12), i__2 = i1mach_(&c__13);
nx = min(i__1,i__2);
r1m5 = r1mach_(&c__5);
r1m4 = r1mach_(&c__4) * .5f;
wdtol = dmax(r1m4,5e-19f);
/* ----------------------------------------------------------------------- */
/* ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT */
/* ----------------------------------------------------------------------- */
elim = (nx * r1m5 - 3.f) * 2.302f;
xln = log(*x);
L41:
nn = *n + mm - 1;
fn = (real) nn;
fnp = fn + 1.f;
t = fnp * xln;
/* ----------------------------------------------------------------------- */
/* OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X */
/* ----------------------------------------------------------------------- */
if (dabs(t) > elim) {
goto L290;
}
if (*x < wdtol) {
goto L260;
}
/* ----------------------------------------------------------------------- */
/* COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 */
/* ----------------------------------------------------------------------- */
rln = r1m5 * i1mach_(&c__11);
rln = dmin(rln,18.06f);
fln = dmax(rln,3.f) - 3.f;
yint = fln * .4f + 3.5f;
slope = fln * (fln * 6.038e-4f + .008677f) + .21f;
xm = yint + slope * fn;
mx = (integer) xm + 1;
xmin = (real) mx;
if (*n == 0) {
goto L50;
}
xm = rln * -2.302f - dmin(0.f,xln);
fns = (real) (*n);
arg = xm / fns;
arg = dmin(0.f,arg);
eps = exp(arg);
xm = 1.f - eps;
if (dabs(arg) < .001f) {
xm = -arg;
}
fln = *x * xm / eps;
xm = xmin - *x;
if (xm > 7.f && fln < 15.f) {
goto L200;
}
L50:
xdmy = *x;
xdmln = xln;
xinc = 0.f;
if (*x >= xmin) {
goto L60;
}
nx = (integer) (*x);
xinc = xmin - nx;
xdmy = *x + xinc;
xdmln = log(xdmy);
L60:
/* ----------------------------------------------------------------------- */
/* GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION */
/* ----------------------------------------------------------------------- */
t = fn * xdmln;
t1 = xdmln + xdmln;
t2 = t + xdmln;
/* Computing MAX */
r__1 = dabs(t), r__2 = dabs(t1), r__1 = max(r__1,r__2), r__2 = dabs(t2);
tk = dmax(r__1,r__2);
if (tk > elim) {
goto L380;
}
tss = exp(-t);
tt = .5f / xdmy;
t1 = tt;
tst = wdtol * tt;
if (nn != 0) {
t1 = tt + 1.f / fn;
}
rxsq = 1.f / (xdmy * xdmy);
ta = rxsq * .5f;
t = fnp * ta;
s = t * b[2];
if (dabs(s) < tst) {
goto L80;
}
tk = 2.f;
for (k = 4; k <= 22; ++k) {
t = t * ((tk + fn + 1.f) / (tk + 1.f)) * ((tk + fn) / (tk + 2.f)) *
rxsq;
trm[k - 1] = t * b[k - 1];
if ((r__1 = trm[k - 1], dabs(r__1)) < tst) {
goto L80;
}
s += trm[k - 1];
tk += 2.f;
/* L70: */
}
L80:
s = (s + t1) * tss;
if (xinc == 0.f) {
goto L100;
}
/* ----------------------------------------------------------------------- */
/* BACKWARD RECUR FROM XDMY TO X */
/* ----------------------------------------------------------------------- */
nx = (integer) xinc;
np = nn + 1;
if (nx > nmax) {
goto L390;
}
if (nn == 0) {
goto L160;
}
xm = xinc - 1.f;
fx = *x + xm;
/* ----------------------------------------------------------------------- */
/* THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL */
/* ----------------------------------------------------------------------- */
i__1 = nx;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = -np;
trmr[i__ - 1] = pow_ri(&fx, &i__2);
s += trmr[i__ - 1];
xm += -1.f;
fx = *x + xm;
/* L90: */
}
L100:
ans[mm] = s;
if (fn == 0.f) {
goto L180;
}
/* ----------------------------------------------------------------------- */
/* GENERATE LOWER DERIVATIVES, J.LT.N+MM-1 */
/* ----------------------------------------------------------------------- */
if (mm == 1) {
return 0;
}
i__1 = mm;
for (j = 2; j <= i__1; ++j) {
fnp = fn;
fn += -1.f;
tss *= xdmy;
t1 = tt;
if (fn != 0.f) {
t1 = tt + 1.f / fn;
}
t = fnp * ta;
s = t * b[2];
if (dabs(s) < tst) {
goto L120;
}
tk = fnp + 3.f;
for (k = 4; k <= 22; ++k) {
trm[k - 1] = trm[k - 1] * fnp / tk;
if ((r__1 = trm[k - 1], dabs(r__1)) < tst) {
goto L120;
}
s += trm[k - 1];
tk += 2.f;
/* L110: */
}
L120:
s = (s + t1) * tss;
if (xinc == 0.f) {
goto L140;
}
if (fn == 0.f) {
goto L160;
}
xm = xinc - 1.f;
fx = *x + xm;
i__2 = nx;
for (i__ = 1; i__ <= i__2; ++i__) {
trmr[i__ - 1] *= fx;
s += trmr[i__ - 1];
xm += -1.f;
fx = *x + xm;
/* L130: */
}
L140:
mx = mm - j + 1;
ans[mx] = s;
if (fn == 0.f) {
goto L180;
}
/* L150: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* RECURSION FOR N = 0 */
/* ----------------------------------------------------------------------- */
L160:
i__1 = nx;
for (i__ = 1; i__ <= i__1; ++i__) {
s += 1.f / (*x + nx - i__);
/* L170: */
}
L180:
if (*kode == 2) {
goto L190;
}
ans[1] = s - xdmln;
return 0;
L190:
if (xdmy == *x) {
return 0;
}
xq = xdmy / *x;
ans[1] = s - log(xq);
return 0;
/* ----------------------------------------------------------------------- */
/* COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... */
/* ----------------------------------------------------------------------- */
L200:
nn = (integer) fln + 1;
np = *n + 1;
t1 = (fns + 1.f) * xln;
t = exp(-t1);
s = t;
den = *x;
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
den += 1.f;
i__2 = -np;
trm[i__ - 1] = pow_ri(&den, &i__2);
s += trm[i__ - 1];
/* L210: */
}
ans[1] = s;
if (*n != 0) {
goto L220;
}
if (*kode == 2) {
ans[1] = s + xln;
}
L220:
if (mm == 1) {
return 0;
}
/* ----------------------------------------------------------------------- */
/* GENERATE HIGHER DERIVATIVES, J.GT.N */
/* ----------------------------------------------------------------------- */
tol = wdtol / 5.f;
i__1 = mm;
for (j = 2; j <= i__1; ++j) {
t /= *x;
s = t;
tols = t * tol;
den = *x;
i__2 = nn;
for (i__ = 1; i__ <= i__2; ++i__) {
den += 1.f;
trm[i__ - 1] /= den;
s += trm[i__ - 1];
if (trm[i__ - 1] < tols) {
goto L240;
}
/* L230: */
}
L240:
ans[j] = s;
/* L250: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* SMALL X.LT.UNIT ROUND OFF */
/* ----------------------------------------------------------------------- */
L260:
i__1 = -(*n) - 1;
ans[1] = pow_ri(x, &i__1);
if (mm == 1) {
goto L280;
}
k = 1;
i__1 = mm;
for (i__ = 2; i__ <= i__1; ++i__) {
ans[k + 1] = ans[k] / *x;
++k;
/* L270: */
}
L280:
if (*n != 0) {
return 0;
}
if (*kode == 2) {
ans[1] += xln;
}
return 0;
L290:
if (t > 0.f) {
goto L380;
}
*nz = 0;
*ierr = 2;
return 0;
L380:
++(*nz);
ans[mm] = 0.f;
--mm;
if (mm == 0) {
return 0;
}
goto L41;
L390:
*ierr = 3;
*nz = 0;
return 0;
} /* psifn_ */
/* Subroutine */ int schkeq_(real *thresh, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002All tests for \002,a3,\002 routines pa"
"ssed the threshold\002)";
static char fmt_9998[] = "(\002 SGEEQU failed test with value \002,e10"
".3,\002 exceeding\002,\002 threshold \002,e10.3)";
static char fmt_9997[] = "(\002 SGBEQU failed test with value \002,e10"
".3,\002 exceeding\002,\002 threshold \002,e10.3)";
static char fmt_9996[] = "(\002 SPOEQU failed test with value \002,e10"
".3,\002 exceeding\002,\002 threshold \002,e10.3)";
static char fmt_9995[] = "(\002 SPPEQU failed test with value \002,e10"
".3,\002 exceeding\002,\002 threshold \002,e10.3)";
static char fmt_9994[] = "(\002 SPBEQU failed test with value \002,e10"
".3,\002 exceeding\002,\002 threshold \002,e10.3)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
real r__1, r__2, r__3;
/* Local variables */
real a[25] /* was [5][5] */, c__[5];
integer i__, j, m, n;
real r__[5], ab[65] /* was [13][5] */, ap[15];
integer kl;
logical ok;
integer ku;
real eps, pow[11];
integer info;
char path[3];
real norm, rpow[11], ccond, rcond, rcmin, rcmax, ratio;
real reslts[5];
/* Fortran I/O blocks */
static cilist io___25 = { 0, 0, 0, 0, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9994, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SCHKEQ tests SGEEQU, SGBEQU, SPOEQU, SPPEQU and SPBEQU */
/* Arguments */
/* ========= */
/* THRESH (input) REAL */
/* Threshold for testing routines. Should be between 2 and 10. */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "EQ", (ftnlen)2, (ftnlen)2);
eps = slamch_("P");
for (i__ = 1; i__ <= 5; ++i__) {
reslts[i__ - 1] = 0.f;
/* L10: */
}
for (i__ = 1; i__ <= 11; ++i__) {
i__1 = i__ - 1;
pow[i__ - 1] = pow_ri(&c_b7, &i__1);
rpow[i__ - 1] = 1.f / pow[i__ - 1];
/* L20: */
}
/* Test SGEEQU */
for (n = 0; n <= 5; ++n) {
for (m = 0; m <= 5; ++m) {
for (j = 1; j <= 5; ++j) {
for (i__ = 1; i__ <= 5; ++i__) {
if (i__ <= m && j <= n) {
i__1 = i__ + j;
a[i__ + j * 5 - 6] = pow[i__ + j] * pow_ii(&c_n1, &
i__1);
} else {
a[i__ + j * 5 - 6] = 0.f;
}
/* L30: */
}
/* L40: */
}
sgeequ_(&m, &n, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
if (info != 0) {
reslts[0] = 1.f;
} else {
if (n != 0 && m != 0) {
/* Computing MAX */
r__2 = reslts[0], r__3 = (r__1 = (rcond - rpow[m - 1]) /
rpow[m - 1], dabs(r__1));
reslts[0] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[0], r__3 = (r__1 = (ccond - rpow[n - 1]) /
rpow[n - 1], dabs(r__1));
reslts[0] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[0], r__3 = (r__1 = (norm - pow[n + m]) /
pow[n + m], dabs(r__1));
reslts[0] = dmax(r__2,r__3);
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = reslts[0], r__3 = (r__1 = (r__[i__ - 1] - rpow[
i__ + n]) / rpow[i__ + n], dabs(r__1));
reslts[0] = dmax(r__2,r__3);
/* L50: */
}
i__1 = n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = reslts[0], r__3 = (r__1 = (c__[j - 1] - pow[n
- j]) / pow[n - j], dabs(r__1));
reslts[0] = dmax(r__2,r__3);
/* L60: */
}
}
}
/* L70: */
}
/* L80: */
}
/* Test with zero rows and columns */
for (j = 1; j <= 5; ++j) {
a[j * 5 - 2] = 0.f;
/* L90: */
}
sgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
if (info != 4) {
reslts[0] = 1.f;
}
for (j = 1; j <= 5; ++j) {
a[j * 5 - 2] = 1.f;
/* L100: */
}
for (i__ = 1; i__ <= 5; ++i__) {
a[i__ + 14] = 0.f;
/* L110: */
}
sgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
if (info != 9) {
reslts[0] = 1.f;
}
reslts[0] /= eps;
/* Test SGBEQU */
for (n = 0; n <= 5; ++n) {
for (m = 0; m <= 5; ++m) {
/* Computing MAX */
i__2 = m - 1;
i__1 = max(i__2,0);
for (kl = 0; kl <= i__1; ++kl) {
/* Computing MAX */
i__3 = n - 1;
i__2 = max(i__3,0);
for (ku = 0; ku <= i__2; ++ku) {
for (j = 1; j <= 5; ++j) {
for (i__ = 1; i__ <= 13; ++i__) {
ab[i__ + j * 13 - 14] = 0.f;
/* L120: */
}
/* L130: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
/* Computing MIN */
i__5 = m, i__6 = j + kl;
/* Computing MAX */
i__7 = 1, i__8 = j - ku;
if (i__ <= min(i__5,i__6) && i__ >= max(i__7,i__8)
&& j <= n) {
i__5 = i__ + j;
ab[ku + 1 + i__ - j + j * 13 - 14] = pow[i__
+ j] * pow_ii(&c_n1, &i__5);
}
/* L140: */
}
/* L150: */
}
sgbequ_(&m, &n, &kl, &ku, ab, &c__13, r__, c__, &rcond, &
ccond, &norm, &info);
if (info != 0) {
if (! (n + kl < m && info == n + kl + 1 || m + ku < n
&& info == (m << 1) + ku + 1)) {
reslts[1] = 1.f;
}
} else {
if (n != 0 && m != 0) {
rcmin = r__[0];
rcmax = r__[0];
i__3 = m;
for (i__ = 1; i__ <= i__3; ++i__) {
/* Computing MIN */
r__1 = rcmin, r__2 = r__[i__ - 1];
rcmin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = rcmax, r__2 = r__[i__ - 1];
rcmax = dmax(r__1,r__2);
/* L160: */
}
ratio = rcmin / rcmax;
/* Computing MAX */
r__2 = reslts[1], r__3 = (r__1 = (rcond - ratio) /
ratio, dabs(r__1));
reslts[1] = dmax(r__2,r__3);
rcmin = c__[0];
rcmax = c__[0];
i__3 = n;
for (j = 1; j <= i__3; ++j) {
/* Computing MIN */
r__1 = rcmin, r__2 = c__[j - 1];
rcmin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = rcmax, r__2 = c__[j - 1];
rcmax = dmax(r__1,r__2);
/* L170: */
}
ratio = rcmin / rcmax;
/* Computing MAX */
r__2 = reslts[1], r__3 = (r__1 = (ccond - ratio) /
ratio, dabs(r__1));
reslts[1] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[1], r__3 = (r__1 = (norm - pow[n +
m]) / pow[n + m], dabs(r__1));
reslts[1] = dmax(r__2,r__3);
i__3 = m;
for (i__ = 1; i__ <= i__3; ++i__) {
rcmax = 0.f;
i__4 = n;
for (j = 1; j <= i__4; ++j) {
if (i__ <= j + kl && i__ >= j - ku) {
ratio = (r__1 = r__[i__ - 1] * pow[
i__ + j] * c__[j - 1], dabs(
r__1));
rcmax = dmax(rcmax,ratio);
}
/* L180: */
}
/* Computing MAX */
r__2 = reslts[1], r__3 = (r__1 = 1.f - rcmax,
dabs(r__1));
reslts[1] = dmax(r__2,r__3);
/* L190: */
}
i__3 = n;
for (j = 1; j <= i__3; ++j) {
rcmax = 0.f;
i__4 = m;
for (i__ = 1; i__ <= i__4; ++i__) {
if (i__ <= j + kl && i__ >= j - ku) {
ratio = (r__1 = r__[i__ - 1] * pow[
i__ + j] * c__[j - 1], dabs(
r__1));
rcmax = dmax(rcmax,ratio);
}
/* L200: */
}
/* Computing MAX */
r__2 = reslts[1], r__3 = (r__1 = 1.f - rcmax,
dabs(r__1));
reslts[1] = dmax(r__2,r__3);
/* L210: */
}
}
}
/* L220: */
}
/* L230: */
}
/* L240: */
}
/* L250: */
}
reslts[1] /= eps;
/* Test SPOEQU */
for (n = 0; n <= 5; ++n) {
for (i__ = 1; i__ <= 5; ++i__) {
for (j = 1; j <= 5; ++j) {
if (i__ <= n && j == i__) {
i__1 = i__ + j;
a[i__ + j * 5 - 6] = pow[i__ + j] * pow_ii(&c_n1, &i__1);
} else {
a[i__ + j * 5 - 6] = 0.f;
}
/* L260: */
}
/* L270: */
}
spoequ_(&n, a, &c__5, r__, &rcond, &norm, &info);
if (info != 0) {
reslts[2] = 1.f;
} else {
if (n != 0) {
/* Computing MAX */
r__2 = reslts[2], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
n - 1], dabs(r__1));
reslts[2] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[2], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
2], dabs(r__1));
reslts[2] = dmax(r__2,r__3);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = reslts[2], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
) / rpow[i__], dabs(r__1));
reslts[2] = dmax(r__2,r__3);
/* L280: */
}
}
}
/* L290: */
}
a[18] = -1.f;
spoequ_(&c__5, a, &c__5, r__, &rcond, &norm, &info);
if (info != 4) {
reslts[2] = 1.f;
}
reslts[2] /= eps;
/* Test SPPEQU */
for (n = 0; n <= 5; ++n) {
/* Upper triangular packed storage */
i__1 = n * (n + 1) / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
ap[i__ - 1] = 0.f;
/* L300: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
ap[i__ * (i__ + 1) / 2 - 1] = pow[i__ * 2];
/* L310: */
}
sppequ_("U", &n, ap, r__, &rcond, &norm, &info);
if (info != 0) {
reslts[3] = 1.f;
} else {
if (n != 0) {
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
n - 1], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
2], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
) / rpow[i__], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
/* L320: */
}
}
}
/* Lower triangular packed storage */
i__1 = n * (n + 1) / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
ap[i__ - 1] = 0.f;
/* L330: */
}
j = 1;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
ap[j - 1] = pow[i__ * 2];
j += n - i__ + 1;
/* L340: */
}
sppequ_("L", &n, ap, r__, &rcond, &norm, &info);
if (info != 0) {
reslts[3] = 1.f;
} else {
if (n != 0) {
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
n - 1], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
2], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = reslts[3], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
) / rpow[i__], dabs(r__1));
reslts[3] = dmax(r__2,r__3);
/* L350: */
}
}
}
/* L360: */
}
i__ = 13;
ap[i__ - 1] = -1.f;
sppequ_("L", &c__5, ap, r__, &rcond, &norm, &info);
if (info != 4) {
reslts[3] = 1.f;
}
reslts[3] /= eps;
/* Test SPBEQU */
for (n = 0; n <= 5; ++n) {
/* Computing MAX */
i__2 = n - 1;
i__1 = max(i__2,0);
for (kl = 0; kl <= i__1; ++kl) {
/* Test upper triangular storage */
for (j = 1; j <= 5; ++j) {
for (i__ = 1; i__ <= 13; ++i__) {
ab[i__ + j * 13 - 14] = 0.f;
/* L370: */
}
/* L380: */
}
i__2 = n;
for (j = 1; j <= i__2; ++j) {
ab[kl + 1 + j * 13 - 14] = pow[j * 2];
/* L390: */
}
spbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
if (info != 0) {
reslts[4] = 1.f;
} else {
if (n != 0) {
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (rcond - rpow[n - 1]) /
rpow[n - 1], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (norm - pow[n * 2]) /
pow[n * 2], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (r__[i__ - 1] - rpow[
i__]) / rpow[i__], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
/* L400: */
}
}
}
if (n != 0) {
/* Computing MAX */
i__2 = n - 1;
ab[kl + 1 + max(i__2,1) * 13 - 14] = -1.f;
spbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
/* Computing MAX */
i__2 = n - 1;
if (info != max(i__2,1)) {
reslts[4] = 1.f;
}
}
/* Test lower triangular storage */
for (j = 1; j <= 5; ++j) {
for (i__ = 1; i__ <= 13; ++i__) {
ab[i__ + j * 13 - 14] = 0.f;
/* L410: */
}
/* L420: */
}
i__2 = n;
for (j = 1; j <= i__2; ++j) {
ab[j * 13 - 13] = pow[j * 2];
/* L430: */
}
spbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
if (info != 0) {
reslts[4] = 1.f;
} else {
if (n != 0) {
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (rcond - rpow[n - 1]) /
rpow[n - 1], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (norm - pow[n * 2]) /
pow[n * 2], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = reslts[4], r__3 = (r__1 = (r__[i__ - 1] - rpow[
i__]) / rpow[i__], dabs(r__1));
reslts[4] = dmax(r__2,r__3);
/* L440: */
}
}
}
if (n != 0) {
/* Computing MAX */
i__2 = n - 1;
ab[max(i__2,1) * 13 - 13] = -1.f;
spbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
/* Computing MAX */
i__2 = n - 1;
if (info != max(i__2,1)) {
reslts[4] = 1.f;
}
}
/* L450: */
}
/* L460: */
}
reslts[4] /= eps;
ok = reslts[0] <= *thresh && reslts[1] <= *thresh && reslts[2] <= *thresh
&& reslts[3] <= *thresh && reslts[4] <= *thresh;
io___25.ciunit = *nout;
s_wsle(&io___25);
e_wsle();
if (ok) {
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else {
if (reslts[0] > *thresh) {
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&reslts[0], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
}
if (reslts[1] > *thresh) {
io___28.ciunit = *nout;
s_wsfe(&io___28);
do_fio(&c__1, (char *)&reslts[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
}
if (reslts[2] > *thresh) {
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&reslts[2], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
}
if (reslts[3] > *thresh) {
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&reslts[3], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
}
if (reslts[4] > *thresh) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&reslts[4], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
}
}
return 0;
/* End of SCHKEQ */
} /* schkeq_ */
/* Subroutine */ int spoequb_(integer *n, real *a, integer *lda, real *s,
real *scond, real *amax, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double log(doublereal), pow_ri(real *, integer *), sqrt(doublereal);
/* Local variables */
integer i__;
real tmp, base, smin;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPOEQU computes row and column scalings intended to equilibrate a */
/* symmetric positive definite matrix A and reduce its condition number */
/* (with respect to the two-norm). S contains the scale factors, */
/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
/* choice of S puts the condition number of B within a factor N of the */
/* smallest possible condition number over all possible diagonal */
/* scalings. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The N-by-N symmetric positive definite matrix whose scaling */
/* factors are to be computed. Only the diagonal elements of A */
/* are referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* S (output) REAL array, dimension (N) */
/* If INFO = 0, S contains the scale factors for A. */
/* SCOND (output) REAL */
/* If INFO = 0, S contains the ratio of the smallest S(i) to */
/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
/* large nor too small, it is not worth scaling by S. */
/* AMAX (output) REAL */
/* Absolute value of largest matrix element. If AMAX is very */
/* close to overflow or very close to underflow, the matrix */
/* should be scaled. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Positive definite only performs 1 pass of equilibration. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*lda < max(1,*n)) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOEQUB", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
*scond = 1.f;
*amax = 0.f;
return 0;
}
base = slamch_("B");
tmp = -.5f / log(base);
/* Find the minimum and maximum diagonal elements. */
s[1] = a[a_dim1 + 1];
smin = s[1];
*amax = s[1];
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
s[i__] = a[i__ + i__ * a_dim1];
/* Computing MIN */
r__1 = smin, r__2 = s[i__];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = *amax, r__2 = s[i__];
*amax = dmax(r__1,r__2);
/* L10: */
}
if (smin <= 0.f) {
/* Find the first non-positive diagonal element and return. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] <= 0.f) {
*info = i__;
return 0;
}
/* L20: */
}
} else {
/* Set the scale factors to the reciprocals */
/* of the diagonal elements. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = (integer) (tmp * log(s[i__]));
s[i__] = pow_ri(&base, &i__2);
/* L30: */
}
/* Compute SCOND = min(S(I)) / max(S(I)). */
*scond = sqrt(smin) / sqrt(*amax);
}
return 0;
/* End of SPOEQUB */
} /* spoequb_ */
doublereal slamch_(char *cmach)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
SLAMCH determines single precision machine parameters.
Arguments
=========
CMACH (input) CHARACTER*1
Specifies the value to be returned by SLAMCH:
= 'E' or 'e', SLAMCH := eps
= 'S' or 's , SLAMCH := sfmin
= 'B' or 'b', SLAMCH := base
= 'P' or 'p', SLAMCH := eps*base
= 'N' or 'n', SLAMCH := t
= 'R' or 'r', SLAMCH := rnd
= 'M' or 'm', SLAMCH := emin
= 'U' or 'u', SLAMCH := rmin
= 'L' or 'l', SLAMCH := emax
= 'O' or 'o', SLAMCH := rmax
where
eps = relative machine precision
sfmin = safe minimum, such that 1/sfmin does not overflow
base = base of the machine
prec = eps*base
t = number of (base) digits in the mantissa
rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
emin = minimum exponent before (gradual) underflow
rmin = underflow threshold - base**(emin-1)
emax = largest exponent before overflow
rmax = overflow threshold - (base**emax)*(1-eps)
=====================================================================
*/
/* >>Start of File<<
Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1;
real ret_val;
/* Builtin functions */
double pow_ri(real *, integer *);
/* Local variables */
static real base;
static integer beta;
static real emin, prec, emax;
static integer imin, imax;
static logical lrnd;
static real rmin, rmax, t, rmach;
extern logical lsame_(char *, char *);
static real small, sfmin;
extern /* Subroutine */ int slamc2_(integer *, integer *, logical *, real
*, integer *, real *, integer *, real *);
static integer it;
static real rnd, eps;
if (first) {
first = FALSE_;
slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
base = (real) beta;
t = (real) it;
if (lrnd) {
rnd = 1.f;
i__1 = 1 - it;
eps = pow_ri(&base, &i__1) / 2;
} else {
rnd = 0.f;
i__1 = 1 - it;
eps = pow_ri(&base, &i__1);
}
prec = eps * base;
emin = (real) imin;
emax = (real) imax;
sfmin = rmin;
small = 1.f / rmax;
if (small >= sfmin) {
/* Use SMALL plus a bit, to avoid the possibility of rou
nding
causing overflow when computing 1/sfmin. */
sfmin = small * (eps + 1.f);
}
}
if (lsame_(cmach, "E")) {
rmach = eps;
} else if (lsame_(cmach, "S")) {
rmach = sfmin;
} else if (lsame_(cmach, "B")) {
rmach = base;
} else if (lsame_(cmach, "P")) {
rmach = prec;
} else if (lsame_(cmach, "N")) {
rmach = t;
} else if (lsame_(cmach, "R")) {
rmach = rnd;
} else if (lsame_(cmach, "M")) {
rmach = emin;
} else if (lsame_(cmach, "U")) {
rmach = rmin;
} else if (lsame_(cmach, "L")) {
rmach = emax;
} else if (lsame_(cmach, "O")) {
rmach = rmax;
}
ret_val = rmach;
return ret_val;
/* End of SLAMCH */
} /* slamch_ */
/* Subroutine */ int slasq4_(integer *n, real *q, real *e, real *tau, real *
sup)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SLASQ4 estimates TAU, the smallest eigenvalue of a matrix. This
routine improves the input value of SUP which is an upper bound
for the smallest eigenvalue for this matrix .
Arguments
=========
N (input) INTEGER
On entry, N specifies the number of rows and columns
in the matrix. N must be at least 0.
Q (input) REAL array, dimension (N)
Q array
E (input) REAL array, dimension (N)
E array
TAU (output) REAL
Estimate of the shift
SUP (input/output) REAL
Upper bound for the smallest singular value
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static real c_b4 = .7f;
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double pow_ri(real *, integer *);
/* Local variables */
static real xinf, d;
static integer i;
static real dm;
static integer ifl;
#define E(I) e[(I)-1]
#define Q(I) q[(I)-1]
ifl = 1;
/* Computing MIN */
r__1 = min(*sup,Q(1)), r__1 = min(r__1,Q(2)), r__1 = min(r__1,Q(3)), r__2
= Q(*n), r__1 = min(r__1,r__2), r__2 = Q(*n - 1), r__1 = min(r__1,
r__2), r__2 = Q(*n - 2);
*sup = dmin(r__1,r__2);
*tau = *sup * .9999f;
xinf = 0.f;
L10:
if (ifl == 5) {
*tau = xinf;
return 0;
}
d = Q(1) - *tau;
dm = d;
i__1 = *n - 2;
for (i = 1; i <= *n-2; ++i) {
d = d / (d + E(i)) * Q(i + 1) - *tau;
if (dm > d) {
dm = d;
}
if (d < 0.f) {
*sup = *tau;
/* Computing MAX */
r__1 = *sup * pow_ri(&c_b4, &ifl), r__2 = d + *tau;
*tau = dmax(r__1,r__2);
++ifl;
goto L10;
}
/* L20: */
}
d = d / (d + E(*n - 1)) * Q(*n) - *tau;
if (dm > d) {
dm = d;
}
if (d < 0.f) {
*sup = *tau;
/* Computing MAX */
r__1 = xinf, r__2 = d + *tau;
xinf = dmax(r__1,r__2);
if (*sup * pow_ri(&c_b4, &ifl) <= xinf) {
*tau = xinf;
} else {
*tau = *sup * pow_ri(&c_b4, &ifl);
++ifl;
goto L10;
}
} else {
/* Computing MIN */
r__1 = *sup, r__2 = dm + *tau;
*sup = dmin(r__1,r__2);
}
return 0;
/* End of SLASQ4 */
} /* slasq4_ */
/* Subroutine */ int clartg_(complex *f, complex *g, real *cs, complex *sn,
complex *r__)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
complex q__1, q__2, q__3;
/* Builtin functions */
double log(doublereal), pow_ri(real *, integer *), r_imag(complex *),
sqrt(doublereal);
void r_cnjg(complex *, complex *);
/* Local variables */
real d__;
integer i__;
real f2, g2;
complex ff;
real di, dr;
complex fs, gs;
real f2s, g2s, eps, scale;
integer count;
real safmn2, safmx2;
extern doublereal slapy2_(real *, real *), slamch_(char *);
real safmin;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARTG generates a plane rotation so that */
/* [ CS SN ] [ F ] [ R ] */
/* [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. */
/* [ -SN CS ] [ G ] [ 0 ] */
/* This is a faster version of the BLAS1 routine CROTG, except for */
/* the following differences: */
/* F and G are unchanged on return. */
/* If G=0, then CS=1 and SN=0. */
/* If F=0, then CS=0 and SN is chosen so that R is real. */
/* Arguments */
/* ========= */
/* F (input) COMPLEX */
/* The first component of vector to be rotated. */
/* G (input) COMPLEX */
/* The second component of vector to be rotated. */
/* CS (output) REAL */
/* The cosine of the rotation. */
/* SN (output) COMPLEX */
/* The sine of the rotation. */
/* R (output) COMPLEX */
/* The nonzero component of the rotated vector. */
/* Further Details */
/* ======= ======= */
/* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel */
/* This version has a few statements commented out for thread safety */
/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* LOGICAL FIRST */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Save statement .. */
/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
/* .. */
/* .. Data statements .. */
/* DATA FIRST / .TRUE. / */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* IF( FIRST ) THEN */
safmin = slamch_("S");
eps = slamch_("E");
r__1 = slamch_("B");
i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f);
safmn2 = pow_ri(&r__1, &i__1);
safmx2 = 1.f / safmn2;
/* FIRST = .FALSE. */
/* END IF */
/* Computing MAX */
/* Computing MAX */
r__7 = (r__1 = f->r, dabs(r__1)), r__8 = (r__2 = r_imag(f), dabs(r__2));
/* Computing MAX */
r__9 = (r__3 = g->r, dabs(r__3)), r__10 = (r__4 = r_imag(g), dabs(r__4));
r__5 = dmax(r__7,r__8), r__6 = dmax(r__9,r__10);
scale = dmax(r__5,r__6);
fs.r = f->r, fs.i = f->i;
gs.r = g->r, gs.i = g->i;
count = 0;
if (scale >= safmx2) {
L10:
++count;
q__1.r = safmn2 * fs.r, q__1.i = safmn2 * fs.i;
fs.r = q__1.r, fs.i = q__1.i;
q__1.r = safmn2 * gs.r, q__1.i = safmn2 * gs.i;
gs.r = q__1.r, gs.i = q__1.i;
scale *= safmn2;
if (scale >= safmx2) {
goto L10;
}
} else if (scale <= safmn2) {
if (g->r == 0.f && g->i == 0.f) {
*cs = 1.f;
sn->r = 0.f, sn->i = 0.f;
r__->r = f->r, r__->i = f->i;
return 0;
}
L20:
--count;
q__1.r = safmx2 * fs.r, q__1.i = safmx2 * fs.i;
fs.r = q__1.r, fs.i = q__1.i;
q__1.r = safmx2 * gs.r, q__1.i = safmx2 * gs.i;
gs.r = q__1.r, gs.i = q__1.i;
scale *= safmx2;
if (scale <= safmn2) {
goto L20;
}
}
/* Computing 2nd power */
r__1 = fs.r;
/* Computing 2nd power */
r__2 = r_imag(&fs);
f2 = r__1 * r__1 + r__2 * r__2;
/* Computing 2nd power */
r__1 = gs.r;
/* Computing 2nd power */
r__2 = r_imag(&gs);
g2 = r__1 * r__1 + r__2 * r__2;
if (f2 <= dmax(g2,1.f) * safmin) {
/* This is a rare case: F is very small. */
if (f->r == 0.f && f->i == 0.f) {
*cs = 0.f;
r__2 = g->r;
r__3 = r_imag(g);
r__1 = slapy2_(&r__2, &r__3);
r__->r = r__1, r__->i = 0.f;
/* Do complex/real division explicitly with two real divisions */
r__1 = gs.r;
r__2 = r_imag(&gs);
d__ = slapy2_(&r__1, &r__2);
r__1 = gs.r / d__;
r__2 = -r_imag(&gs) / d__;
q__1.r = r__1, q__1.i = r__2;
sn->r = q__1.r, sn->i = q__1.i;
return 0;
}
r__1 = fs.r;
r__2 = r_imag(&fs);
f2s = slapy2_(&r__1, &r__2);
/* G2 and G2S are accurate */
/* G2 is at least SAFMIN, and G2S is at least SAFMN2 */
g2s = sqrt(g2);
/* Error in CS from underflow in F2S is at most */
/* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS */
/* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, */
/* and so CS .lt. sqrt(SAFMIN) */
/* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN */
/* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) */
/* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S */
*cs = f2s / g2s;
/* Make sure abs(FF) = 1 */
/* Do complex/real division explicitly with 2 real divisions */
/* Computing MAX */
r__3 = (r__1 = f->r, dabs(r__1)), r__4 = (r__2 = r_imag(f), dabs(r__2)
);
if (dmax(r__3,r__4) > 1.f) {
r__1 = f->r;
r__2 = r_imag(f);
d__ = slapy2_(&r__1, &r__2);
r__1 = f->r / d__;
r__2 = r_imag(f) / d__;
q__1.r = r__1, q__1.i = r__2;
ff.r = q__1.r, ff.i = q__1.i;
} else {
dr = safmx2 * f->r;
di = safmx2 * r_imag(f);
d__ = slapy2_(&dr, &di);
r__1 = dr / d__;
r__2 = di / d__;
q__1.r = r__1, q__1.i = r__2;
ff.r = q__1.r, ff.i = q__1.i;
}
r__1 = gs.r / g2s;
r__2 = -r_imag(&gs) / g2s;
q__2.r = r__1, q__2.i = r__2;
q__1.r = ff.r * q__2.r - ff.i * q__2.i, q__1.i = ff.r * q__2.i + ff.i
* q__2.r;
sn->r = q__1.r, sn->i = q__1.i;
q__2.r = *cs * f->r, q__2.i = *cs * f->i;
q__3.r = sn->r * g->r - sn->i * g->i, q__3.i = sn->r * g->i + sn->i *
g->r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
r__->r = q__1.r, r__->i = q__1.i;
} else {
/* This is the most common case. */
/* Neither F2 nor F2/G2 are less than SAFMIN */
/* F2S cannot overflow, and it is accurate */
f2s = sqrt(g2 / f2 + 1.f);
/* Do the F2S(real)*FS(complex) multiply with two real multiplies */
r__1 = f2s * fs.r;
r__2 = f2s * r_imag(&fs);
q__1.r = r__1, q__1.i = r__2;
r__->r = q__1.r, r__->i = q__1.i;
*cs = 1.f / f2s;
d__ = f2 + g2;
/* Do complex/real division explicitly with two real divisions */
r__1 = r__->r / d__;
r__2 = r_imag(r__) / d__;
q__1.r = r__1, q__1.i = r__2;
sn->r = q__1.r, sn->i = q__1.i;
r_cnjg(&q__2, &gs);
q__1.r = sn->r * q__2.r - sn->i * q__2.i, q__1.i = sn->r * q__2.i +
sn->i * q__2.r;
sn->r = q__1.r, sn->i = q__1.i;
if (count != 0) {
if (count > 0) {
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
q__1.r = safmx2 * r__->r, q__1.i = safmx2 * r__->i;
r__->r = q__1.r, r__->i = q__1.i;
/* L30: */
}
} else {
i__1 = -count;
for (i__ = 1; i__ <= i__1; ++i__) {
q__1.r = safmn2 * r__->r, q__1.i = safmn2 * r__->i;
r__->r = q__1.r, r__->i = q__1.i;
/* L40: */
}
}
}
}
return 0;
/* End of CLARTG */
} /* clartg_ */
/* Subroutine */ int slaed6_(integer *kniter, logical *orgati, real *rho,
real *d__, real *z__, real *finit, real *tau, integer *info)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(doublereal), log(doublereal), pow_ri(real *, integer *);
/* Local variables */
real a, b, c__, f;
integer i__;
real fc, df, ddf, lbd, eta, ubd, eps, base;
integer iter;
real temp, temp1, temp2, temp3, temp4;
logical scale;
integer niter;
real small1, small2, sminv1, sminv2, dscale[3], sclfac;
extern doublereal slamch_(char *);
real zscale[3], erretm, sclinv;
/* -- LAPACK routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* February 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAED6 computes the positive or negative root (closest to the origin) */
/* of */
/* z(1) z(2) z(3) */
/* f(x) = rho + --------- + ---------- + --------- */
/* d(1)-x d(2)-x d(3)-x */
/* It is assumed that */
/* if ORGATI = .true. the root is between d(2) and d(3); */
/* otherwise it is between d(1) and d(2) */
/* This routine will be called by SLAED4 when necessary. In most cases, */
/* the root sought is the smallest in magnitude, though it might not be */
/* in some extremely rare situations. */
/* Arguments */
/* ========= */
/* KNITER (input) INTEGER */
/* Refer to SLAED4 for its significance. */
/* ORGATI (input) LOGICAL */
/* If ORGATI is true, the needed root is between d(2) and */
/* d(3); otherwise it is between d(1) and d(2). See */
/* SLAED4 for further details. */
/* RHO (input) REAL */
/* Refer to the equation f(x) above. */
/* D (input) REAL array, dimension (3) */
/* D satisfies d(1) < d(2) < d(3). */
/* Z (input) REAL array, dimension (3) */
/* Each of the elements in z must be positive. */
/* FINIT (input) REAL */
/* The value of f at 0. It is more accurate than the one */
/* evaluated inside this routine (if someone wants to do */
/* so). */
/* TAU (output) REAL */
/* The root of the equation f(x). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: if INFO = 1, failure to converge */
/* Further Details */
/* =============== */
/* 30/06/99: Based on contributions by */
/* Ren-Cang Li, Computer Science Division, University of California */
/* at Berkeley, USA */
/* 10/02/03: This version has a few statements commented out for thread safety */
/* (machine parameters are computed on each entry). SJH. */
/* 05/10/06: Modified from a new version of Ren-Cang Li, use */
/* Gragg-Thornton-Warner cubic convergent scheme for better stability. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--z__;
--d__;
/* Function Body */
*info = 0;
if (*orgati) {
lbd = d__[2];
ubd = d__[3];
} else {
lbd = d__[1];
ubd = d__[2];
}
if (*finit < 0.f) {
lbd = 0.f;
} else {
ubd = 0.f;
}
niter = 1;
*tau = 0.f;
if (*kniter == 2) {
if (*orgati) {
temp = (d__[3] - d__[2]) / 2.f;
c__ = *rho + z__[1] / (d__[1] - d__[2] - temp);
a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3];
b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2];
} else {
temp = (d__[1] - d__[2]) / 2.f;
c__ = *rho + z__[3] / (d__[3] - d__[2] - temp);
a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2];
b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1];
}
/* Computing MAX */
r__1 = dabs(a), r__2 = dabs(b), r__1 = max(r__1,r__2), r__2 = dabs(
c__);
temp = dmax(r__1,r__2);
a /= temp;
b /= temp;
c__ /= temp;
if (c__ == 0.f) {
*tau = b / a;
} else if (a <= 0.f) {
*tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / (
c__ * 2.f);
} else {
*tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
r__1))));
}
if (*tau < lbd || *tau > ubd) {
*tau = (lbd + ubd) / 2.f;
}
if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) {
*tau = 0.f;
} else {
temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau
* z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / (
d__[3] * (d__[3] - *tau));
if (temp <= 0.f) {
lbd = *tau;
} else {
ubd = *tau;
}
if (dabs(*finit) <= dabs(temp)) {
*tau = 0.f;
}
}
}
/* get machine parameters for possible scaling to avoid overflow */
/* modified by Sven: parameters SMALL1, SMINV1, SMALL2, */
/* SMINV2, EPS are not SAVEd anymore between one call to the */
/* others but recomputed at each call */
eps = slamch_("Epsilon");
base = slamch_("Base");
i__1 = (integer) (log(slamch_("SafMin")) / log(base) / 3.f);
small1 = pow_ri(&base, &i__1);
sminv1 = 1.f / small1;
small2 = small1 * small1;
sminv2 = sminv1 * sminv1;
/* Determine if scaling of inputs necessary to avoid overflow */
/* when computing 1/TEMP**3 */
if (*orgati) {
/* Computing MIN */
r__3 = (r__1 = d__[2] - *tau, dabs(r__1)), r__4 = (r__2 = d__[3] - *
tau, dabs(r__2));
temp = dmin(r__3,r__4);
} else {
/* Computing MIN */
r__3 = (r__1 = d__[1] - *tau, dabs(r__1)), r__4 = (r__2 = d__[2] - *
tau, dabs(r__2));
temp = dmin(r__3,r__4);
}
scale = FALSE_;
if (temp <= small1) {
scale = TRUE_;
if (temp <= small2) {
/* Scale up by power of radix nearest 1/SAFMIN**(2/3) */
sclfac = sminv2;
sclinv = small2;
} else {
/* Scale up by power of radix nearest 1/SAFMIN**(1/3) */
sclfac = sminv1;
sclinv = small1;
}
/* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) */
for (i__ = 1; i__ <= 3; ++i__) {
dscale[i__ - 1] = d__[i__] * sclfac;
zscale[i__ - 1] = z__[i__] * sclfac;
/* L10: */
}
*tau *= sclfac;
lbd *= sclfac;
ubd *= sclfac;
} else {
/* Copy D and Z to DSCALE and ZSCALE */
for (i__ = 1; i__ <= 3; ++i__) {
dscale[i__ - 1] = d__[i__];
zscale[i__ - 1] = z__[i__];
/* L20: */
}
}
fc = 0.f;
df = 0.f;
ddf = 0.f;
for (i__ = 1; i__ <= 3; ++i__) {
temp = 1.f / (dscale[i__ - 1] - *tau);
temp1 = zscale[i__ - 1] * temp;
temp2 = temp1 * temp;
temp3 = temp2 * temp;
fc += temp1 / dscale[i__ - 1];
df += temp2;
ddf += temp3;
/* L30: */
}
f = *finit + *tau * fc;
if (dabs(f) <= 0.f) {
goto L60;
}
if (f <= 0.f) {
lbd = *tau;
} else {
ubd = *tau;
}
/* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent */
/* scheme */
/* It is not hard to see that */
/* 1) Iterations will go up monotonically */
/* if FINIT < 0; */
/* 2) Iterations will go down monotonically */
/* if FINIT > 0. */
iter = niter + 1;
for (niter = iter; niter <= 40; ++niter) {
if (*orgati) {
temp1 = dscale[1] - *tau;
temp2 = dscale[2] - *tau;
} else {
temp1 = dscale[0] - *tau;
temp2 = dscale[1] - *tau;
}
a = (temp1 + temp2) * f - temp1 * temp2 * df;
b = temp1 * temp2 * f;
c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf;
/* Computing MAX */
r__1 = dabs(a), r__2 = dabs(b), r__1 = max(r__1,r__2), r__2 = dabs(
c__);
temp = dmax(r__1,r__2);
a /= temp;
b /= temp;
c__ /= temp;
if (c__ == 0.f) {
eta = b / a;
} else if (a <= 0.f) {
eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / (
c__ * 2.f);
} else {
eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
r__1))));
}
if (f * eta >= 0.f) {
eta = -f / df;
}
*tau += eta;
if (*tau < lbd || *tau > ubd) {
*tau = (lbd + ubd) / 2.f;
}
fc = 0.f;
erretm = 0.f;
df = 0.f;
ddf = 0.f;
for (i__ = 1; i__ <= 3; ++i__) {
temp = 1.f / (dscale[i__ - 1] - *tau);
temp1 = zscale[i__ - 1] * temp;
temp2 = temp1 * temp;
temp3 = temp2 * temp;
temp4 = temp1 / dscale[i__ - 1];
fc += temp4;
erretm += dabs(temp4);
df += temp2;
ddf += temp3;
/* L40: */
}
f = *finit + *tau * fc;
erretm = (dabs(*finit) + dabs(*tau) * erretm) * 8.f + dabs(*tau) * df;
if (dabs(f) <= eps * erretm) {
goto L60;
}
if (f <= 0.f) {
lbd = *tau;
} else {
ubd = *tau;
}
/* L50: */
}
*info = 1;
L60:
/* Undo scaling */
if (scale) {
*tau *= sclinv;
}
return 0;
/* End of SLAED6 */
} /* slaed6_ */
int cggbal_(char *job, int *n, complex *a, int *lda,
complex *b, int *ldb, int *ilo, int *ihi, float *lscale,
float *rscale, float *work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
float r__1, r__2, r__3;
/* Builtin functions */
double r_lg10(float *), r_imag(complex *), c_abs(complex *), r_sign(float *,
float *), pow_ri(float *, int *);
/* Local variables */
int i__, j, k, l, m;
float t;
int jc;
float ta, tb, tc;
int ir;
float ew;
int it, nr, ip1, jp1, lm1;
float cab, rab, ewc, cor, sum;
int nrp2, icab, lcab;
float beta, coef;
int irab, lrab;
float basl, cmax;
extern double sdot_(int *, float *, int *, float *, int *);
float coef2, coef5, gamma, alpha;
extern int lsame_(char *, char *);
extern int sscal_(int *, float *, float *, int *);
float sfmin;
extern int cswap_(int *, complex *, int *,
complex *, int *);
float sfmax;
int iflow, kount;
extern int saxpy_(int *, float *, float *, int *,
float *, int *);
float pgamma;
extern int icamax_(int *, complex *, int *);
extern double slamch_(char *);
extern int csscal_(int *, float *, complex *, int
*), xerbla_(char *, int *);
int lsfmin, lsfmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGGBAL balances a pair of general complex matrices (A,B). This */
/* involves, first, permuting A and B by similarity transformations to */
/* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */
/* elements on the diagonal; and second, applying a diagonal similarity */
/* transformation to rows and columns ILO to IHI to make the rows */
/* and columns as close in norm as possible. Both steps are optional. */
/* Balancing may reduce the 1-norm of the matrices, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors in the */
/* generalized eigenvalue problem A*x = lambda*B*x. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A and B: */
/* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */
/* and RSCALE(I) = 1.0 for i=1,...,N; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the input matrix A. */
/* On exit, A is overwritten by the balanced matrix. */
/* If JOB = 'N', A is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB,N) */
/* On entry, the input matrix B. */
/* On exit, B is overwritten by the balanced matrix. */
/* If JOB = 'N', B is not referenced. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to ints such that on exit */
/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
/* LSCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the left side of A and B. If P(j) is the index of the */
/* row interchanged with row j, and D(j) is the scaling factor */
/* applied to row j, then */
/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */
/* = D(j) for J = ILO,...,IHI */
/* = P(j) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* RSCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* to the right side of A and B. If P(j) is the index of the */
/* column interchanged with column j, and D(j) is the scaling */
/* factor applied to column j, then */
/* RSCALE(j) = P(j) for J = 1,...,ILO-1 */
/* = D(j) for J = ILO,...,IHI */
/* = P(j) for J = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* WORK (workspace) REAL array, dimension (lwork) */
/* lwork must be at least MAX(1,6*N) when JOB = 'S' or 'B', and */
/* at least 1 when JOB = 'N' or 'P'. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* See R.C. WARD, Balancing the generalized eigenvalue problem, */
/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--lscale;
--rscale;
--work;
/* Function Body */
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*n)) {
*info = -4;
} else if (*ldb < MAX(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGBAL", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*ilo = 1;
*ihi = *n;
return 0;
}
if (*n == 1) {
*ilo = 1;
*ihi = *n;
lscale[1] = 1.f;
rscale[1] = 1.f;
return 0;
}
if (lsame_(job, "N")) {
*ilo = 1;
*ihi = *n;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
lscale[i__] = 1.f;
rscale[i__] = 1.f;
/* L10: */
}
return 0;
}
k = 1;
l = *n;
if (lsame_(job, "S")) {
goto L190;
}
goto L30;
/* Permute the matrices A and B to isolate the eigenvalues. */
/* Find row with one nonzero in columns 1 through L */
L20:
l = lm1;
if (l != 1) {
goto L30;
}
rscale[1] = 1.f;
lscale[1] = 1.f;
goto L190;
L30:
lm1 = l - 1;
for (i__ = l; i__ >= 1; --i__) {
i__1 = lm1;
for (j = 1; j <= i__1; ++j) {
jp1 = j + 1;
i__2 = i__ + j * a_dim1;
i__3 = i__ + j * b_dim1;
if (a[i__2].r != 0.f || a[i__2].i != 0.f || (b[i__3].r != 0.f ||
b[i__3].i != 0.f)) {
goto L50;
}
/* L40: */
}
j = l;
goto L70;
L50:
i__1 = l;
for (j = jp1; j <= i__1; ++j) {
i__2 = i__ + j * a_dim1;
i__3 = i__ + j * b_dim1;
if (a[i__2].r != 0.f || a[i__2].i != 0.f || (b[i__3].r != 0.f ||
b[i__3].i != 0.f)) {
goto L80;
}
/* L60: */
}
j = jp1 - 1;
L70:
m = l;
iflow = 1;
goto L160;
L80:
;
}
goto L100;
/* Find column with one nonzero in rows K through N */
L90:
++k;
L100:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = lm1;
for (i__ = k; i__ <= i__2; ++i__) {
ip1 = i__ + 1;
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * b_dim1;
if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != 0.f ||
b[i__4].i != 0.f)) {
goto L120;
}
/* L110: */
}
i__ = l;
goto L140;
L120:
i__2 = l;
for (i__ = ip1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
i__4 = i__ + j * b_dim1;
if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != 0.f ||
b[i__4].i != 0.f)) {
goto L150;
}
/* L130: */
}
i__ = ip1 - 1;
L140:
m = k;
iflow = 2;
goto L160;
L150:
;
}
goto L190;
/* Permute rows M and I */
L160:
lscale[m] = (float) i__;
if (i__ == m) {
goto L170;
}
i__1 = *n - k + 1;
cswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
i__1 = *n - k + 1;
cswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
/* Permute columns M and J */
L170:
rscale[m] = (float) j;
if (j == m) {
goto L180;
}
cswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
cswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1);
L180:
switch (iflow) {
case 1: goto L20;
case 2: goto L90;
}
L190:
*ilo = k;
*ihi = l;
if (lsame_(job, "P")) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
lscale[i__] = 1.f;
rscale[i__] = 1.f;
/* L195: */
}
return 0;
}
if (*ilo == *ihi) {
return 0;
}
/* Balance the submatrix in rows ILO to IHI. */
nr = *ihi - *ilo + 1;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
rscale[i__] = 0.f;
lscale[i__] = 0.f;
work[i__] = 0.f;
work[i__ + *n] = 0.f;
work[i__ + (*n << 1)] = 0.f;
work[i__ + *n * 3] = 0.f;
work[i__ + (*n << 2)] = 0.f;
work[i__ + *n * 5] = 0.f;
/* L200: */
}
/* Compute right side vector in resulting linear equations */
basl = r_lg10(&c_b36);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
ta = 0.f;
goto L210;
}
i__3 = i__ + j * a_dim1;
r__3 = (r__1 = a[i__3].r, ABS(r__1)) + (r__2 = r_imag(&a[i__ + j
* a_dim1]), ABS(r__2));
ta = r_lg10(&r__3) / basl;
L210:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
tb = 0.f;
goto L220;
}
i__3 = i__ + j * b_dim1;
r__3 = (r__1 = b[i__3].r, ABS(r__1)) + (r__2 = r_imag(&b[i__ + j
* b_dim1]), ABS(r__2));
tb = r_lg10(&r__3) / basl;
L220:
work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
work[j + *n * 5] = work[j + *n * 5] - ta - tb;
/* L230: */
}
/* L240: */
}
coef = 1.f / (float) (nr << 1);
coef2 = coef * coef;
coef5 = coef2 * .5f;
nrp2 = nr + 2;
beta = 0.f;
it = 1;
/* Start generalized conjugate gradient iteration */
L250:
gamma = sdot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
, &c__1) + sdot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
n * 5], &c__1);
ew = 0.f;
ewc = 0.f;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
ew += work[i__ + (*n << 2)];
ewc += work[i__ + *n * 5];
/* L260: */
}
/* Computing 2nd power */
r__1 = ew;
/* Computing 2nd power */
r__2 = ewc;
/* Computing 2nd power */
r__3 = ew - ewc;
gamma = coef * gamma - coef2 * (r__1 * r__1 + r__2 * r__2) - coef5 * (
r__3 * r__3);
if (gamma == 0.f) {
goto L350;
}
if (it != 1) {
beta = gamma / pgamma;
}
t = coef5 * (ewc - ew * 3.f);
tc = coef5 * (ew - ewc * 3.f);
sscal_(&nr, &beta, &work[*ilo], &c__1);
sscal_(&nr, &beta, &work[*ilo + *n], &c__1);
saxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
c__1);
saxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
work[i__] += tc;
work[i__ + *n] += t;
/* L270: */
}
/* Apply matrix to vector */
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
kount = 0;
sum = 0.f;
i__2 = *ihi;
for (j = *ilo; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
goto L280;
}
++kount;
sum += work[j];
L280:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
goto L290;
}
++kount;
sum += work[j];
L290:
;
}
work[i__ + (*n << 1)] = (float) kount * work[i__ + *n] + sum;
/* L300: */
}
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
kount = 0;
sum = 0.f;
i__2 = *ihi;
for (i__ = *ilo; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
goto L310;
}
++kount;
sum += work[i__ + *n];
L310:
i__3 = i__ + j * b_dim1;
if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
goto L320;
}
++kount;
sum += work[i__ + *n];
L320:
;
}
work[j + *n * 3] = (float) kount * work[j] + sum;
/* L330: */
}
sum = sdot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ sdot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
alpha = gamma / sum;
/* Determine correction to current iteration */
cmax = 0.f;
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
cor = alpha * work[i__ + *n];
if (ABS(cor) > cmax) {
cmax = ABS(cor);
}
lscale[i__] += cor;
cor = alpha * work[i__];
if (ABS(cor) > cmax) {
cmax = ABS(cor);
}
rscale[i__] += cor;
/* L340: */
}
if (cmax < .5f) {
goto L350;
}
r__1 = -alpha;
saxpy_(&nr, &r__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
, &c__1);
r__1 = -alpha;
saxpy_(&nr, &r__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], &
c__1);
pgamma = gamma;
++it;
if (it <= nrp2) {
goto L250;
}
/* End generalized conjugate gradient iteration */
L350:
sfmin = slamch_("S");
sfmax = 1.f / sfmin;
lsfmin = (int) (r_lg10(&sfmin) / basl + 1.f);
lsfmax = (int) (r_lg10(&sfmax) / basl);
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
irab = icamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
rab = c_abs(&a[i__ + (irab + *ilo - 1) * a_dim1]);
i__2 = *n - *ilo + 1;
irab = icamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
/* Computing MAX */
r__1 = rab, r__2 = c_abs(&b[i__ + (irab + *ilo - 1) * b_dim1]);
rab = MAX(r__1,r__2);
r__1 = rab + sfmin;
lrab = (int) (r_lg10(&r__1) / basl + 1.f);
ir = lscale[i__] + r_sign(&c_b72, &lscale[i__]);
/* Computing MIN */
i__2 = MAX(ir,lsfmin), i__2 = MIN(i__2,lsfmax), i__3 = lsfmax - lrab;
ir = MIN(i__2,i__3);
lscale[i__] = pow_ri(&c_b36, &ir);
icab = icamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
cab = c_abs(&a[icab + i__ * a_dim1]);
icab = icamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
/* Computing MAX */
r__1 = cab, r__2 = c_abs(&b[icab + i__ * b_dim1]);
cab = MAX(r__1,r__2);
r__1 = cab + sfmin;
lcab = (int) (r_lg10(&r__1) / basl + 1.f);
jc = rscale[i__] + r_sign(&c_b72, &rscale[i__]);
/* Computing MIN */
i__2 = MAX(jc,lsfmin), i__2 = MIN(i__2,lsfmax), i__3 = lsfmax - lcab;
jc = MIN(i__2,i__3);
rscale[i__] = pow_ri(&c_b36, &jc);
/* L360: */
}
/* Row scaling of matrices A and B */
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
i__2 = *n - *ilo + 1;
csscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
i__2 = *n - *ilo + 1;
csscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb);
/* L370: */
}
/* Column scaling of matrices A and B */
i__1 = *ihi;
for (j = *ilo; j <= i__1; ++j) {
csscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
csscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
/* L380: */
}
return 0;
/* End of CGGBAL */
} /* cggbal_ */
/* Subroutine */ int cgeequb_(integer *m, integer *n, complex *a, integer *
lda, real *r__, real *c__, real *rowcnd, real *colcnd, real *amax,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1, r__2, r__3, r__4;
/* Builtin functions */
double log(doublereal), r_imag(complex *), pow_ri(real *, integer *);
/* Local variables */
integer i__, j;
real radix, rcmin, rcmax;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum, logrdx, smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGEEQUB computes row and column scalings intended to equilibrate an */
/* M-by-N matrix A and reduce its condition number. R returns the row */
/* scale factors and C the column scale factors, chosen to try to make */
/* the largest element in each row and column of the matrix B with */
/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */
/* the radix. */
/* R(i) and C(j) are restricted to be a power of the radix between */
/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */
/* of these scaling factors is not guaranteed to reduce the condition */
/* number of A but works well in practice. */
/* This routine differs from CGEEQU by restricting the scaling factors */
/* to a power of the radix. Baring over- and underflow, scaling by */
/* these factors introduces no additional rounding errors. However, the */
/* scaled entries' magnitured are no longer approximately 1 but lie */
/* between sqrt(radix) and 1/sqrt(radix). */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The M-by-N matrix whose equilibration factors are */
/* to be computed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* R (output) REAL array, dimension (M) */
/* If INFO = 0 or INFO > M, R contains the row scale factors */
/* for A. */
/* C (output) REAL array, dimension (N) */
/* If INFO = 0, C contains the column scale factors for A. */
/* ROWCND (output) REAL */
/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
/* AMAX is neither too large nor too small, it is not worth */
/* scaling by R. */
/* COLCND (output) REAL */
/* If INFO = 0, COLCND contains the ratio of the smallest */
/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
/* worth scaling by C. */
/* AMAX (output) REAL */
/* Absolute value of largest matrix element. If AMAX is very */
/* close to overflow or very close to underflow, the matrix */
/* should be scaled. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= M: the i-th row of A is exactly zero */
/* > M: the (i-M)-th column of A is exactly zero */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--r__;
--c__;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEEQUB", &i__1);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
*rowcnd = 1.f;
*colcnd = 1.f;
*amax = 0.f;
return 0;
}
/* Get machine constants. Assume SMLNUM is a power of the radix. */
smlnum = slamch_("S");
bignum = 1.f / smlnum;
radix = slamch_("B");
logrdx = log(radix);
/* Compute row scale factors. */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
r__[i__] = 0.f;
/* L10: */
}
/* Find the maximum element in each row. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = r__[i__], r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
r__[i__] = dmax(r__3,r__4);
/* L20: */
}
/* L30: */
}
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
if (r__[i__] > 0.f) {
i__2 = (integer) (log(r__[i__]) / logrdx);
r__[i__] = pow_ri(&radix, &i__2);
}
}
/* Find the maximum and minimum scale factors. */
rcmin = bignum;
rcmax = 0.f;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = rcmax, r__2 = r__[i__];
rcmax = dmax(r__1,r__2);
/* Computing MIN */
r__1 = rcmin, r__2 = r__[i__];
rcmin = dmin(r__1,r__2);
/* L40: */
}
*amax = rcmax;
if (rcmin == 0.f) {
/* Find the first zero scale factor and return an error code. */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
if (r__[i__] == 0.f) {
*info = i__;
return 0;
}
/* L50: */
}
} else {
/* Invert the scale factors. */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MIN */
/* Computing MAX */
r__2 = r__[i__];
r__1 = dmax(r__2,smlnum);
r__[i__] = 1.f / dmin(r__1,bignum);
/* L60: */
}
/* Compute ROWCND = min(R(I)) / max(R(I)). */
*rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
}
/* Compute column scale factors. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
c__[j] = 0.f;
/* L70: */
}
/* Find the maximum element in each column, */
/* assuming the row scaling computed above. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * a_dim1;
r__3 = c__[j], r__4 = ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), dabs(r__2))) * r__[i__];
c__[j] = dmax(r__3,r__4);
/* L80: */
}
if (c__[j] > 0.f) {
i__2 = (integer) (log(c__[j]) / logrdx);
c__[j] = pow_ri(&radix, &i__2);
}
/* L90: */
}
/* Find the maximum and minimum scale factors. */
rcmin = bignum;
rcmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = rcmin, r__2 = c__[j];
rcmin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = rcmax, r__2 = c__[j];
rcmax = dmax(r__1,r__2);
/* L100: */
}
if (rcmin == 0.f) {
/* Find the first zero scale factor and return an error code. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (c__[j] == 0.f) {
*info = *m + j;
return 0;
}
/* L110: */
}
} else {
/* Invert the scale factors. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
/* Computing MAX */
r__2 = c__[j];
r__1 = dmax(r__2,smlnum);
c__[j] = 1.f / dmin(r__1,bignum);
/* L120: */
}
/* Compute COLCND = min(C(J)) / max(C(J)). */
*colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
}
return 0;
/* End of CGEEQUB */
} /* cgeequb_ */
/*< REAL FUNCTION SLAMCH( CMACH ) >*/
doublereal slamch_(char *cmach, ftnlen cmach_len)
{
/* Initialized data */
static logical first = TRUE_; /* runtime-initialized constant */
/* System generated locals */
integer i__1;
real ret_val;
/* Builtin functions */
double pow_ri(real *, integer *);
/* Local variables */
static real t; /* runtime-initialized constant */
integer it;
static real rnd, eps, base; /* runtime-initialized constant */
integer beta;
static real emin, prec, emax; /* runtime-initialized constant */
integer imin, imax;
logical lrnd;
static real rmin, rmax; /* runtime-initialized constant */
real rmach=0;
extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
real small;
static real sfmin; /* runtime-initialized constant */
extern /* Subroutine */ int slamc2_(integer *, integer *, logical *, real
*, integer *, real *, integer *, real *);
(void)cmach_len;
/* -- LAPACK auxiliary routine (version 1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/*< CHARACTER CMACH >*/
/* .. */
/* Purpose */
/* ======= */
/* SLAMCH determines single precision machine parameters. */
/* Arguments */
/* ========= */
/* CMACH (input) CHARACTER*1 */
/* Specifies the value to be returned by SLAMCH: */
/* = 'E' or 'e', SLAMCH := eps */
/* = 'S' or 's , SLAMCH := sfmin */
/* = 'B' or 'b', SLAMCH := base */
/* = 'P' or 'p', SLAMCH := eps*base */
/* = 'N' or 'n', SLAMCH := t */
/* = 'R' or 'r', SLAMCH := rnd */
/* = 'M' or 'm', SLAMCH := emin */
/* = 'U' or 'u', SLAMCH := rmin */
/* = 'L' or 'l', SLAMCH := emax */
/* = 'O' or 'o', SLAMCH := rmax */
/* where */
/* eps = relative machine precision */
/* sfmin = safe minimum, such that 1/sfmin does not overflow */
/* base = base of the machine */
/* prec = eps*base */
/* t = number of (base) digits in the mantissa */
/* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise */
/* emin = minimum exponent before (gradual) underflow */
/* rmin = underflow threshold - base**(emin-1) */
/* emax = largest exponent before overflow */
/* rmax = overflow threshold - (base**emax)*(1-eps) */
/* ===================================================================== */
/* .. Parameters .. */
/*< REAL ONE, ZERO >*/
/*< PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< LOGICAL FIRST, LRND >*/
/*< INTEGER BETA, IMAX, IMIN, IT >*/
/*< >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< EXTERNAL LSAME >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL SLAMC2 >*/
/* .. */
/* .. Save statement .. */
/*< >*/
/* .. */
/* .. Data statements .. */
/*< DATA FIRST / .TRUE. / >*/
/* .. */
/* .. Executable Statements .. */
/*< IF( FIRST ) THEN >*/
if (first) {
/*< FIRST = .FALSE. >*/
first = FALSE_;
/*< CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) >*/
slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
/*< BASE = BETA >*/
base = (real) beta;
/*< T = IT >*/
t = (real) it;
/*< IF( LRND ) THEN >*/
if (lrnd) {
/*< RND = ONE >*/
rnd = (float)1.;
/*< EPS = ( BASE**( 1-IT ) ) / 2 >*/
i__1 = 1 - it;
eps = pow_ri(&base, &i__1) / 2;
/*< ELSE >*/
} else {
/*< RND = ZERO >*/
rnd = (float)0.;
/*< EPS = BASE**( 1-IT ) >*/
i__1 = 1 - it;
eps = pow_ri(&base, &i__1);
/*< END IF >*/
}
/*< PREC = EPS*BASE >*/
prec = eps * base;
/*< EMIN = IMIN >*/
emin = (real) imin;
/*< EMAX = IMAX >*/
emax = (real) imax;
/*< SFMIN = RMIN >*/
sfmin = rmin;
/*< SMALL = ONE / RMAX >*/
small = (float)1. / rmax;
/*< IF( SMALL.GE.SFMIN ) THEN >*/
if (small >= sfmin) {
/* Use SMALL plus a bit, to avoid the possibility of rounding */
/* causing overflow when computing 1/sfmin. */
/*< SFMIN = SMALL*( ONE+EPS ) >*/
sfmin = small * (eps + (float)1.);
/*< END IF >*/
}
/*< END IF >*/
}
/*< IF( LSAME( CMACH, 'E' ) ) THEN >*/
if (lsame_(cmach, "E", (ftnlen)1, (ftnlen)1)) {
/*< RMACH = EPS >*/
rmach = eps;
/*< ELSE IF( LSAME( CMACH, 'S' ) ) THEN >*/
} else if (lsame_(cmach, "S", (ftnlen)1, (ftnlen)1)) {
/*< RMACH = SFMIN >*/
rmach = sfmin;
/*< ELSE IF( LSAME( CMACH, 'B' ) ) THEN >*/
} else if (lsame_(cmach, "B", (ftnlen)1, (ftnlen)1)) {
/*< RMACH = BASE >*/
rmach = base;
/*< ELSE IF( LSAME( CMACH, 'P' ) ) THEN >*/
} else if (lsame_(cmach, "P", (ftnlen)1, (ftnlen)1)) {
/*< RMACH = PREC >*/
rmach = prec;
/*< ELSE IF( LSAME( CMACH, 'N' ) ) THEN >*/
} else if (lsame_(cmach, "N", (ftnlen)1, (ftnlen)1)) {
/*< RMACH = T >*/
rmach = t;
/*< ELSE IF( LSAME( CMACH, 'R' ) ) THEN >*/
} else if (lsame_(cmach, "R", (ftnlen)1, (ftnlen)1)) {
/*< RMACH = RND >*/
rmach = rnd;
/*< ELSE IF( LSAME( CMACH, 'M' ) ) THEN >*/
} else if (lsame_(cmach, "M", (ftnlen)1, (ftnlen)1)) {
/*< RMACH = EMIN >*/
rmach = emin;
/*< ELSE IF( LSAME( CMACH, 'U' ) ) THEN >*/
} else if (lsame_(cmach, "U", (ftnlen)1, (ftnlen)1)) {
/*< RMACH = RMIN >*/
rmach = rmin;
/*< ELSE IF( LSAME( CMACH, 'L' ) ) THEN >*/
} else if (lsame_(cmach, "L", (ftnlen)1, (ftnlen)1)) {
/*< RMACH = EMAX >*/
rmach = emax;
/*< ELSE IF( LSAME( CMACH, 'O' ) ) THEN >*/
} else if (lsame_(cmach, "O", (ftnlen)1, (ftnlen)1)) {
/*< RMACH = RMAX >*/
rmach = rmax;
/*< END IF >*/
}
/*< SLAMCH = RMACH >*/
ret_val = rmach;
/*< RETURN >*/
return ret_val;
/* End of SLAMCH */
/*< END >*/
} /* slamch_ */
/* Subroutine */ int slartg_(real *f, real *g, real *cs, real *sn, real *r__)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double log(doublereal), pow_ri(real *, integer *), sqrt(doublereal);
/* Local variables */
integer i__;
real f1, g1, eps, scale;
integer count;
real safmn2, safmx2;
extern doublereal slamch_(char *);
real safmin;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLARTG generate a plane rotation so that */
/* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. */
/* [ -SN CS ] [ G ] [ 0 ] */
/* This is a slower, more accurate version of the BLAS1 routine SROTG, */
/* with the following other differences: */
/* F and G are unchanged on return. */
/* If G=0, then CS=1 and SN=0. */
/* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any */
/* floating point operations (saves work in SBDSQR when */
/* there are zeros on the diagonal). */
/* If F exceeds G in magnitude, CS will be positive. */
/* Arguments */
/* ========= */
/* F (input) REAL */
/* The first component of vector to be rotated. */
/* G (input) REAL */
/* The second component of vector to be rotated. */
/* CS (output) REAL */
/* The cosine of the rotation. */
/* SN (output) REAL */
/* The sine of the rotation. */
/* R (output) REAL */
/* The nonzero component of the rotated vector. */
/* This version has a few statements commented out for thread safety */
/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* LOGICAL FIRST */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Save statement .. */
/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
/* .. */
/* .. Data statements .. */
/* DATA FIRST / .TRUE. / */
/* .. */
/* .. Executable Statements .. */
/* IF( FIRST ) THEN */
safmin = slamch_("S");
eps = slamch_("E");
r__1 = slamch_("B");
i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f);
safmn2 = pow_ri(&r__1, &i__1);
safmx2 = 1.f / safmn2;
/* FIRST = .FALSE. */
/* END IF */
if (*g == 0.f) {
*cs = 1.f;
*sn = 0.f;
*r__ = *f;
} else if (*f == 0.f) {
*cs = 0.f;
*sn = 1.f;
*r__ = *g;
} else {
f1 = *f;
g1 = *g;
/* Computing MAX */
r__1 = dabs(f1), r__2 = dabs(g1);
scale = dmax(r__1,r__2);
if (scale >= safmx2) {
count = 0;
L10:
++count;
f1 *= safmn2;
g1 *= safmn2;
/* Computing MAX */
r__1 = dabs(f1), r__2 = dabs(g1);
scale = dmax(r__1,r__2);
if (scale >= safmx2) {
goto L10;
}
/* Computing 2nd power */
r__1 = f1;
/* Computing 2nd power */
r__2 = g1;
*r__ = sqrt(r__1 * r__1 + r__2 * r__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmx2;
/* L20: */
}
} else if (scale <= safmn2) {
count = 0;
L30:
++count;
f1 *= safmx2;
g1 *= safmx2;
/* Computing MAX */
r__1 = dabs(f1), r__2 = dabs(g1);
scale = dmax(r__1,r__2);
if (scale <= safmn2) {
goto L30;
}
/* Computing 2nd power */
r__1 = f1;
/* Computing 2nd power */
r__2 = g1;
*r__ = sqrt(r__1 * r__1 + r__2 * r__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmn2;
/* L40: */
}
} else {
/* Computing 2nd power */
r__1 = f1;
/* Computing 2nd power */
r__2 = g1;
*r__ = sqrt(r__1 * r__1 + r__2 * r__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
}
if (dabs(*f) > dabs(*g) && *cs < 0.f) {
*cs = -(*cs);
*sn = -(*sn);
*r__ = -(*r__);
}
}
return 0;
/* End of SLARTG */
} /* slartg_ */
/* Subroutine */ int slartg_(real *f, real *g, real *cs, real *sn, real *r)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SLARTG generate a plane rotation so that
[ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.
[ -SN CS ] [ G ] [ 0 ]
This is a slower, more accurate version of the BLAS1 routine SROTG,
with the following other differences:
F and G are unchanged on return.
If G=0, then CS=1 and SN=0.
If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
floating point operations (saves work in SBDSQR when
there are zeros on the diagonal).
If F exceeds G in magnitude, CS will be positive.
Arguments
=========
F (input) REAL
The first component of vector to be rotated.
G (input) REAL
The second component of vector to be rotated.
CS (output) REAL
The cosine of the rotation.
SN (output) REAL
The sine of the rotation.
R (output) REAL
The nonzero component of the rotated vector.
=====================================================================
*/
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double log(doublereal), pow_ri(real *, integer *), sqrt(doublereal);
/* Local variables */
static integer i;
static real scale;
static integer count;
static real f1, g1, safmn2, safmx2;
extern doublereal slamch_(char *);
static real safmin, eps;
if (first) {
first = FALSE_;
safmin = slamch_("S");
eps = slamch_("E");
r__1 = slamch_("B");
i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f);
safmn2 = pow_ri(&r__1, &i__1);
safmx2 = 1.f / safmn2;
}
if (*g == 0.f) {
*cs = 1.f;
*sn = 0.f;
*r = *f;
} else if (*f == 0.f) {
*cs = 0.f;
*sn = 1.f;
*r = *g;
} else {
f1 = *f;
g1 = *g;
/* Computing MAX */
r__1 = dabs(f1), r__2 = dabs(g1);
scale = dmax(r__1,r__2);
if (scale >= safmx2) {
count = 0;
L10:
++count;
f1 *= safmn2;
g1 *= safmn2;
/* Computing MAX */
r__1 = dabs(f1), r__2 = dabs(g1);
scale = dmax(r__1,r__2);
if (scale >= safmx2) {
goto L10;
}
/* Computing 2nd power */
r__1 = f1;
/* Computing 2nd power */
r__2 = g1;
*r = sqrt(r__1 * r__1 + r__2 * r__2);
*cs = f1 / *r;
*sn = g1 / *r;
i__1 = count;
for (i = 1; i <= count; ++i) {
*r *= safmx2;
/* L20: */
}
} else if (scale <= safmn2) {
count = 0;
L30:
++count;
f1 *= safmx2;
g1 *= safmx2;
/* Computing MAX */
r__1 = dabs(f1), r__2 = dabs(g1);
scale = dmax(r__1,r__2);
if (scale <= safmn2) {
goto L30;
}
/* Computing 2nd power */
r__1 = f1;
/* Computing 2nd power */
r__2 = g1;
*r = sqrt(r__1 * r__1 + r__2 * r__2);
*cs = f1 / *r;
*sn = g1 / *r;
i__1 = count;
for (i = 1; i <= count; ++i) {
*r *= safmn2;
/* L40: */
}
} else {
/* Computing 2nd power */
r__1 = f1;
/* Computing 2nd power */
r__2 = g1;
*r = sqrt(r__1 * r__1 + r__2 * r__2);
*cs = f1 / *r;
*sn = g1 / *r;
}
if (dabs(*f) > dabs(*g) && *cs < 0.f) {
*cs = -(doublereal)(*cs);
*sn = -(doublereal)(*sn);
*r = -(doublereal)(*r);
}
}
return 0;
/* End of SLARTG */
} /* slartg_ */
/* DECK RC6J */
/* Subroutine */ int rc6j_(real *l2, real *l3, real *l4, real *l5, real *l6,
real *l1min, real *l1max, real *sixcof, integer *ndim, integer *ier)
{
/* Initialized data */
static real zero = 0.f;
static real eps = .01f;
static real one = 1.f;
static real two = 2.f;
static real three = 3.f;
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4;
/* Local variables */
static integer i__, n;
static real x, y, a1, a2, c1, c2, l1, x1, x2, x3, y1, y2, y3, dv, a1s,
a2s, sum1, sum2, huge__;
static integer nfin, nlim;
static real tiny, c1old, sign1, sign2, denom;
static integer index;
static real cnorm, ratio;
static integer lstep;
extern doublereal r1mach_(integer *);
static integer nfinp1, nfinp2, nfinp3, nstep2;
static real oldfac, newfac, sumbac, srhuge, thresh;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static real sumfor, sumuni, srtiny;
/* ***BEGIN PROLOGUE RC6J */
/* ***PURPOSE Evaluate the 6j symbol h(L1) = {L1 L2 L3} */
/* {L4 L5 L6} */
/* for all allowed values of L1, the other parameters */
/* being held fixed. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C19 */
/* ***TYPE SINGLE PRECISION (RC6J-S, DRC6J-D) */
/* ***KEYWORDS 6J COEFFICIENTS, 6J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS, */
/* RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, */
/* WIGNER COEFFICIENTS */
/* ***AUTHOR Gordon, R. G., Harvard University */
/* Schulten, K., Max Planck Institute */
/* ***DESCRIPTION */
/* *Usage: */
/* REAL L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM) */
/* INTEGER NDIM, IER */
/* CALL RC6J(L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, IER) */
/* *Arguments: */
/* L2 :IN Parameter in 6j symbol. */
/* L3 :IN Parameter in 6j symbol. */
/* L4 :IN Parameter in 6j symbol. */
/* L5 :IN Parameter in 6j symbol. */
/* L6 :IN Parameter in 6j symbol. */
/* L1MIN :OUT Smallest allowable L1 in 6j symbol. */
/* L1MAX :OUT Largest allowable L1 in 6j symbol. */
/* SIXCOF :OUT Set of 6j coefficients generated by evaluating the */
/* 6j symbol for all allowed values of L1. SIXCOF(I) */
/* will contain h(L1MIN+I-1), I=1,2,...,L1MAX-L1MIN+1. */
/* NDIM :IN Declared length of SIXCOF in calling program. */
/* IER :OUT Error flag. */
/* IER=0 No errors. */
/* IER=1 L2+L3+L5+L6 or L4+L2+L6 not an integer. */
/* IER=2 L4, L2, L6 triangular condition not satisfied. */
/* IER=3 L4, L5, L3 triangular condition not satisfied. */
/* IER=4 L1MAX-L1MIN not an integer. */
/* IER=5 L1MAX less than L1MIN. */
/* IER=6 NDIM less than L1MAX-L1MIN+1. */
/* *Description: */
/* The definition and properties of 6j symbols can be found, for */
/* example, in Appendix C of Volume II of A. Messiah. Although the */
/* parameters of the vector addition coefficients satisfy certain */
/* conventional restrictions, the restriction that they be non-negative */
/* integers or non-negative integers plus 1/2 is not imposed on input */
/* to this subroutine. The restrictions imposed are */
/* 1. L2+L3+L5+L6 and L2+L4+L6 must be integers; */
/* 2. ABS(L2-L4).LE.L6.LE.L2+L4 must be satisfied; */
/* 3. ABS(L4-L5).LE.L3.LE.L4+L5 must be satisfied; */
/* 4. L1MAX-L1MIN must be a non-negative integer, where */
/* L1MAX=MIN(L2+L3,L5+L6) and L1MIN=MAX(ABS(L2-L3),ABS(L5-L6)). */
/* If all the conventional restrictions are satisfied, then these */
/* restrictions are met. Conversely, if input to this subroutine meets */
/* all of these restrictions and the conventional restriction stated */
/* above, then all the conventional restrictions are satisfied. */
/* The user should be cautious in using input parameters that do */
/* not satisfy the conventional restrictions. For example, the */
/* the subroutine produces values of */
/* h(L1) = { L1 2/3 1 } */
/* {2/3 2/3 2/3} */
/* for L1=1/3 and 4/3 but none of the symmetry properties of the 6j */
/* symbol, set forth on pages 1063 and 1064 of Messiah, is satisfied. */
/* The subroutine generates h(L1MIN), h(L1MIN+1), ..., h(L1MAX) */
/* where L1MIN and L1MAX are defined above. The sequence h(L1) is */
/* generated by a three-term recurrence algorithm with scaling to */
/* control overflow. Both backward and forward recurrence are used to */
/* maintain numerical stability. The two recurrence sequences are */
/* matched at an interior point and are normalized from the unitary */
/* property of 6j coefficients and Wigner's phase convention. */
/* The algorithm is suited to applications in which large quantum */
/* numbers arise, such as in molecular dynamics. */
/* ***REFERENCES 1. Messiah, Albert., Quantum Mechanics, Volume II, */
/* North-Holland Publishing Company, 1963. */
/* 2. Schulten, Klaus and Gordon, Roy G., Exact recursive */
/* evaluation of 3j and 6j coefficients for quantum- */
/* mechanical coupling of angular momenta, J Math */
/* Phys, v 16, no. 10, October 1975, pp. 1961-1970. */
/* 3. Schulten, Klaus and Gordon, Roy G., Semiclassical */
/* approximations to 3j and 6j coefficients for */
/* quantum-mechanical coupling of angular momenta, */
/* J Math Phys, v 16, no. 10, October 1975, */
/* pp. 1971-1988. */
/* 4. Schulten, Klaus and Gordon, Roy G., Recursive */
/* evaluation of 3j and 6j coefficients, Computer */
/* Phys Comm, v 11, 1976, pp. 269-278. */
/* ***ROUTINES CALLED R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 750101 DATE WRITTEN */
/* 880515 SLATEC prologue added by G. C. Nielson, NBS; parameters */
/* HUGE and TINY revised to depend on R1MACH. */
/* 891229 Prologue description rewritten; other prologue sections */
/* revised; LMATCH (location of match point for recurrences) */
/* removed from argument list; argument IER changed to serve */
/* only as an error flag (previously, in cases without error, */
/* it returned the number of scalings); number of error codes */
/* increased to provide more precise error information; */
/* program comments revised; SLATEC error handler calls */
/* introduced to enable printing of error messages to meet */
/* SLATEC standards. These changes were done by D. W. Lozier, */
/* M. A. McClain and J. M. Smith of the National Institute */
/* of Standards and Technology, formerly NBS. */
/* 910415 Mixed type expressions eliminated; variable C1 initialized; */
/* description of SIXCOF expanded. These changes were done by */
/* D. W. Lozier. */
/* ***END PROLOGUE RC6J */
/* Parameter adjustments */
--sixcof;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT RC6J */
*ier = 0;
/* HUGE is the square root of one twentieth of the largest floating */
/* point number, approximately. */
huge__ = sqrt(r1mach_(&c__2) / 20.f);
srhuge = sqrt(huge__);
tiny = 1.f / huge__;
srtiny = 1.f / srhuge;
/* LMATCH = ZERO */
/* Check error conditions 1, 2, and 3. */
r__1 = *l2 + *l3 + *l5 + *l6 + eps;
r__2 = *l4 + *l2 + *l6 + eps;
if (r_mod(&r__1, &one) >= eps + eps || r_mod(&r__2, &one) >= eps + eps) {
*ier = 1;
xermsg_("SLATEC", "RC6J", "L2+L3+L5+L6 or L4+L2+L6 not integer.", ier,
&c__1, (ftnlen)6, (ftnlen)4, (ftnlen)36);
return 0;
} else if (*l4 + *l2 - *l6 < zero || *l4 - *l2 + *l6 < zero || -(*l4) + *
l2 + *l6 < zero) {
*ier = 2;
xermsg_("SLATEC", "RC6J", "L4, L2, L6 triangular condition not satis"
"fied.", ier, &c__1, (ftnlen)6, (ftnlen)4, (ftnlen)46);
return 0;
} else if (*l4 - *l5 + *l3 < zero || *l4 + *l5 - *l3 < zero || -(*l4) + *
l5 + *l3 < zero) {
*ier = 3;
xermsg_("SLATEC", "RC6J", "L4, L5, L3 triangular condition not satis"
"fied.", ier, &c__1, (ftnlen)6, (ftnlen)4, (ftnlen)46);
return 0;
}
/* Limits for L1 */
/* Computing MAX */
r__3 = (r__1 = *l2 - *l3, dabs(r__1)), r__4 = (r__2 = *l5 - *l6, dabs(
r__2));
*l1min = dmax(r__3,r__4);
/* Computing MIN */
r__1 = *l2 + *l3, r__2 = *l5 + *l6;
*l1max = dmin(r__1,r__2);
/* Check error condition 4. */
r__1 = *l1max - *l1min + eps;
if (r_mod(&r__1, &one) >= eps + eps) {
*ier = 4;
xermsg_("SLATEC", "RC6J", "L1MAX-L1MIN not integer.", ier, &c__1, (
ftnlen)6, (ftnlen)4, (ftnlen)24);
return 0;
}
if (*l1min < *l1max - eps) {
goto L20;
}
if (*l1min < *l1max + eps) {
goto L10;
}
/* Check error condition 5. */
*ier = 5;
xermsg_("SLATEC", "RC6J", "L1MIN greater than L1MAX.", ier, &c__1, (
ftnlen)6, (ftnlen)4, (ftnlen)25);
return 0;
/* This is reached in case that L1 can take only one value */
L10:
/* LSCALE = 0 */
r__1 = -one;
i__1 = (integer) (*l2 + *l3 + *l5 + *l6 + eps);
sixcof[1] = pow_ri(&r__1, &i__1) / sqrt((*l1min + *l1min + one) * (*l4 + *
l4 + one));
return 0;
/* This is reached in case that L1 can take more than one value. */
L20:
/* LSCALE = 0 */
nfin = (integer) (*l1max - *l1min + one + eps);
if (*ndim - nfin >= 0) {
goto L23;
} else {
goto L21;
}
/* Check error condition 6. */
L21:
*ier = 6;
xermsg_("SLATEC", "RC6J", "Dimension of result array for 6j coefficients"
" too small.", ier, &c__1, (ftnlen)6, (ftnlen)4, (ftnlen)56);
return 0;
/* Start of forward recursion */
L23:
l1 = *l1min;
newfac = 0.f;
c1 = 0.f;
sixcof[1] = srtiny;
sum1 = (l1 + l1 + one) * tiny;
lstep = 1;
L30:
++lstep;
l1 += one;
oldfac = newfac;
a1 = (l1 + *l2 + *l3 + one) * (l1 - *l2 + *l3) * (l1 + *l2 - *l3) * (-l1
+ *l2 + *l3 + one);
a2 = (l1 + *l5 + *l6 + one) * (l1 - *l5 + *l6) * (l1 + *l5 - *l6) * (-l1
+ *l5 + *l6 + one);
newfac = sqrt(a1 * a2);
if (l1 < one + eps) {
goto L40;
}
dv = two * (*l2 * (*l2 + one) * *l5 * (*l5 + one) + *l3 * (*l3 + one) * *
l6 * (*l6 + one) - l1 * (l1 - one) * *l4 * (*l4 + one)) - (*l2 * (
*l2 + one) + *l3 * (*l3 + one) - l1 * (l1 - one)) * (*l5 * (*l5 +
one) + *l6 * (*l6 + one) - l1 * (l1 - one));
denom = (l1 - one) * newfac;
if (lstep - 2 <= 0) {
goto L32;
} else {
goto L31;
}
L31:
c1old = dabs(c1);
L32:
c1 = -(l1 + l1 - one) * dv / denom;
goto L50;
/* If L1 = 1, (L1 - 1) has to be factored out of DV, hence */
L40:
c1 = -two * (*l2 * (*l2 + one) + *l5 * (*l5 + one) - *l4 * (*l4 + one)) /
newfac;
L50:
if (lstep > 2) {
goto L60;
}
/* If L1 = L1MIN + 1, the third term in recursion equation vanishes */
x = srtiny * c1;
sixcof[2] = x;
sum1 += tiny * (l1 + l1 + one) * c1 * c1;
if (lstep == nfin) {
goto L220;
}
goto L30;
L60:
c2 = -l1 * oldfac / denom;
/* Recursion to the next 6j coefficient X */
x = c1 * sixcof[lstep - 1] + c2 * sixcof[lstep - 2];
sixcof[lstep] = x;
sumfor = sum1;
sum1 += (l1 + l1 + one) * x * x;
if (lstep == nfin) {
goto L100;
}
/* See if last unnormalized 6j coefficient exceeds SRHUGE */
if (dabs(x) < srhuge) {
goto L80;
}
/* This is reached if last 6j coefficient larger than SRHUGE, */
/* so that the recursion series SIXCOF(1), ... ,SIXCOF(LSTEP) */
/* has to be rescaled to prevent overflow */
/* LSCALE = LSCALE + 1 */
i__1 = lstep;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = sixcof[i__], dabs(r__1)) < srtiny) {
sixcof[i__] = zero;
}
/* L70: */
sixcof[i__] /= srhuge;
}
sum1 /= huge__;
sumfor /= huge__;
x /= srhuge;
/* As long as the coefficient ABS(C1) is decreasing, the recursion */
/* proceeds towards increasing 6j values and, hence, is numerically */
/* stable. Once an increase of ABS(C1) is detected, the recursion */
/* direction is reversed. */
L80:
if (c1old - dabs(c1) <= 0.f) {
goto L100;
} else {
goto L30;
}
/* Keep three 6j coefficients around LMATCH for comparison later */
/* with backward recursion. */
L100:
/* LMATCH = L1 - 1 */
x1 = x;
x2 = sixcof[lstep - 1];
x3 = sixcof[lstep - 2];
/* Starting backward recursion from L1MAX taking NSTEP2 steps, so */
/* that forward and backward recursion overlap at the three points */
/* L1 = LMATCH+1, LMATCH, LMATCH-1. */
nfinp1 = nfin + 1;
nfinp2 = nfin + 2;
nfinp3 = nfin + 3;
nstep2 = nfin - lstep + 3;
l1 = *l1max;
sixcof[nfin] = srtiny;
sum2 = (l1 + l1 + one) * tiny;
l1 += two;
lstep = 1;
L110:
++lstep;
l1 -= one;
oldfac = newfac;
a1s = (l1 + *l2 + *l3) * (l1 - *l2 + *l3 - one) * (l1 + *l2 - *l3 - one) *
(-l1 + *l2 + *l3 + two);
a2s = (l1 + *l5 + *l6) * (l1 - *l5 + *l6 - one) * (l1 + *l5 - *l6 - one) *
(-l1 + *l5 + *l6 + two);
newfac = sqrt(a1s * a2s);
dv = two * (*l2 * (*l2 + one) * *l5 * (*l5 + one) + *l3 * (*l3 + one) * *
l6 * (*l6 + one) - l1 * (l1 - one) * *l4 * (*l4 + one)) - (*l2 * (
*l2 + one) + *l3 * (*l3 + one) - l1 * (l1 - one)) * (*l5 * (*l5 +
one) + *l6 * (*l6 + one) - l1 * (l1 - one));
denom = l1 * newfac;
c1 = -(l1 + l1 - one) * dv / denom;
if (lstep > 2) {
goto L120;
}
/* If L1 = L1MAX + 1 the third term in the recursion equation vanishes */
y = srtiny * c1;
sixcof[nfin - 1] = y;
if (lstep == nstep2) {
goto L200;
}
sumbac = sum2;
sum2 += (l1 + l1 - three) * c1 * c1 * tiny;
goto L110;
L120:
c2 = -(l1 - one) * oldfac / denom;
/* Recursion to the next 6j coefficient Y */
y = c1 * sixcof[nfinp2 - lstep] + c2 * sixcof[nfinp3 - lstep];
if (lstep == nstep2) {
goto L200;
}
sixcof[nfinp1 - lstep] = y;
sumbac = sum2;
sum2 += (l1 + l1 - three) * y * y;
/* See if last unnormalized 6j coefficient exceeds SRHUGE */
if (dabs(y) < srhuge) {
goto L110;
}
/* This is reached if last 6j coefficient larger than SRHUGE, */
/* so that the recursion series SIXCOF(NFIN), ... ,SIXCOF(NFIN-LSTEP+1) */
/* has to be rescaled to prevent overflow */
/* LSCALE = LSCALE + 1 */
i__1 = lstep;
for (i__ = 1; i__ <= i__1; ++i__) {
index = nfin - i__ + 1;
if ((r__1 = sixcof[index], dabs(r__1)) < srtiny) {
sixcof[index] = zero;
}
/* L130: */
sixcof[index] /= srhuge;
}
sumbac /= huge__;
sum2 /= huge__;
goto L110;
/* The forward recursion 6j coefficients X1, X2, X3 are to be matched */
/* with the corresponding backward recursion values Y1, Y2, Y3. */
L200:
y3 = y;
y2 = sixcof[nfinp2 - lstep];
y1 = sixcof[nfinp3 - lstep];
/* Determine now RATIO such that YI = RATIO * XI (I=1,2,3) holds */
/* with minimal error. */
ratio = (x1 * y1 + x2 * y2 + x3 * y3) / (x1 * x1 + x2 * x2 + x3 * x3);
nlim = nfin - nstep2 + 1;
if (dabs(ratio) < one) {
goto L211;
}
i__1 = nlim;
for (n = 1; n <= i__1; ++n) {
/* L210: */
sixcof[n] = ratio * sixcof[n];
}
sumuni = ratio * ratio * sumfor + sumbac;
goto L230;
L211:
++nlim;
ratio = one / ratio;
i__1 = nfin;
for (n = nlim; n <= i__1; ++n) {
/* L212: */
sixcof[n] = ratio * sixcof[n];
}
sumuni = sumfor + ratio * ratio * sumbac;
goto L230;
L220:
sumuni = sum1;
/* Normalize 6j coefficients */
L230:
cnorm = one / sqrt((*l4 + *l4 + one) * sumuni);
/* Sign convention for last 6j coefficient determines overall phase */
sign1 = r_sign(&one, &sixcof[nfin]);
r__1 = -one;
i__1 = (integer) (*l2 + *l3 + *l5 + *l6 + eps);
sign2 = pow_ri(&r__1, &i__1);
if (sign1 * sign2 <= 0.f) {
goto L235;
} else {
goto L236;
}
L235:
cnorm = -cnorm;
L236:
if (dabs(cnorm) < one) {
goto L250;
}
i__1 = nfin;
for (n = 1; n <= i__1; ++n) {
/* L240: */
sixcof[n] = cnorm * sixcof[n];
}
return 0;
L250:
thresh = tiny / dabs(cnorm);
i__1 = nfin;
for (n = 1; n <= i__1; ++n) {
if ((r__1 = sixcof[n], dabs(r__1)) < thresh) {
sixcof[n] = zero;
}
/* L251: */
sixcof[n] = cnorm * sixcof[n];
}
return 0;
} /* rc6j_ */
