/* > \brief \b IPARMQ
=========== DOCUMENTATION ===========
Online html documentation available at
http://www.netlib.org/lapack/explore-html/
> \htmlonly
> Download IPARMQ + dependencies
> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/iparmq.
f">
> [TGZ]</a>
> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/iparmq.
f">
> [ZIP]</a>
> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/iparmq.
f">
> [TXT]</a>
> \endhtmlonly
Definition:
===========
INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
INTEGER IHI, ILO, ISPEC, LWORK, N
CHARACTER NAME*( * ), OPTS*( * )
> \par Purpose:
=============
>
> \verbatim
>
> This program sets problem and machine dependent parameters
> useful for xHSEQR and its subroutines. It is called whenever
> ILAENV is called with 12 <= ISPEC <= 16
> \endverbatim
Arguments:
==========
> \param[in] ISPEC
> \verbatim
> ISPEC is integer scalar
> ISPEC specifies which tunable parameter IPARMQ should
> return.
>
> ISPEC=12: (INMIN) Matrices of order nmin or less
> are sent directly to xLAHQR, the implicit
> double shift QR algorithm. NMIN must be
> at least 11.
>
> ISPEC=13: (INWIN) Size of the deflation window.
> This is best set greater than or equal to
> the number of simultaneous shifts NS.
> Larger matrices benefit from larger deflation
> windows.
>
> ISPEC=14: (INIBL) Determines when to stop nibbling and
> invest in an (expensive) multi-shift QR sweep.
> If the aggressive early deflation subroutine
> finds LD converged eigenvalues from an order
> NW deflation window and LD.GT.(NW*NIBBLE)/100,
> then the next QR sweep is skipped and early
> deflation is applied immediately to the
> remaining active diagonal block. Setting
> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a
> multi-shift QR sweep whenever early deflation
> finds a converged eigenvalue. Setting
> IPARMQ(ISPEC=14) greater than or equal to 100
> prevents TTQRE from skipping a multi-shift
> QR sweep.
>
> ISPEC=15: (NSHFTS) The number of simultaneous shifts in
> a multi-shift QR iteration.
>
> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the
> following meanings.
> 0: During the multi-shift QR sweep,
> xLAQR5 does not accumulate reflections and
> does not use matrix-matrix multiply to
> update the far-from-diagonal matrix
> entries.
> 1: During the multi-shift QR sweep,
> xLAQR5 and/or xLAQRaccumulates reflections and uses
> matrix-matrix multiply to update the
> far-from-diagonal matrix entries.
> 2: During the multi-shift QR sweep.
> xLAQR5 accumulates reflections and takes
> advantage of 2-by-2 block structure during
> matrix-matrix multiplies.
> (If xTRMM is slower than xGEMM, then
> IPARMQ(ISPEC=16)=1 may be more efficient than
> IPARMQ(ISPEC=16)=2 despite the greater level of
> arithmetic work implied by the latter choice.)
> \endverbatim
>
> \param[in] NAME
> \verbatim
> NAME is character string
> Name of the calling subroutine
> \endverbatim
>
> \param[in] OPTS
> \verbatim
> OPTS is character string
> This is a concatenation of the string arguments to
> TTQRE.
> \endverbatim
>
> \param[in] N
> \verbatim
> N is integer scalar
> N is the order of the Hessenberg matrix H.
> \endverbatim
>
> \param[in] ILO
> \verbatim
> ILO is INTEGER
> \endverbatim
>
> \param[in] IHI
> \verbatim
> IHI is INTEGER
> It is assumed that H is already upper triangular
> in rows and columns 1:ILO-1 and IHI+1:N.
> \endverbatim
>
> \param[in] LWORK
> \verbatim
> LWORK is integer scalar
> The amount of workspace available.
> \endverbatim
Authors:
========
> \author Univ. of Tennessee
> \author Univ. of California Berkeley
> \author Univ. of Colorado Denver
> \author NAG Ltd.
> \date November 2011
> \ingroup auxOTHERauxiliary
> \par Further Details:
=====================
>
> \verbatim
>
> Little is known about how best to choose these parameters.
> It is possible to use different values of the parameters
> for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.
>
> It is probably best to choose different parameters for
> different matrices and different parameters at different
> times during the iteration, but this has not been
> implemented --- yet.
>
>
> The best choices of most of the parameters depend
> in an ill-understood way on the relative execution
> rate of xLAQR3 and xLAQR5 and on the nature of each
> particular eigenvalue problem. Experiment may be the
> only practical way to determine which choices are most
> effective.
>
> Following is a list of default values supplied by IPARMQ.
> These defaults may be adjusted in order to attain better
> performance in any particular computational environment.
>
> IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.
> Default: 75. (Must be at least 11.)
>
> IPARMQ(ISPEC=13) Recommended deflation window size.
> This depends on ILO, IHI and NS, the
> number of simultaneous shifts returned
> by IPARMQ(ISPEC=15). The default for
> (IHI-ILO+1).LE.500 is NS. The default
> for (IHI-ILO+1).GT.500 is 3*NS/2.
>
> IPARMQ(ISPEC=14) Nibble crossover point. Default: 14.
>
> IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.
> a multi-shift QR iteration.
>
> If IHI-ILO+1 is ...
>
> greater than ...but less ... the
> or equal to ... than default is
>
> 0 30 NS = 2+
> 30 60 NS = 4+
> 60 150 NS = 10
> 150 590 NS = **
> 590 3000 NS = 64
> 3000 6000 NS = 128
> 6000 infinity NS = 256
>
> (+) By default matrices of this order are
> passed to the implicit double shift routine
> xLAHQR. See IPARMQ(ISPEC=12) above. These
> values of NS are used only in case of a rare
> xLAHQR failure.
>
> (**) The asterisks (**) indicate an ad-hoc
> function increasing from 10 to 64.
>
> IPARMQ(ISPEC=16) Select structured matrix multiply.
> (See ISPEC=16 above for details.)
> Default: 3.
> \endverbatim
>
===================================================================== */
integer igraphiparmq_(integer *ispec, char *name__, char *opts, integer *n, integer
*ilo, integer *ihi, integer *lwork)
{
/* System generated locals */
integer ret_val, i__1, i__2;
real r__1;
/* Builtin functions */
double log(doublereal);
integer i_nint(real *);
/* Local variables */
integer nh, ns;
/* -- LAPACK auxiliary 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
================================================================ */
if (*ispec == 15 || *ispec == 13 || *ispec == 16) {
/* ==== Set the number simultaneous shifts ==== */
nh = *ihi - *ilo + 1;
ns = 2;
if (nh >= 30) {
ns = 4;
}
if (nh >= 60) {
ns = 10;
}
if (nh >= 150) {
/* Computing MAX */
r__1 = log((real) nh) / log(2.f);
i__1 = 10, i__2 = nh / i_nint(&r__1);
ns = max(i__1,i__2);
}
if (nh >= 590) {
ns = 64;
}
if (nh >= 3000) {
ns = 128;
}
if (nh >= 6000) {
ns = 256;
}
/* Computing MAX */
i__1 = 2, i__2 = ns - ns % 2;
ns = max(i__1,i__2);
}
if (*ispec == 12) {
/* ===== Matrices of order smaller than NMIN get sent
. to xLAHQR, the classic double shift algorithm.
. This must be at least 11. ==== */
ret_val = 75;
} else if (*ispec == 14) {
/* ==== INIBL: skip a multi-shift qr iteration and
. whenever aggressive early deflation finds
. at least (NIBBLE*(window size)/100) deflations. ==== */
ret_val = 14;
} else if (*ispec == 15) {
/* ==== NSHFTS: The number of simultaneous shifts ===== */
ret_val = ns;
} else if (*ispec == 13) {
/* ==== NW: deflation window size. ==== */
if (nh <= 500) {
ret_val = ns;
} else {
ret_val = ns * 3 / 2;
}
} else if (*ispec == 16) {
/* ==== IACC22: Whether to accumulate reflections
. before updating the far-from-diagonal elements
. and whether to use 2-by-2 block structure while
. doing it. A small amount of work could be saved
. by making this choice dependent also upon the
. NH=IHI-ILO+1. */
ret_val = 0;
if (ns >= 14) {
ret_val = 1;
}
if (ns >= 14) {
ret_val = 2;
}
} else {
/* ===== invalid value of ispec ===== */
ret_val = -1;
}
/* ==== End of IPARMQ ==== */
return ret_val;
} /* igraphiparmq_ */
/* Subroutine */ int slacn2_(integer *n, real *v, real *x, integer *isgn,
real *est, integer *kase, integer *isave)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
double r_sign(real *, real *);
integer i_nint(real *);
/* Local variables */
integer i__;
real temp;
integer jlast;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern integer isamax_(integer *, real *, integer *);
real altsgn, estold;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLACN2 estimates the 1-norm of a square, real matrix A. */
/* Reverse communication is used for evaluating matrix-vector products. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 1. */
/* V (workspace) REAL array, dimension (N) */
/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
/* (W is not returned). */
/* X (input/output) REAL array, dimension (N) */
/* On an intermediate return, X should be overwritten by */
/* A * X, if KASE=1, */
/* A' * X, if KASE=2, */
/* and SLACN2 must be re-called with all the other parameters */
/* unchanged. */
/* ISGN (workspace) INTEGER array, dimension (N) */
/* EST (input/output) REAL */
/* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */
/* unchanged from the previous call to SLACN2. */
/* On exit, EST is an estimate (a lower bound) for norm(A). */
/* KASE (input/output) INTEGER */
/* On the initial call to SLACN2, KASE should be 0. */
/* On an intermediate return, KASE will be 1 or 2, indicating */
/* whether X should be overwritten by A * X or A' * X. */
/* On the final return from SLACN2, KASE will again be 0. */
/* ISAVE (input/output) INTEGER array, dimension (3) */
/* ISAVE is used to save variables between calls to SLACN2 */
/* Further Details */
/* ======= ======= */
/* Contributed by Nick Higham, University of Manchester. */
/* Originally named SONEST, dated March 16, 1988. */
/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/* a real or complex matrix, with applications to condition estimation", */
/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
/* This is a thread safe version of SLACON, which uses the array ISAVE */
/* in place of a SAVE statement, as follows: */
/* SLACON SLACN2 */
/* JUMP ISAVE(1) */
/* J ISAVE(2) */
/* ITER ISAVE(3) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--isave;
--isgn;
--x;
--v;
/* Function Body */
if (*kase == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 1.f / (real) (*n);
/* L10: */
}
*kase = 1;
isave[1] = 1;
return 0;
}
switch (isave[1]) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* ................ ENTRY (ISAVE( 1 ) = 1) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[1] = x[1];
*est = dabs(v[1]);
/* ... QUIT */
goto L150;
}
*est = sasum_(n, &x[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = r_sign(&c_b11, &x[i__]);
isgn[i__] = i_nint(&x[i__]);
/* L30: */
}
*kase = 2;
isave[1] = 2;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 2) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
isave[2] = isamax_(n, &x[1], &c__1);
isave[3] = 2;
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 0.f;
/* L60: */
}
x[isave[2]] = 1.f;
*kase = 1;
isave[1] = 3;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 3) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L70:
scopy_(n, &x[1], &c__1, &v[1], &c__1);
estold = *est;
*est = sasum_(n, &v[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
r__1 = r_sign(&c_b11, &x[i__]);
if (i_nint(&r__1) != isgn[i__]) {
goto L90;
}
/* L80: */
}
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) {
goto L120;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = r_sign(&c_b11, &x[i__]);
isgn[i__] = i_nint(&x[i__]);
/* L100: */
}
*kase = 2;
isave[1] = 4;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 4) */
/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L110:
jlast = isave[2];
isave[2] = isamax_(n, &x[1], &c__1);
if (x[jlast] != (r__1 = x[isave[2]], dabs(r__1)) && isave[3] < 5) {
++isave[3];
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f);
altsgn = -altsgn;
/* L130: */
}
*kase = 1;
isave[1] = 5;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 5) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L140:
temp = sasum_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f;
if (temp > *est) {
scopy_(n, &x[1], &c__1, &v[1], &c__1);
*est = temp;
}
L150:
*kase = 0;
return 0;
/* End of SLACN2 */
} /* slacn2_ */
/* Subroutine */ int placea_(integer *ipitch, integer *voibuf, integer *
obound, integer *af, integer *vwin, integer *awin, integer *ewin,
integer *lframe, integer *maxwin)
{
/* System generated locals */
real r__1;
/* Builtin functions */
integer i_nint(real *);
/* Local variables */
logical allv, winv;
integer i__, j, k, l, hrange;
logical ephase;
integer lrange;
/* Arguments */
/* Local variables that need not be saved */
/* Parameter adjustments */
ewin -= 3;
awin -= 3;
vwin -= 3;
--voibuf;
/* Function Body */
lrange = (*af - 2) * *lframe + 1;
hrange = *af * *lframe;
/* Place the Analysis window based on the voicing window */
/* placement, onsets, tentative voicing decision, and pitch. */
/* Case 1: Sustained Voiced Speech */
/* If the five most recent voicing decisions are */
/* voiced, then the window is placed phase-synchronously with the */
/* previous window, as close to the present voicing window if possible.
*/
/* If onsets bound the voicing window, then preference is given to */
/* a phase-synchronous placement which does not overlap these onsets. */
/* Case 2: Voiced Transition */
/* If at least one voicing decision in AF is voicied, and there are no
*/
/* onsets, then the window is placed as in case 1. */
/* Case 3: Unvoiced Speech or Onsets */
/* If both voicing decisions in AF are unvoiced, or there are onsets, */
/* then the window is placed coincident with the voicing window. */
/* Note: During phase-synchronous placement of windows, the length */
/* is not altered from MAXWIN, since this would defeat the purpose */
/* of phase-synchronous placement. */
/* Check for case 1 and case 2 */
allv = voibuf[((*af - 2) << 1) + 2] == 1;
allv = allv && voibuf[((*af - 1) << 1) + 1] == 1;
allv = allv && voibuf[((*af - 1) << 1) + 2] == 1;
allv = allv && voibuf[(*af << 1) + 1] == 1;
allv = allv && voibuf[(*af << 1) + 2] == 1;
winv = voibuf[(*af << 1) + 1] == 1 || voibuf[(*af << 1) + 2] == 1;
if (allv || (winv && *obound == 0)) {
/* APHASE: Phase synchronous window placement. */
/* Get minimum lower index of the window. */
i__ = (lrange + *ipitch - 1 - awin[((*af - 1) << 1) + 1]) / *ipitch;
i__ *= *ipitch;
i__ += awin[((*af - 1) << 1) + 1];
/* L = the actual length of this frame's analysis window. */
l = *maxwin;
/* Calculate the location where a perfectly centered window would star
t. */
k = (vwin[(*af << 1) + 1] + vwin[(*af << 1) + 2] + 1 - l) / 2;
/* Choose the actual location to be the pitch multiple closest to this
. */
r__1 = (real) (k - i__) / *ipitch;
awin[(*af << 1) + 1] = i__ + i_nint(&r__1) * *ipitch;
awin[(*af << 1) + 2] = awin[(*af << 1) + 1] + l - 1;
/* If there is an onset bounding the right of the voicing window and t
he */
/* analysis window overlaps that, then move the analysis window backwa
rd */
/* to avoid this onset. */
if (*obound >= 2 && awin[(*af << 1) + 2] > vwin[(*af << 1) + 2]) {
awin[(*af << 1) + 1] -= *ipitch;
awin[(*af << 1) + 2] -= *ipitch;
}
/* Similarly for the left of the voicing window. */
if ((*obound == 1 || *obound == 3) && awin[(*af << 1) + 1] < vwin[(*
af << 1) + 1]) {
awin[(*af << 1) + 1] += *ipitch;
awin[(*af << 1) + 2] += *ipitch;
}
/* If this placement puts the analysis window above HRANGE, then */
/* move it backward an integer number of pitch periods. */
while(awin[(*af << 1) + 2] > hrange) {
awin[(*af << 1) + 1] -= *ipitch;
awin[(*af << 1) + 2] -= *ipitch;
}
/* Similarly if the placement puts the analysis window below LRANGE.
*/
while(awin[(*af << 1) + 1] < lrange) {
awin[(*af << 1) + 1] += *ipitch;
awin[(*af << 1) + 2] += *ipitch;
}
/* Make Energy window be phase-synchronous. */
ephase = TRUE_;
/* Case 3 */
} else {
awin[(*af << 1) + 1] = vwin[(*af << 1) + 1];
awin[(*af << 1) + 2] = vwin[(*af << 1) + 2];
ephase = FALSE_;
}
/* RMS is computed over an integer number of pitch periods in the analysis
*/
/*window. When it is not placed phase-synchronously, it is placed as clos
e*/
/* as possible to onsets. */
j = (awin[(*af << 1) + 2] - awin[(*af << 1) + 1] + 1) / *ipitch * *ipitch;
if (j == 0 || ! winv) {
ewin[(*af << 1) + 1] = vwin[(*af << 1) + 1];
ewin[(*af << 1) + 2] = vwin[(*af << 1) + 2];
} else if (! ephase && *obound == 2) {
ewin[(*af << 1) + 1] = awin[(*af << 1) + 2] - j + 1;
ewin[(*af << 1) + 2] = awin[(*af << 1) + 2];
} else {
ewin[(*af << 1) + 1] = awin[(*af << 1) + 1];
ewin[(*af << 1) + 2] = awin[(*af << 1) + 1] + j - 1;
}
return 0;
} /* placea_ */
/*< S >*/
/* Subroutine */ int placea_(integer *ipitch, integer *voibuf, integer *
obound, integer *af, integer *vwin, integer *awin, integer *ewin,
integer *lframe, integer *maxwin)
{
/* System generated locals */
real r__1;
/* Builtin functions */
integer i_nint(real *);
/* Local variables */
logical allv, winv;
integer i__, j, k, l, hrange;
logical ephase;
integer lrange;
/* Arguments */
/*< INTEGER IPITCH, OBOUND, AF >*/
/*< INTEGER VOIBUF(2,0:AF) >*/
/*< INTEGER VWIN(2,AF) >*/
/*< INTEGER LFRAME, MAXWIN >*/
/*< INTEGER AWIN(2,AF) >*/
/*< INTEGER EWIN(2,AF) >*/
/* Local variables that need not be saved */
/*< INTEGER I, J, K, L >*/
/*< LOGICAL EPHASE, ALLV, WINV >*/
/*< INTEGER LRANGE, HRANGE >*/
/*< LRANGE = (AF-2)*LFRAME + 1 >*/
/* Parameter adjustments */
ewin -= 3;
awin -= 3;
vwin -= 3;
--voibuf;
/* Function Body */
lrange = (*af - 2) * *lframe + 1;
/*< HRANGE = AF*LFRAME >*/
hrange = *af * *lframe;
/* Place the Analysis window based on the voicing window */
/* placement, onsets, tentative voicing decision, and pitch. */
/* Case 1: Sustained Voiced Speech */
/* If the five most recent voicing decisions are */
/* voiced, then the window is placed phase-synchronously with the */
/* previous window, as close to the present voicing window if possible.
*/
/* If onsets bound the voicing window, then preference is given to */
/* a phase-synchronous placement which does not overlap these onsets. */
/* Case 2: Voiced Transition */
/* If at least one voicing decision in AF is voicied, and there are no
*/
/* onsets, then the window is placed as in case 1. */
/* Case 3: Unvoiced Speech or Onsets */
/* If both voicing decisions in AF are unvoiced, or there are onsets, */
/* then the window is placed coincident with the voicing window. */
/* Note: During phase-synchronous placement of windows, the length */
/* is not altered from MAXWIN, since this would defeat the purpose */
/* of phase-synchronous placement. */
/* Check for case 1 and case 2 */
/*< ALLV = VOIBUF(2,AF-2) .EQ. 1 >*/
allv = voibuf[(*af - 2 << 1) + 2] == 1;
/*< ALLV = ALLV .AND. VOIBUF(1,AF-1) .EQ. 1 >*/
allv = allv && voibuf[(*af - 1 << 1) + 1] == 1;
/*< ALLV = ALLV .AND. VOIBUF(2,AF-1) .EQ. 1 >*/
allv = allv && voibuf[(*af - 1 << 1) + 2] == 1;
/*< ALLV = ALLV .AND. VOIBUF(1,AF ) .EQ. 1 >*/
allv = allv && voibuf[(*af << 1) + 1] == 1;
/*< ALLV = ALLV .AND. VOIBUF(2,AF ) .EQ. 1 >*/
allv = allv && voibuf[(*af << 1) + 2] == 1;
/*< WINV = VOIBUF(1,AF ) .EQ. 1 .OR. VOIBUF(2,AF ) .EQ. 1 >*/
winv = voibuf[(*af << 1) + 1] == 1 || voibuf[(*af << 1) + 2] == 1;
/*< IF (ALLV .OR. WINV .AND. OBOUND .EQ. 0) THEN >*/
if (allv || winv && *obound == 0) {
/* APHASE: Phase synchronous window placement. */
/* Get minimum lower index of the window. */
/*< I = (LRANGE + IPITCH - 1 - AWIN(1,AF-1)) / IPITCH >*/
i__ = (lrange + *ipitch - 1 - awin[(*af - 1 << 1) + 1]) / *ipitch;
/*< I = I * IPITCH >*/
i__ *= *ipitch;
/*< I = I + AWIN(1,AF-1) >*/
i__ += awin[(*af - 1 << 1) + 1];
/* L = the actual length of this frame's analysis window. */
/*< L = MAXWIN >*/
l = *maxwin;
/* Calculate the location where a perfectly centered window would star
t. */
/*< K = (VWIN(1,AF) + VWIN(2,AF) + 1 - L) / 2 >*/
k = (vwin[(*af << 1) + 1] + vwin[(*af << 1) + 2] + 1 - l) / 2;
/* Choose the actual location to be the pitch multiple closest to this
. */
/*< AWIN(1,AF) = I + NINT (FLOAT (K - I) / IPITCH) * IPITCH >*/
r__1 = (real) (k - i__) / *ipitch;
awin[(*af << 1) + 1] = i__ + i_nint(&r__1) * *ipitch;
/*< AWIN(2,AF) = AWIN(1,AF) + L - 1 >*/
awin[(*af << 1) + 2] = awin[(*af << 1) + 1] + l - 1;
/* If there is an onset bounding the right of the voicing window and t
he */
/* analysis window overlaps that, then move the analysis window backwa
rd */
/* to avoid this onset. */
/*< IF (OBOUND .GE. 2 .AND. AWIN (2,AF) .GT. VWIN (2,AF)) THEN >*/
if (*obound >= 2 && awin[(*af << 1) + 2] > vwin[(*af << 1) + 2]) {
/*< AWIN(1,AF) = AWIN(1,AF) - IPITCH >*/
awin[(*af << 1) + 1] -= *ipitch;
/*< AWIN(2,AF) = AWIN(2,AF) - IPITCH >*/
awin[(*af << 1) + 2] -= *ipitch;
/*< END IF >*/
}
/* Similarly for the left of the voicing window. */
/*< >*/
if ((*obound == 1 || *obound == 3) && awin[(*af << 1) + 1] < vwin[(*
af << 1) + 1]) {
/*< AWIN(1,AF) = AWIN(1,AF) + IPITCH >*/
awin[(*af << 1) + 1] += *ipitch;
/*< AWIN(2,AF) = AWIN(2,AF) + IPITCH >*/
awin[(*af << 1) + 2] += *ipitch;
/*< END IF >*/
}
/* If this placement puts the analysis window above HRANGE, then */
/* move it backward an integer number of pitch periods. */
/*< DO WHILE (AWIN (2,AF) .GT. HRANGE) >*/
while(awin[(*af << 1) + 2] > hrange) {
/*< AWIN(1,AF) = AWIN(1,AF) - IPITCH >*/
awin[(*af << 1) + 1] -= *ipitch;
/*< AWIN(2,AF) = AWIN(2,AF) - IPITCH >*/
awin[(*af << 1) + 2] -= *ipitch;
/*< END DO >*/
}
/* Similarly if the placement puts the analysis window below LRANGE.
*/
/*< DO WHILE (AWIN (1,AF) .LT. LRANGE) >*/
while(awin[(*af << 1) + 1] < lrange) {
/*< AWIN(1,AF) = AWIN(1,AF) + IPITCH >*/
awin[(*af << 1) + 1] += *ipitch;
/*< AWIN(2,AF) = AWIN(2,AF) + IPITCH >*/
awin[(*af << 1) + 2] += *ipitch;
/*< END DO >*/
}
/* Make Energy window be phase-synchronous. */
/*< EPHASE = .TRUE. >*/
ephase = TRUE_;
/* Case 3 */
/*< ELSE >*/
} else {
/*< AWIN(1,AF) = VWIN(1,AF) >*/
awin[(*af << 1) + 1] = vwin[(*af << 1) + 1];
/*< AWIN(2,AF) = VWIN(2,AF) >*/
awin[(*af << 1) + 2] = vwin[(*af << 1) + 2];
/*< EPHASE = .FALSE. >*/
ephase = FALSE_;
/*< END IF >*/
}
/* RMS is computed over an integer number of pitch periods in the analysis
*/
/*window. When it is not placed phase-synchronously, it is placed as clos
e*/
/* as possible to onsets. */
/*< J = ((AWIN(2,AF)-AWIN(1,AF)+1)/IPITCH)*IPITCH >*/
j = (awin[(*af << 1) + 2] - awin[(*af << 1) + 1] + 1) / *ipitch * *ipitch;
/*< IF (J .EQ. 0 .OR. .NOT. WINV) THEN >*/
if (j == 0 || ! winv) {
/*< EWIN(1,AF) = VWIN(1,AF) >*/
ewin[(*af << 1) + 1] = vwin[(*af << 1) + 1];
/*< EWIN(2,AF) = VWIN(2,AF) >*/
ewin[(*af << 1) + 2] = vwin[(*af << 1) + 2];
/*< ELSE IF (.NOT. EPHASE .AND. OBOUND .EQ. 2) THEN >*/
} else if (! ephase && *obound == 2) {
/*< EWIN(1,AF) = AWIN(2,AF) - J + 1 >*/
ewin[(*af << 1) + 1] = awin[(*af << 1) + 2] - j + 1;
/*< EWIN(2,AF) = AWIN(2,AF) >*/
ewin[(*af << 1) + 2] = awin[(*af << 1) + 2];
/*< ELSE >*/
} else {
/*< EWIN(1,AF) = AWIN(1,AF) >*/
ewin[(*af << 1) + 1] = awin[(*af << 1) + 1];
/*< EWIN(2,AF) = AWIN(1,AF) + J - 1 >*/
ewin[(*af << 1) + 2] = awin[(*af << 1) + 1] + j - 1;
/*< END IF >*/
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* placea_ */
integer kb1calmsg_(integer *pfx, integer *idir, integer *nval, integer *band,
shortint *ibuf)
{
/* Initialized data */
static real factor[12] = { 21.21f,23.24f,19.77f,0.f,0.f,0.f,0.f,0.f,0.f,
0.f,0.f,22.39f };
static integer this__ = -9999;
static doublereal c1w3 = 0.;
static doublereal c2w = 0.;
static doublereal alpha = 0.;
static doublereal beta = 0.;
static doublereal gain = 0.;
static doublereal offset = 0.;
/* Format strings */
static char fmt_1[] = "(6e17.10)";
/* System generated locals */
address a__1[2];
integer ret_val, i__1[2], i__2;
real r__1;
char ch__1[116], ch__2[25], ch__3[12], ch__4[27];
static integer equiv_0[313];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_rsfi(icilist *), do_fio(integer *, char *, ftnlen), e_rsfi(void)
, i_nint(real *);
double sqrt(doublereal), log(doublereal);
/* Local variables */
extern /* Subroutine */ int m0sxtrce_(char *, ftnlen);
static integer i__, bandoffset;
extern /* Character */ VOID cff_(char *, ftnlen, doublereal *, integer *);
#define buf (equiv_0)
#define cbuf ((char *)equiv_0)
static integer ides;
static real refl;
static char cout[104];
static integer isou;
extern /* Subroutine */ int movw_(integer *, integer *, integer *);
static integer ibrit, itemp;
static real xtemp;
extern /* Subroutine */ int araget_(integer *, integer *, integer *,
integer *), mpixel_(integer *, integer *, integer *, shortint *),
gryscl_(real *, integer *);
/* Fortran I/O blocks */
static icilist io___13 = { 1, cout, 0, fmt_1, 104, 1 };
/* symbolic constants & shared data */
/* 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 */
/* external functions */
/* local variables */
/* Parameter adjustments */
--ibuf;
--idir;
--pfx;
/* Function Body */
if (this__ != idir[33]) {
this__ = idir[33];
s_copy(cout, " ", (ftnlen)104, (ftnlen)1);
if (msgcommsgkb1_1.calflg != 0) {
movw_(&c__51, msgcommsgkb1_1.calarr, buf);
} else {
araget_(&idir[33], &idir[63], &c__104, buf);
}
if (s_cmp(cbuf, "MSGT", (ftnlen)4, (ftnlen)4) == 0) {
if (msgcommsgkb1_1.calflg != 0) {
movw_(&c__313, msgcommsgkb1_1.calarr, buf);
} else {
araget_(&idir[33], &idir[63], &c__1252, buf);
}
bandoffset = (*band - 1) * 104 + 5;
s_copy(cout, cbuf + (bandoffset - 1), (ftnlen)104, (ftnlen)104);
} else {
s_copy(cout, cbuf, (ftnlen)104, (ftnlen)104);
}
/* Writing concatenation */
i__1[0] = 12, a__1[0] = "KBXMSG: CAL=";
i__1[1] = 104, a__1[1] = cout;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)116);
m0sxtrce_(ch__1, (ftnlen)116);
/* L1: */
i__2 = s_rsfi(&io___13);
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&c1w3, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&c2w, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&gain, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = do_fio(&c__1, (char *)&offset, (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L999;
}
i__2 = e_rsfi();
if (i__2 != 0) {
goto L999;
}
/* Writing concatenation */
i__1[0] = 13, a__1[0] = "KBXMSG: GAIN=";
cff_(ch__3, (ftnlen)12, &gain, &c__4);
i__1[1] = 12, a__1[1] = ch__3;
s_cat(ch__2, a__1, i__1, &c__2, (ftnlen)25);
m0sxtrce_(ch__2, (ftnlen)25);
/* Writing concatenation */
i__1[0] = 15, a__1[0] = "KBXMSG: OFFSET=";
cff_(ch__3, (ftnlen)12, &offset, &c__4);
i__1[1] = 12, a__1[1] = ch__3;
s_cat(ch__4, a__1, i__1, &c__2, (ftnlen)27);
m0sxtrce_(ch__4, (ftnlen)27);
isou = msgcommsgkb1_1.jopt[0];
ides = msgcommsgkb1_1.jopt[1];
}
i__2 = *nval;
for (i__ = 1; i__ <= i__2; ++i__) {
itemp = ibuf[i__];
if (*band < 4 || *band == 12) {
if (msgcommsgkb1_1.itype == 4) {
ibuf[i__] = 0;
} else {
xtemp = (real) itemp * gain + offset;
if (xtemp <= 0.f) {
xtemp = 0.f;
}
if (msgcommsgkb1_1.itype == 2) {
r__1 = xtemp * 100.f;
ibuf[i__] = (shortint) i_nint(&r__1);
} else if (msgcommsgkb1_1.itype == 3) {
refl = xtemp / factor[*band - 1] * 100;
if (refl < 0.f) {
refl = 0.f;
}
if (refl > 100.f) {
refl = 100.f;
}
r__1 = refl * 100;
ibuf[i__] = (shortint) i_nint(&r__1);
} else {
refl = xtemp / factor[*band - 1] * 100;
if (refl < 0.f) {
refl = 0.f;
}
if (refl > 100.f) {
refl = 100.f;
}
r__1 = sqrt(refl) * 25.5f;
ibuf[i__] = (shortint) i_nint(&r__1);
}
}
} else {
xtemp = gain * itemp + offset;
if (xtemp < 0.f) {
xtemp = 0.f;
}
if (msgcommsgkb1_1.itype == 2) {
r__1 = xtemp * 100.f;
ibuf[i__] = (shortint) i_nint(&r__1);
} else if (msgcommsgkb1_1.itype == 3) {
ibuf[i__] = 0;
} else if (msgcommsgkb1_1.itype == 4) {
if (xtemp > 0.f) {
xtemp = (c2w / log(c1w3 / xtemp + 1.f) - beta) / alpha;
r__1 = xtemp * 100.f;
ibuf[i__] = (shortint) i_nint(&r__1);
} else {
ibuf[i__] = 0;
}
} else {
if (xtemp > 0.f) {
xtemp = (c2w / log(c1w3 / xtemp + 1.f) - beta) / alpha;
gryscl_(&xtemp, &ibrit);
ibuf[i__] = (shortint) ibrit;
} else {
ibuf[i__] = 255;
}
}
}
}
mpixel_(nval, &isou, &ides, &ibuf[1]);
ret_val = 0;
return ret_val;
L999:
m0sxtrce_("KBXMSG: CAN NOT READ CAL HEADER", (ftnlen)31);
ret_val = -1;
return ret_val;
} /* kb1calmsg_ */
/* Subroutine */ int voicin_(integer *vwin, real *inbuf, real *
lpbuf, integer *buflim, integer *half, real *minamd, real *maxamd,
integer *mintau, real *ivrc, integer *obound, integer *voibuf,
integer *af, struct lpc10_encoder_state *st)
{
/* Initialized data */
real *dither;
static real vdc[100] /* was [10][10] */ = { 0.f,1714.f,-110.f,
334.f,-4096.f,-654.f,3752.f,3769.f,0.f,1181.f,0.f,874.f,-97.f,
300.f,-4096.f,-1021.f,2451.f,2527.f,0.f,-500.f,0.f,510.f,-70.f,
250.f,-4096.f,-1270.f,2194.f,2491.f,0.f,-1500.f,0.f,500.f,-10.f,
200.f,-4096.f,-1300.f,2e3f,2e3f,0.f,-2e3f,0.f,500.f,0.f,0.f,
-4096.f,-1300.f,2e3f,2e3f,0.f,-2500.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,
0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,
0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,
0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f };
static integer nvdcl = 5;
static real vdcl[10] = { 600.f,450.f,300.f,200.f,0.f,0.f,0.f,0.f,0.f,0.f }
;
/* System generated locals */
integer inbuf_offset = 0, lpbuf_offset = 0, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
integer i_nint(real *);
double sqrt(doublereal);
/* Local variables */
real ar_b__, ar_f__;
integer *lbve, *lbue, *fbve, *fbue;
integer snrl, i__;
integer *ofbue, *sfbue;
real *voice;
integer *olbue, *slbue;
real value[9];
integer zc;
logical ot;
real qs;
real *maxmin;
integer vstate;
real rc1;
extern /* Subroutine */ int vparms_(integer *, real *, real *, integer *,
integer *, real *, integer *, integer *, integer *, integer *,
real *, real *, real *, real *);
integer fbe, lbe;
real *snr;
real snr2;
/* Global Variables: */
/* Arguments */
/* $Log: voicin.c,v $
/* Revision 1.16 2004/06/26 03:50:14 markster
/* Merge source cleanups (bug #1911)
/*
/* Revision 1.15 2003/11/23 22:14:32 markster
/* Various warning cleanups
/*
/* Revision 1.14 2003/02/12 13:59:15 matteo
/* mer feb 12 14:56:57 CET 2003
/*
/* Revision 1.1.1.1 2003/02/12 13:59:15 matteo
/* mer feb 12 14:56:57 CET 2003
/*
/* Revision 1.2 2000/01/05 08:20:40 markster
/* Some OSS fixes and a few lpc changes to make it actually work
/*
* Revision 1.2 1996/08/20 20:45:00 jaf
* Removed all static local variables that were SAVE'd in the Fortran
* code, and put them in struct lpc10_encoder_state that is passed as an
* argument.
*
* Removed init function, since all initialization is now done in
* init_lpc10_encoder_state().
*
* Revision 1.1 1996/08/19 22:30:14 jaf
* Initial revision
* */
/* Revision 1.3 1996/03/29 22:05:55 jaf */
/* Commented out the common block variables that are not needed by the */
/* embedded version. */
/* Revision 1.2 1996/03/26 19:34:50 jaf */
/* Added comments indicating which constants are not needed in an */
/* application that uses the LPC-10 coder. */
/* Revision 1.1 1996/02/07 14:44:09 jaf */
/* Initial revision */
/* LPC Processing control variables: */
/* *** Read-only: initialized in setup */
/* Files for Speech, Parameter, and Bitstream Input & Output, */
/* and message and debug outputs. */
/* Here are the only files which use these variables: */
/* lpcsim.f setup.f trans.f error.f vqsetup.f */
/* Many files which use fdebug are not listed, since it is only used in */
/* those other files conditionally, to print trace statements. */
/* integer fsi, fso, fpi, fpo, fbi, fbo, pbin, fmsg, fdebug */
/* LPC order, Frame size, Quantization rate, Bits per frame, */
/* Error correction */
/* Subroutine SETUP is the only place where order is assigned a value, */
/* and that value is 10. It could increase efficiency 1% or so to */
/* declare order as a constant (i.e., a Fortran PARAMETER) instead of as
*/
/* a variable in a COMMON block, since it is used in many places in the */
/* core of the coding and decoding routines. Actually, I take that back.
*/
/* At least when compiling with f2c, the upper bound of DO loops is */
/* stored in a local variable before the DO loop begins, and then that is
*/
/* compared against on each iteration. */
/* Similarly for lframe, which is given a value of MAXFRM in SETUP. */
/* Similarly for quant, which is given a value of 2400 in SETUP. quant */
/* is used in only a few places, and never in the core coding and */
/* decoding routines, so it could be eliminated entirely. */
/* nbits is similar to quant, and is given a value of 54 in SETUP. */
/* corrp is given a value of .TRUE. in SETUP, and is only used in the */
/* subroutines ENCODE and DECODE. It doesn't affect the speed of the */
/* coder significantly whether it is .TRUE. or .FALSE., or whether it is
*/
/* a constant or a variable, since it is only examined once per frame. */
/* Leaving it as a variable that is set to .TRUE. seems like a good */
/* idea, since it does enable some error-correction capability for */
/* unvoiced frames, with no change in the coding rate, and no noticeable
*/
/* quality difference in the decoded speech. */
/* integer quant, nbits */
/* *** Read/write: variables for debugging, not needed for LPC algorithm
*/
/* Current frame, Unstable frames, Output clip count, Max onset buffer,
*/
/* Debug listing detail level, Line count on listing page */
/* nframe is not needed for an embedded LPC10 at all. */
/* nunsfm is initialized to 0 in SETUP, and incremented in subroutine */
/* ERROR, which is only called from RCCHK. When LPC10 is embedded into */
/* an application, I would recommend removing the call to ERROR in RCCHK,
*/
/* and remove ERROR and nunsfm completely. */
/* iclip is initialized to 0 in SETUP, and incremented in entry SWRITE in
*/
/* sread.f. When LPC10 is embedded into an application, one might want */
/* to cause it to be incremented in a routine that takes the output of */
/* SYNTHS and sends it to an audio device. It could be optionally */
/* displayed, for those that might want to know what it is. */
/* maxosp is never initialized to 0 in SETUP, although it probably should
*/
/* be, and it is updated in subroutine ANALYS. I doubt that its value */
/* would be of much interest to an application in which LPC10 is */
/* embedded. */
/* listl and lincnt are not needed for an embedded LPC10 at all. */
/* integer nframe, nunsfm, iclip, maxosp, listl, lincnt */
/* common /contrl/ fsi, fso, fpi, fpo, fbi, fbo, pbin, fmsg, fdebug */
/* common /contrl/ quant, nbits */
/* common /contrl/ nframe, nunsfm, iclip, maxosp, listl, lincnt */
/* Parameters/constants */
/* Voicing coefficient and Linear Discriminant Analysis variables:
*/
/* Max number of VDC's and VDC levels */
/* The following are not Fortran PARAMETER's, but they are */
/* initialized with DATA statements, and never modified. */
/* Actual number of VDC's and levels */
/* Local variables that need not be saved */
/* Note: */
/* VALUE(1) through VALUE(8) are assigned values, but VALUE(9) */
/* never is. Yet VALUE(9) is read in the loop that begins "DO I =
*/
/* 1, 9" below. I believe that this doesn't cause any problems in
*/
/* this subroutine, because all VDC(9,*) array elements are 0, and
*/
/* this is what is multiplied by VALUE(9) in all cases. Still, it
*/
/* would save a multiplication to change the loop to "DO I = 1, 8".
*/
/* Local state */
/* WARNING! */
/* VOICE, SFBUE, and SLBUE should be saved from one invocation to */
/* the next, but they are never given an initial value. */
/* Does Fortran 77 specify some default initial value, like 0, or */
/* is it undefined? If it is undefined, then this code should be */
/* corrected to specify an initial value. */
/* For VOICE, note that it is "shifted" in the statement that */
/* begins "IF (HALF .EQ. 1) THEN" below. Also, uninitialized */
/* values in the VOICE array can only affect entries in the VOIBUF
*/
/* array that are for the same frame, or for an older frame. Thus
*/
/* the effects of uninitialized values in VOICE cannot linger on */
/* for more than 2 or 3 frame times. */
/* For SFBUE and SLBUE, the effects of uninitialized values can */
/* linger on for many frame times, because their previous values */
/* are exponentially decayed. Thus it is more important to choose
*/
/* initial values for these variables. I would guess that a */
/* reasonable initial value for SFBUE is REF/16, the same as used */
/* for FBUE and OFBUE. Similarly, SLBUE can be initialized to */
/* REF/32, the same as for LBUE and OLBUE. */
/* These guessed initial values should be validated by re-running */
/* the modified program on some audio samples. */
/* Declare and initialize filters: */
dither = (&st->dither);
snr = (&st->snr);
maxmin = (&st->maxmin);
voice = (&st->voice[0]);
lbve = (&st->lbve);
lbue = (&st->lbue);
fbve = (&st->fbve);
fbue = (&st->fbue);
ofbue = (&st->ofbue);
olbue = (&st->olbue);
sfbue = (&st->sfbue);
slbue = (&st->slbue);
/* Parameter adjustments */
if (vwin) {
--vwin;
}
if (buflim) {
--buflim;
}
if (inbuf) {
inbuf_offset = buflim[1];
inbuf -= inbuf_offset;
}
if (lpbuf) {
lpbuf_offset = buflim[3];
lpbuf -= lpbuf_offset;
}
if (ivrc) {
--ivrc;
}
if (obound) {
--obound;
}
if (voibuf) {
--voibuf;
}
/* Function Body */
/* The following variables are saved from one invocation to the */
/* next, but are not initialized with DATA statements. This is */
/* acceptable, because FIRST is initialized ot .TRUE., and the */
/* first time that this subroutine is then called, they are all */
/* given initial values. */
/* SNR */
/* LBVE, LBUE, FBVE, FBUE, OFBUE, OLBUE */
/* MAXMIN is initialized on the first call, assuming that HALF */
/* .EQ. 1 on first call. This is how ANALYS calls this subroutine.
*/
/* Voicing Decision Parameter vector (* denotes zero coefficient): */
/* * MAXMIN */
/* LBE/LBVE */
/* ZC */
/* RC1 */
/* QS */
/* IVRC2 */
/* aR_B */
/* aR_F */
/* * LOG(LBE/LBVE) */
/* Define 2-D voicing decision coefficient vector according to the voicin
g*/
/* parameter order above. Each row (VDC vector) is optimized for a speci
fic*/
/* SNR. The last element of the vector is the constant. */
/* E ZC RC1 Qs IVRC2 aRb aRf c */
/* The VOICE array contains the result of the linear discriminant functio
n*/
/* (analog values). The VOIBUF array contains the hard-limited binary
*/
/* voicing decisions. The VOICE and VOIBUF arrays, according to FORTRAN
*/
/* memory allocation, are addressed as: */
/* (half-frame number, future-frame number) */
/* | Past | Present | Future1 | Future2 | */
/* | 1,0 | 2,0 | 1,1 | 2,1 | 1,2 | 2,2 | 1,3 | 2,3 | ---> time */
/* Update linear discriminant function history each frame: */
if (*half == 1) {
voice[0] = voice[2];
voice[1] = voice[3];
voice[2] = voice[4];
voice[3] = voice[5];
*maxmin = *maxamd / max(*minamd,1.f);
}
/* Calculate voicing parameters twice per frame: */
vparms_(&vwin[1], &inbuf[inbuf_offset], &lpbuf[lpbuf_offset], &buflim[1],
half, dither, mintau, &zc, &lbe, &fbe, &qs, &rc1, &ar_b__, &
ar_f__);
/* Estimate signal-to-noise ratio to select the appropriate VDC vector.
*/
/* The SNR is estimated as the running average of the ratio of the */
/* running average full-band voiced energy to the running average */
/* full-band unvoiced energy. SNR filter has gain of 63. */
r__1 = (*snr + *fbve / (real) max(*fbue,1)) * 63 / 64.f;
*snr = (real) i_nint(&r__1);
snr2 = *snr * *fbue / max(*lbue,1);
/* Quantize SNR to SNRL according to VDCL thresholds. */
snrl = 1;
i__1 = nvdcl - 1;
for (snrl = 1; snrl <= i__1; ++snrl) {
if (snr2 > vdcl[snrl - 1]) {
goto L69;
}
}
/* (Note: SNRL = NVDCL here) */
L69:
/* Linear discriminant voicing parameters: */
value[0] = *maxmin;
value[1] = (real) lbe / max(*lbve,1);
value[2] = (real) zc;
value[3] = rc1;
value[4] = qs;
value[5] = ivrc[2];
value[6] = ar_b__;
value[7] = ar_f__;
/* Evaluation of linear discriminant function: */
voice[*half + 3] = vdc[snrl * 10 - 1];
for (i__ = 1; i__ <= 8; ++i__) {
voice[*half + 3] += vdc[i__ + snrl * 10 - 11] * value[i__ - 1];
}
/* Classify as voiced if discriminant > 0, otherwise unvoiced */
/* Voicing decision for current half-frame: 1 = Voiced; 0 = Unvoiced */
if (voice[*half + 3] > 0.f) {
voibuf[*half + 6] = 1;
} else {
voibuf[*half + 6] = 0;
}
/* Skip voicing decision smoothing in first half-frame: */
/* Give a value to VSTATE, so that trace statements below will print
*/
/* a consistent value from one call to the next when HALF .EQ. 1. */
/* The value of VSTATE is not used for any other purpose when this is
*/
/* true. */
vstate = -1;
if (*half == 1) {
goto L99;
}
/* Voicing decision smoothing rules (override of linear combination): */
/* Unvoiced half-frames: At least two in a row. */
/* -------------------- */
/* Voiced half-frames: At least two in a row in one frame. */
/* ------------------- Otherwise at least three in a row. */
/* (Due to the way transition frames are encoded) */
/* In many cases, the discriminant function determines how to smooth. */
/* In the following chart, the decisions marked with a * may be overridden
.*/
/* Voicing override of transitions at onsets: */
/* If a V/UV or UV/V voicing decision transition occurs within one-half
*/
/* frame of an onset bounding a voicing window, then the transition is */
/* moved to occur at the onset. */
/* P 1F */
/* ----- ----- */
/* 0 0 0 0 */
/* 0 0 0* 1 (If there is an onset there) */
/* 0 0 1* 0* (Based on 2F and discriminant distance) */
/* 0 0 1 1 */
/* 0 1* 0 0 (Always) */
/* 0 1* 0* 1 (Based on discriminant distance) */
/* 0* 1 1 0* (Based on past, 2F, and discriminant distance) */
/* 0 1* 1 1 (If there is an onset there) */
/* 1 0* 0 0 (If there is an onset there) */
/* 1 0 0 1 */
/* 1 0* 1* 0 (Based on discriminant distance) */
/* 1 0* 1 1 (Always) */
/* 1 1 0 0 */
/* 1 1 0* 1* (Based on 2F and discriminant distance) */
/* 1 1 1* 0 (If there is an onset there) */
/* 1 1 1 1 */
/* Determine if there is an onset transition between P and 1F. */
/* OT (Onset Transition) is true if there is an onset between */
/* P and 1F but not after 1F. */
ot = ((obound[1] & 2) != 0 || obound[2] == 1) && (obound[3] & 1) == 0;
/* Multi-way dispatch on voicing decision history: */
vstate = (voibuf[3] << 3) + (voibuf[4] << 2) + (voibuf[5] << 1) + voibuf[
6];
switch (vstate + 1) {
case 1: goto L99;
case 2: goto L1;
case 3: goto L2;
case 4: goto L99;
case 5: goto L4;
case 6: goto L5;
case 7: goto L6;
case 8: goto L7;
case 9: goto L8;
case 10: goto L99;
case 11: goto L10;
case 12: goto L11;
case 13: goto L99;
case 14: goto L13;
case 15: goto L14;
case 16: goto L99;
}
L1:
if (ot && voibuf[7] == 1) {
voibuf[5] = 1;
}
goto L99;
L2:
if (voibuf[7] == 0 || voice[2] < -voice[3]) {
voibuf[5] = 0;
} else {
voibuf[6] = 1;
}
goto L99;
L4:
voibuf[4] = 0;
goto L99;
L5:
if (voice[1] < -voice[2]) {
voibuf[4] = 0;
} else {
voibuf[5] = 1;
}
goto L99;
/* VOIBUF(2,0) must be 0 */
L6:
if (voibuf[1] == 1 || voibuf[7] == 1 || voice[3] > voice[0]) {
voibuf[6] = 1;
} else {
voibuf[3] = 1;
}
goto L99;
L7:
if (ot) {
voibuf[4] = 0;
}
goto L99;
L8:
if (ot) {
voibuf[4] = 1;
}
goto L99;
L10:
if (voice[2] < -voice[1]) {
voibuf[5] = 0;
} else {
voibuf[4] = 1;
}
goto L99;
L11:
voibuf[4] = 1;
goto L99;
L13:
if (voibuf[7] == 0 && voice[3] < -voice[2]) {
voibuf[6] = 0;
} else {
voibuf[5] = 1;
}
goto L99;
L14:
if (ot && voibuf[7] == 0) {
voibuf[5] = 0;
}
/* GOTO 99 */
L99:
/* Now update parameters: */
/* ---------------------- */
/* During unvoiced half-frames, update the low band and full band unvoice
d*/
/* energy estimates (LBUE and FBUE) and also the zero crossing */
/* threshold (DITHER). (The input to the unvoiced energy filters is */
/* restricted to be less than 10dB above the previous inputs of the */
/* filters.) */
/* During voiced half-frames, update the low-pass (LBVE) and all-pass */
/* (FBVE) voiced energy estimates. */
if (voibuf[*half + 6] == 0) {
/* Computing MIN */
i__1 = fbe, i__2 = *ofbue * 3;
r__1 = (*sfbue * 63 + (min(i__1,i__2) << 3)) / 64.f;
*sfbue = i_nint(&r__1);
*fbue = *sfbue / 8;
*ofbue = fbe;
/* Computing MIN */
i__1 = lbe, i__2 = *olbue * 3;
r__1 = (*slbue * 63 + (min(i__1,i__2) << 3)) / 64.f;
*slbue = i_nint(&r__1);
*lbue = *slbue / 8;
*olbue = lbe;
} else {
r__1 = (*lbve * 63 + lbe) / 64.f;
*lbve = i_nint(&r__1);
r__1 = (*fbve * 63 + fbe) / 64.f;
*fbve = i_nint(&r__1);
}
/* Set dither threshold to yield proper zero crossing rates in the */
/* presence of low frequency noise and low level signal input. */
/* NOTE: The divisor is a function of REF, the expected energies. */
/* Computing MIN */
/* Computing MAX */
r__2 = sqrt((real) (*lbue * *lbve)) * 64 / 3000;
r__1 = max(r__2,1.f);
*dither = min(r__1,20.f);
/* Voicing decisions are returned in VOIBUF. */
return 0;
} /* voicin_ */
integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer
*ilo, integer *ihi, integer *lwork)
{
/* System generated locals */
integer ret_val, i__1, i__2;
real r__1;
/* Builtin functions */
double log(doublereal);
integer i_nint(real *);
/* Local variables */
integer nh, ns;
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
if (*ispec == 15 || *ispec == 13 || *ispec == 16) {
/* ==== Set the number simultaneous shifts ==== */
nh = *ihi - *ilo + 1;
ns = 2;
if (nh >= 30) {
ns = 4;
}
if (nh >= 60) {
ns = 10;
}
if (nh >= 150) {
/* Computing MAX */
r__1 = log((real) nh) / log(2.f);
i__1 = 10, i__2 = nh / i_nint(&r__1);
ns = max(i__1,i__2);
}
if (nh >= 590) {
ns = 64;
}
if (nh >= 3000) {
ns = 128;
}
if (nh >= 6000) {
ns = 256;
}
/* Computing MAX */
i__1 = 2, i__2 = ns - ns % 2;
ns = max(i__1,i__2);
}
if (*ispec == 12) {
/* ===== Matrices of order smaller than NMIN get sent */
/* . to LAHQR, the classic double shift algorithm. */
/* . This must be at least 11. ==== */
ret_val = 11;
} else if (*ispec == 14) {
/* ==== INIBL: skip a multi-shift qr iteration and */
/* . whenever aggressive early deflation finds */
/* . at least (NIBBLE*(window size)/100) deflations. ==== */
ret_val = 14;
} else if (*ispec == 15) {
/* ==== NSHFTS: The number of simultaneous shifts ===== */
ret_val = ns;
} else if (*ispec == 13) {
/* ==== NW: deflation window size. ==== */
if (nh <= 500) {
ret_val = ns;
} else {
ret_val = ns * 3 / 2;
}
} else if (*ispec == 16) {
/* ==== IACC22: Whether to accumulate reflections */
/* . before updating the far-from-diagonal elements */
/* . and whether to use 2-by-2 block structure while */
/* . doing it. A small amount of work could be saved */
/* . by making this choice dependent also upon the */
/* . NH=IHI-ILO+1. */
ret_val = 0;
if (ns >= 14) {
ret_val = 1;
}
if (ns >= 14) {
ret_val = 2;
}
} else {
/* ===== invalid value of ispec ===== */
ret_val = -1;
}
/* ==== End of IPARMQ ==== */
return ret_val;
} /* iparmq_ */
integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer
*ilo, integer *ihi, integer *lwork)
{
/* System generated locals */
integer ret_val, i__1, i__2;
real r__1;
/* Local variables */
integer nh, ns;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* This program sets problem and machine dependent parameters */
/* useful for xHSEQR and its subroutines. It is called whenever */
/* ILAENV is called with 12 <= ISPEC <= 16 */
/* Arguments */
/* ========= */
/* ISPEC (input) integer scalar */
/* ISPEC specifies which tunable parameter IPARMQ should */
/* return. */
/* ISPEC=12: (INMIN) Matrices of order nmin or less */
/* are sent directly to xLAHQR, the implicit */
/* double shift QR algorithm. NMIN must be */
/* at least 11. */
/* ISPEC=13: (INWIN) Size of the deflation window. */
/* This is best set greater than or equal to */
/* the number of simultaneous shifts NS. */
/* Larger matrices benefit from larger deflation */
/* windows. */
/* ISPEC=14: (INIBL) Determines when to stop nibbling and */
/* invest in an (expensive) multi-shift QR sweep. */
/* If the aggressive early deflation subroutine */
/* finds LD converged eigenvalues from an order */
/* NW deflation window and LD.GT.(NW*NIBBLE)/100, */
/* then the next QR sweep is skipped and early */
/* deflation is applied immediately to the */
/* remaining active diagonal block. Setting */
/* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a */
/* multi-shift QR sweep whenever early deflation */
/* finds a converged eigenvalue. Setting */
/* IPARMQ(ISPEC=14) greater than or equal to 100 */
/* prevents TTQRE from skipping a multi-shift */
/* QR sweep. */
/* ISPEC=15: (NSHFTS) The number of simultaneous shifts in */
/* a multi-shift QR iteration. */
/* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the */
/* following meanings. */
/* 0: During the multi-shift QR sweep, */
/* xLAQR5 does not accumulate reflections and */
/* does not use matrix-matrix multiply to */
/* update the far-from-diagonal matrix */
/* entries. */
/* 1: During the multi-shift QR sweep, */
/* xLAQR5 and/or xLAQRaccumulates reflections and uses */
/* matrix-matrix multiply to update the */
/* far-from-diagonal matrix entries. */
/* 2: During the multi-shift QR sweep. */
/* xLAQR5 accumulates reflections and takes */
/* advantage of 2-by-2 block structure during */
/* matrix-matrix multiplies. */
/* (If xTRMM is slower than xGEMM, then */
/* IPARMQ(ISPEC=16)=1 may be more efficient than */
/* IPARMQ(ISPEC=16)=2 despite the greater level of */
/* arithmetic work implied by the latter choice.) */
/* NAME (input) character string */
/* Name of the calling subroutine */
/* OPTS (input) character string */
/* This is a concatenation of the string arguments to */
/* TTQRE. */
/* N (input) integer scalar */
/* N is the order of the Hessenberg matrix H. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular */
/* in rows and columns 1:ILO-1 and IHI+1:N. */
/* LWORK (input) integer scalar */
/* The amount of workspace available. */
/* Further Details */
/* =============== */
/* Little is known about how best to choose these parameters. */
/* It is possible to use different values of the parameters */
/* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. */
/* It is probably best to choose different parameters for */
/* different matrices and different parameters at different */
/* times during the iteration, but this has not been */
/* implemented --- yet. */
/* The best choices of most of the parameters depend */
/* in an ill-understood way on the relative execution */
/* rate of xLAQR3 and xLAQR5 and on the nature of each */
/* particular eigenvalue problem. Experiment may be the */
/* only practical way to determine which choices are most */
/* effective. */
/* Following is a list of default values supplied by IPARMQ. */
/* These defaults may be adjusted in order to attain better */
/* performance in any particular computational environment. */
/* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. */
/* Default: 75. (Must be at least 11.) */
/* IPARMQ(ISPEC=13) Recommended deflation window size. */
/* This depends on ILO, IHI and NS, the */
/* number of simultaneous shifts returned */
/* by IPARMQ(ISPEC=15). The default for */
/* (IHI-ILO+1).LE.500 is NS. The default */
/* for (IHI-ILO+1).GT.500 is 3*NS/2. */
/* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. */
/* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. */
/* a multi-shift QR iteration. */
/* 0 30 NS = 2+ */
/* 30 60 NS = 4+ */
/* 60 150 NS = 10 */
/* 150 590 NS = ** */
/* 590 3000 NS = 64 */
/* 3000 6000 NS = 128 */
/* 6000 infinity NS = 256 */
/* (+) By default matrices of this order are */
/* passed to the implicit double shift routine */
/* xLAHQR. See IPARMQ(ISPEC=12) above. These */
/* values of NS are used only in case of a rare */
/* xLAHQR failure. */
/* (**) The asterisks (**) indicate an ad-hoc */
/* function increasing from 10 to 64. */
/* IPARMQ(ISPEC=16) Select structured matrix multiply. */
/* (See ISPEC=16 above for details.) */
/* Default: 3. */
/* ================================================================ */
if (*ispec == 15 || *ispec == 13 || *ispec == 16) {
/* ==== Set the number simultaneous shifts ==== */
nh = *ihi - *ilo + 1;
ns = 2;
if (nh >= 30) {
ns = 4;
}
if (nh >= 60) {
ns = 10;
}
if (nh >= 150) {
/* Computing MAX */
r__1 = log((real) nh) / log(2.f);
i__1 = 10, i__2 = nh / i_nint(&r__1);
ns = max(i__1,i__2);
}
if (nh >= 590) {
ns = 64;
}
if (nh >= 3000) {
ns = 128;
}
if (nh >= 6000) {
ns = 256;
}
/* Computing MAX */
i__1 = 2, i__2 = ns - ns % 2;
ns = max(i__1,i__2);
}
if (*ispec == 12) {
/* ===== Matrices of order smaller than NMIN get sent */
/* . to xLAHQR, the classic double shift algorithm. */
/* . This must be at least 11. ==== */
ret_val = 75;
} else if (*ispec == 14) {
/* ==== INIBL: skip a multi-shift qr iteration and */
/* . whenever aggressive early deflation finds */
/* . at least (NIBBLE*(window size)/100) deflations. ==== */
ret_val = 14;
} else if (*ispec == 15) {
/* ==== NSHFTS: The number of simultaneous shifts ===== */
ret_val = ns;
} else if (*ispec == 13) {
/* ==== NW: deflation window size. ==== */
if (nh <= 500) {
ret_val = ns;
} else {
ret_val = ns * 3 / 2;
}
} else if (*ispec == 16) {
/* ==== IACC22: Whether to accumulate reflections */
/* . before updating the far-from-diagonal elements */
/* . and whether to use 2-by-2 block structure while */
/* . doing it. A small amount of work could be saved */
/* . by making this choice dependent also upon the */
/* . NH=IHI-ILO+1. */
ret_val = 0;
if (ns >= 14) {
ret_val = 1;
}
if (ns >= 14) {
ret_val = 2;
}
} else {
/* ===== invalid value of ispec ===== */
ret_val = -1;
}
/* ==== End of IPARMQ ==== */
return ret_val;
} /* iparmq_ */
int slaqps_(int *m, int *n, int *offset, int
*nb, int *kb, float *a, int *lda, int *jpvt, float *tau,
float *vn1, float *vn2, float *auxv, float *f, int *ldf)
{
/* System generated locals */
int a_dim1, a_offset, f_dim1, f_offset, i__1, i__2;
float r__1, r__2;
/* Builtin functions */
double sqrt(double);
int i_nint(float *);
/* Local variables */
int j, k, rk;
float akk;
int pvt;
float temp, temp2;
extern double snrm2_(int *, float *, int *);
float tol3z;
extern int sgemm_(char *, char *, int *, int *,
int *, float *, float *, int *, float *, int *, float *,
float *, int *);
int itemp;
extern int sgemv_(char *, int *, int *, float *,
float *, int *, float *, int *, float *, float *, int *), sswap_(int *, float *, int *, float *, int *);
extern double slamch_(char *);
int lsticc;
extern int isamax_(int *, float *, int *);
extern int slarfp_(int *, float *, float *, int *,
float *);
int lastrk;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAQPS computes a step of QR factorization with column pivoting */
/* of a float M-by-N matrix A by using Blas-3. It tries to factorize */
/* NB columns from A starting from the row OFFSET+1, and updates all */
/* of the matrix with Blas-3 xGEMM. */
/* In some cases, due to catastrophic cancellations, it cannot */
/* factorize NB columns. Hence, the actual number of factorized */
/* columns is returned in KB. */
/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* 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 */
/* OFFSET (input) INTEGER */
/* The number of rows of A that have been factorized in */
/* previous steps. */
/* NB (input) INTEGER */
/* The number of columns to factorize. */
/* KB (output) INTEGER */
/* The number of columns actually factorized. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */
/* factor obtained and block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */
/* been updated. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* JPVT(I) = K <==> Column K of the full matrix A has been */
/* permuted into position I in AP. */
/* TAU (output) REAL array, dimension (KB) */
/* The scalar factors of the elementary reflectors. */
/* VN1 (input/output) REAL array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) REAL array, dimension (N) */
/* The vector with the exact column norms. */
/* AUXV (input/output) REAL array, dimension (NB) */
/* Auxiliar vector. */
/* F (input/output) REAL array, dimension (LDF,NB) */
/* Matrix F' = L*Y'*A. */
/* LDF (input) INTEGER */
/* The leading dimension of the array F. LDF >= MAX(1,N). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* Partial column norm updating strategy modified by */
/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
/* University of Zagreb, Croatia. */
/* June 2006. */
/* For more details see LAPACK Working Note 176. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--auxv;
f_dim1 = *ldf;
f_offset = 1 + f_dim1;
f -= f_offset;
/* Function Body */
/* Computing MIN */
i__1 = *m, i__2 = *n + *offset;
lastrk = MIN(i__1,i__2);
lsticc = 0;
k = 0;
tol3z = sqrt(slamch_("Epsilon"));
/* Beginning of while loop. */
L10:
if (k < *nb && lsticc == 0) {
++k;
rk = *offset + k;
/* Determine ith pivot column and swap if necessary */
i__1 = *n - k + 1;
pvt = k - 1 + isamax_(&i__1, &vn1[k], &c__1);
if (pvt != k) {
sswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
sswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[k];
jpvt[k] = itemp;
vn1[pvt] = vn1[k];
vn2[pvt] = vn2[k];
}
/* Apply previous Householder reflectors to column K: */
/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */
if (k > 1) {
i__1 = *m - rk + 1;
i__2 = k - 1;
sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[rk + a_dim1], lda,
&f[k + f_dim1], ldf, &c_b9, &a[rk + k * a_dim1], &c__1);
}
/* Generate elementary reflector H(k). */
if (rk < *m) {
i__1 = *m - rk + 1;
slarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], &
c__1, &tau[k]);
} else {
slarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, &
tau[k]);
}
akk = a[rk + k * a_dim1];
a[rk + k * a_dim1] = 1.f;
/* Compute Kth column of F: */
/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */
if (k < *n) {
i__1 = *m - rk + 1;
i__2 = *n - k;
sgemv_("Transpose", &i__1, &i__2, &tau[k], &a[rk + (k + 1) *
a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b16, &f[k +
1 + k * f_dim1], &c__1);
}
/* Padding F(1:K,K) with zeros. */
i__1 = k;
for (j = 1; j <= i__1; ++j) {
f[j + k * f_dim1] = 0.f;
/* L20: */
}
/* Incremental updating of F: */
/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */
/* *A(RK:M,K). */
if (k > 1) {
i__1 = *m - rk + 1;
i__2 = k - 1;
r__1 = -tau[k];
sgemv_("Transpose", &i__1, &i__2, &r__1, &a[rk + a_dim1], lda, &a[
rk + k * a_dim1], &c__1, &c_b16, &auxv[1], &c__1);
i__1 = k - 1;
sgemv_("No transpose", n, &i__1, &c_b9, &f[f_dim1 + 1], ldf, &
auxv[1], &c__1, &c_b9, &f[k * f_dim1 + 1], &c__1);
}
/* Update the current row of A: */
/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */
if (k < *n) {
i__1 = *n - k;
sgemv_("No transpose", &i__1, &k, &c_b8, &f[k + 1 + f_dim1], ldf,
&a[rk + a_dim1], lda, &c_b9, &a[rk + (k + 1) * a_dim1],
lda);
}
/* Update partial column norms. */
if (rk < lastrk) {
i__1 = *n;
for (j = k + 1; j <= i__1; ++j) {
if (vn1[j] != 0.f) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
temp = (r__1 = a[rk + j * a_dim1], ABS(r__1)) / vn1[j];
/* Computing MAX */
r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp);
temp = MAX(r__1,r__2);
/* Computing 2nd power */
r__1 = vn1[j] / vn2[j];
temp2 = temp * (r__1 * r__1);
if (temp2 <= tol3z) {
vn2[j] = (float) lsticc;
lsticc = j;
} else {
vn1[j] *= sqrt(temp);
}
}
/* L30: */
}
}
a[rk + k * a_dim1] = akk;
/* End of while loop. */
goto L10;
}
*kb = k;
rk = *offset + *kb;
/* Apply the block reflector to the rest of the matrix: */
/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */
/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */
/* Computing MIN */
i__1 = *n, i__2 = *m - *offset;
if (*kb < MIN(i__1,i__2)) {
i__1 = *m - rk;
i__2 = *n - *kb;
sgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b8, &a[rk +
1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b9, &a[rk + 1
+ (*kb + 1) * a_dim1], lda);
}
/* Recomputation of difficult columns. */
L40:
if (lsticc > 0) {
itemp = i_nint(&vn2[lsticc]);
i__1 = *m - rk;
vn1[lsticc] = snrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1);
/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */
/* SNRM2 does not fail on vectors with norm below the value of */
/* SQRT(DLAMCH('S')) */
vn2[lsticc] = vn1[lsticc];
lsticc = itemp;
goto L40;
}
return 0;
/* End of SLAQPS */
} /* slaqps_ */
/* Subroutine */ int claqps_(integer *m, integer *n, integer *offset, integer
*nb, integer *kb, complex *a, integer *lda, integer *jpvt, complex *
tau, real *vn1, real *vn2, complex *auxv, complex *f, integer *ldf)
{
/* System generated locals */
integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2, i__3;
real r__1, r__2;
complex q__1;
/* Local variables */
integer j, k, rk;
complex akk;
integer pvt;
real temp, temp2, tol3z;
integer itemp;
integer lsticc;
integer lastrk;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CLAQPS computes a step of QR factorization with column pivoting */
/* of a complex M-by-N matrix A by using Blas-3. It tries to factorize */
/* NB columns from A starting from the row OFFSET+1, and updates all */
/* of the matrix with Blas-3 xGEMM. */
/* In some cases, due to catastrophic cancellations, it cannot */
/* factorize NB columns. Hence, the actual number of factorized */
/* columns is returned in KB. */
/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* 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 */
/* OFFSET (input) INTEGER */
/* The number of rows of A that have been factorized in */
/* previous steps. */
/* NB (input) INTEGER */
/* The number of columns to factorize. */
/* KB (output) INTEGER */
/* The number of columns actually factorized. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */
/* factor obtained and block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */
/* been updated. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* JPVT(I) = K <==> Column K of the full matrix A has been */
/* permuted into position I in AP. */
/* TAU (output) COMPLEX array, dimension (KB) */
/* The scalar factors of the elementary reflectors. */
/* VN1 (input/output) REAL array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) REAL array, dimension (N) */
/* The vector with the exact column norms. */
/* AUXV (input/output) COMPLEX array, dimension (NB) */
/* Auxiliar vector. */
/* F (input/output) COMPLEX array, dimension (LDF,NB) */
/* Matrix F' = L*Y'*A. */
/* LDF (input) INTEGER */
/* The leading dimension of the array F. LDF >= max(1,N). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* Partial column norm updating strategy modified by */
/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
/* University of Zagreb, Croatia. */
/* June 2006. */
/* For more details see LAPACK Working Note 176. */
/* ===================================================================== */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--auxv;
f_dim1 = *ldf;
f_offset = 1 + f_dim1;
f -= f_offset;
/* Function Body */
/* Computing MIN */
i__1 = *m, i__2 = *n + *offset;
lastrk = min(i__1,i__2);
lsticc = 0;
k = 0;
tol3z = sqrt(slamch_("Epsilon"));
/* Beginning of while loop. */
L10:
if (k < *nb && lsticc == 0) {
++k;
rk = *offset + k;
/* Determine ith pivot column and swap if necessary */
i__1 = *n - k + 1;
pvt = k - 1 + isamax_(&i__1, &vn1[k], &c__1);
if (pvt != k) {
cswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
i__1 = k - 1;
cswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[k];
jpvt[k] = itemp;
vn1[pvt] = vn1[k];
vn2[pvt] = vn2[k];
}
/* Apply previous Householder reflectors to column K: */
/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */
if (k > 1) {
i__1 = k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * f_dim1;
r_cnjg(&q__1, &f[k + j * f_dim1]);
f[i__2].r = q__1.r, f[i__2].i = q__1.i;
}
i__1 = *m - rk + 1;
i__2 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__1, &i__2, &q__1, &a[rk + a_dim1], lda,
&f[k + f_dim1], ldf, &c_b2, &a[rk + k * a_dim1], &c__1);
i__1 = k - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * f_dim1;
r_cnjg(&q__1, &f[k + j * f_dim1]);
f[i__2].r = q__1.r, f[i__2].i = q__1.i;
}
}
/* Generate elementary reflector H(k). */
if (rk < *m) {
i__1 = *m - rk + 1;
clarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], &
c__1, &tau[k]);
} else {
clarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, &
tau[k]);
}
i__1 = rk + k * a_dim1;
akk.r = a[i__1].r, akk.i = a[i__1].i;
i__1 = rk + k * a_dim1;
a[i__1].r = 1.f, a[i__1].i = 0.f;
/* Compute Kth column of F: */
/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */
if (k < *n) {
i__1 = *m - rk + 1;
i__2 = *n - k;
cgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[rk + (k +
1) * a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b1, &f[
k + 1 + k * f_dim1], &c__1);
}
/* Padding F(1:K,K) with zeros. */
i__1 = k;
for (j = 1; j <= i__1; ++j) {
i__2 = j + k * f_dim1;
f[i__2].r = 0.f, f[i__2].i = 0.f;
}
/* Incremental updating of F: */
/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */
/* *A(RK:M,K). */
if (k > 1) {
i__1 = *m - rk + 1;
i__2 = k - 1;
i__3 = k;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cgemv_("Conjugate transpose", &i__1, &i__2, &q__1, &a[rk + a_dim1]
, lda, &a[rk + k * a_dim1], &c__1, &c_b1, &auxv[1], &c__1);
i__1 = k - 1;
cgemv_("No transpose", n, &i__1, &c_b2, &f[f_dim1 + 1], ldf, &
auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1);
}
/* Update the current row of A: */
/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, &
q__1, &a[rk + a_dim1], lda, &f[k + 1 + f_dim1], ldf, &
c_b2, &a[rk + (k + 1) * a_dim1], lda);
}
/* Update partial column norms. */
if (rk < lastrk) {
i__1 = *n;
for (j = k + 1; j <= i__1; ++j) {
if (vn1[j] != 0.f) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
temp = c_abs(&a[rk + j * a_dim1]) / vn1[j];
/* Computing MAX */
r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp);
temp = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = vn1[j] / vn2[j];
temp2 = temp * (r__1 * r__1);
if (temp2 <= tol3z) {
vn2[j] = (real) lsticc;
lsticc = j;
} else {
vn1[j] *= sqrt(temp);
}
}
}
}
i__1 = rk + k * a_dim1;
a[i__1].r = akk.r, a[i__1].i = akk.i;
/* End of while loop. */
goto L10;
}
*kb = k;
rk = *offset + *kb;
/* Apply the block reflector to the rest of the matrix: */
/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */
/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */
/* Computing MIN */
i__1 = *n, i__2 = *m - *offset;
if (*kb < min(i__1,i__2)) {
i__1 = *m - rk;
i__2 = *n - *kb;
q__1.r = -1.f, q__1.i = -0.f;
cgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &q__1,
&a[rk + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, &
a[rk + 1 + (*kb + 1) * a_dim1], lda);
}
/* Recomputation of difficult columns. */
L60:
if (lsticc > 0) {
itemp = i_nint(&vn2[lsticc]);
i__1 = *m - rk;
vn1[lsticc] = scnrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1);
/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */
/* SNRM2 does not fail on vectors with norm below the value of */
/* SQRT(DLAMCH('S')) */
vn2[lsticc] = vn1[lsticc];
lsticc = itemp;
goto L60;
}
return 0;
/* End of CLAQPS */
} /* claqps_ */
integer kb3calgms_(integer *calb, integer *idir, integer *nval, integer *
iband, integer *ibuf)
{
/* Initialized data */
static integer ivflg = 0;
static integer lastyp = -1;
static integer laschan = -1;
static integer lasband = -1;
/* System generated locals */
integer ret_val;
real r__1, r__2;
static integer equiv_1[1024];
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), i_nint(real *);
/* Local variables */
static integer i__, k;
extern integer rdcalgmskb3_(integer *, integer *, integer *, integer *);
#define itab (equiv_1)
static real xalb;
extern real vplancgmskb3_(real *, integer *, integer *, integer *);
static real xrad;
static integer ichan, irtab;
extern /* Subroutine */ int edestX_(char *, integer *, ftnlen);
#define itabv (equiv_1)
#define jtabv ((integer *)&debuggmskb3_2 + 2049)
static integer ibrit, ivisn;
static real xtemp;
extern integer brkval_(real *);
extern /* Subroutine */ int gryscl_(real *, integer *), mpixtb_(integer *,
integer *, integer *, integer *, integer *);
/* 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 */
/* Number of pixels to process from inpu */
/* Band number (not needed for GMS-4) */
/* (will contain converted values at */
/* I/O array containing pixels to be mod */
/* (defines NUMAREAOPTIONS) */
/* Global declarations for McIDAS a */
/* 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 */
/* Calibration parameters for conve */
/* Common block for BRKSET table type */
/* Calibration type for breakpoint */
/* to generate the ITAB/ITABR arr */
/* Identifies method used by RD_CAL */
/* produced by RD_CAL function */
/* and returned as ITAB. It is */
/* renamed ITABR here to avoid do */
/* defining the array. */
/* stage 1 conversion table */
/* to the input DN value: either */
/* albedo, temperature, or radian */
/* (this quantity is converted to */
/* scaled integer appearing in JT */
/* Real physical quantity correspon */
/* produced by KBX_CAL here */
/* (generates conversion transfer */
/* function table from albedo or */
/* temperature to scaled integer */
/* output, using BRKVAL and MPIX */
/* stage 2 conversion table */
/* visible sensors are identifie */
/* by IVISN=1,2,3,4. For IR ban */
/* the value of IVISN=1 always, */
/* only 1/4 of the table is used */
/* JTAB array for visible channel w */
/* Provides values from breakpoint */
/* Planck function */
/* Sets up the ITAB lookup table */
/* index variable */
/* index variable */
/* (high BRIT on screen means low */
/* Output of GRYSCAL TEMP-->BRIT co */
/* *** may have to increase to */
/* for GMS-5 *** */
/* visible or IR channel designator */
/* (0 means unknown or undefined */
/* Visible sensor designator 0-4 */
/* (returned ALB output is */
/* in %, i.e. albedo*100.) */
/* true albedo 0.000-1.000 */
/* true absolute temperature (Kelvi */
/* Radiance (mW/m**2/ster/cm**-1) */
/* Identifies current channel as IR */
/* produced by RD_CAL function */
/* (generates a calibrated transf */
/* function table from the physi */
/* conversion formulas -- input */
/* index is a function of DN val */
/* and IVISN, output is either a */
/* albedo or is in degrees Kelvi */
/* stage 1 conversion table */
/* visible sensors are identifie */
/* by IVISN=1,2,3,4 */
/* ITAB array for visible channel w */
/* if set to 1 means visible data */
/* JTYPE for which tables are curre */
/* ICHAN for which tables are curre */
/* IBAND for which tables are curre */
/* Parameter adjustments */
--ibuf;
--idir;
--calb;
/* Function Body */
if (idir[3] == 12) {
ichan = 0;
irtab = 0;
} else if (idir[3] == 13) {
ichan = 1;
irtab = 1;
} else if (idir[3] == 82 && *iband == 1) {
ichan = 0;
irtab = 0;
} else if (idir[3] == 82 && *iband == 2) {
ichan = 1;
irtab = 1;
} else if (idir[3] == 82 && *iband == 8) {
ichan = 1;
irtab = 1;
} else if (idir[3] == 83 && *iband == 1) {
ichan = 0;
irtab = 0;
} else if (idir[3] == 83 && *iband == 2) {
ichan = 1;
irtab = 1;
} else if (idir[3] == 83 && *iband == 3) {
ichan = 1;
irtab = 1;
} else if (idir[3] == 83 && *iband == 4) {
ichan = 1;
irtab = 1;
} else if (idir[3] == 83 && *iband == 8) {
ichan = 1;
irtab = 1;
} else {
edestX_("KBX_CAL: Unrecognized data band or SS", &c__0, (ftnlen)37);
ret_val = -1;
}
if (*iband == 1) {
if (calb[2] == 1819017216) {
ivisn = 1;
} else if (calb[2] == -1263271936) {
ivisn = 2;
} else if (calb[2] == -656932864) {
ivisn = 3;
} else if (calb[2] == -50593792) {
ivisn = 4;
} else {
ivisn = 1;
}
} else {
ivisn = 1;
}
if (s_cmp(brkpntgmskb3_1.caltyp, "BRIT", (ftnlen)4, (ftnlen)4) == 0 &&
gmsxxgmskb3_1.jtype == 4 && lastyp != gmsxxgmskb3_1.jtype ||
s_cmp(brkpntgmskb3_1.caltyp, "RAW", (ftnlen)4, (ftnlen)3) == 0 &&
gmsxxgmskb3_1.jtype == 7 && lastyp != gmsxxgmskb3_1.jtype) {
for (i__ = 1; i__ <= 256; ++i__) {
r__1 = (real) (i__ - 1);
debuggmskb3_2.jtab[i__ - 1] = brkval_(&r__1);
}
lastyp = gmsxxgmskb3_1.jtype;
ret_val = 0;
} else if (gmsxxgmskb3_1.jtype == 5 && lastyp != gmsxxgmskb3_1.jtype) {
for (i__ = 1; i__ <= 256; ++i__) {
debuggmskb3_2.jtab[i__ - 1] = i__ - 1;
}
lastyp = gmsxxgmskb3_1.jtype;
ret_val = 0;
} else if (lastyp != gmsxxgmskb3_1.jtype || laschan != ichan || lasband !=
*iband) {
if (ichan == 0 && (ivflg == 0 || lastyp != gmsxxgmskb3_1.jtype ||
lasband != *iband)) {
laschan = ichan;
lasband = *iband;
if (rdcalgmskb3_(&calb[1], &idir[1], iband, itab) != 0) {
edestX_("KBX_CAL: RD_CAL call failed.", &c__0, (ftnlen)28);
ret_val = -1;
}
ivflg = 1;
if (gmsxxgmskb3_1.jtype == 2 || gmsxxgmskb3_1.jtype == 4 ||
gmsxxgmskb3_1.jtype == 7) {
for (i__ = 1; i__ <= 1024; ++i__) {
xalb = itab[i__ - 1] / 1e3f;
debuggmskb3_2.xtab[i__ - 1] = xalb;
if (s_cmp(brkpntgmskb3_1.caltyp, "ALB", (ftnlen)4, (
ftnlen)3) == 0 && gmsxxgmskb3_1.jtype != 2) {
/* MODB */
r__1 = (xalb + .5f) / 10.f;
debuggmskb3_2.jtab[i__ - 1] = brkval_(&r__1);
} else if (gmsxxgmskb3_1.jtype == 2) {
/* ALB */
debuggmskb3_2.jtab[i__ - 1] = (integer) (xalb + .5f);
}
}
lastyp = gmsxxgmskb3_1.jtype;
}
if (gmsxxgmskb3_1.jtype == 6 || gmsxxgmskb3_1.jtype == 7) {
if (s_cmp(brkpntgmskb3_1.caltyp, "BRIT", (ftnlen)4, (ftnlen)4)
== 0 && gmsxxgmskb3_1.jtype != 6) {
/* MODB */
for (i__ = 1; i__ <= 256; ++i__) {
r__1 = (real) itab[i__ - 1] / 4e3f;
k = brkval_(&r__1);
debuggmskb3_2.jtab[i__ - 1] = k;
debuggmskb3_2.jtab[i__ + 255] = k;
debuggmskb3_2.jtab[i__ + 511] = k;
debuggmskb3_2.jtab[i__ + 767] = k;
}
} else if (gmsxxgmskb3_1.jtype == 6) {
/* BRIT */
for (i__ = 1; i__ <= 1024; ++i__) {
debuggmskb3_2.jtab[i__ - 1] = itab[i__ - 1] / 4e3f;
debuggmskb3_2.jtab[i__ - 1] = debuggmskb3_2.jtab[i__
- 1] * .80000000000000004f + 35.f;
}
}
ivisn = 1;
lastyp = gmsxxgmskb3_1.jtype;
}
} else if (ichan == 1 && lastyp != gmsxxgmskb3_1.jtype || lasband != *
iband) {
laschan = ichan;
lasband = *iband;
if (rdcalgmskb3_(&calb[1], &idir[1], iband, itab) != 0) {
edestX_("KBX_CAL: RD_CAL call failed.", &c__0, (ftnlen)28);
ret_val = -1;
}
ivflg = 1;
if (gmsxxgmskb3_1.jtype == 1 || gmsxxgmskb3_1.jtype == 4 ||
gmsxxgmskb3_1.jtype == 7) {
for (i__ = 1; i__ <= 256; ++i__) {
if (s_cmp(brkpntgmskb3_1.caltyp, "TEMP", (ftnlen)4, (
ftnlen)4) == 0 && gmsxxgmskb3_1.jtype != 1) {
/* MODB */
r__1 = itab[i__ - 1] / 1e3f;
debuggmskb3_2.jtab[i__ - 1] = brkval_(&r__1);
} else if (gmsxxgmskb3_1.jtype == 1) {
/* TEMP */
debuggmskb3_2.jtab[i__ - 1] = (integer) (itab[i__ - 1]
/ 100.f + .5f);
}
xtemp = (real) itab[i__ - 1] / 1e3f;
debuggmskb3_2.xtab[i__ - 1] = xtemp;
}
ivisn = 1;
}
if (gmsxxgmskb3_1.jtype == 3 || gmsxxgmskb3_1.jtype == 4 ||
gmsxxgmskb3_1.jtype == 7) {
for (i__ = 1; i__ <= 256; ++i__) {
if (s_cmp(brkpntgmskb3_1.caltyp, "RAD ", (ftnlen)4, (
ftnlen)4) == 0 && gmsxxgmskb3_1.jtype != 3) {
/* MODB */
r__2 = itab[i__ - 1] / 1e3f;
r__1 = vplancgmskb3_(&r__2, &i__, &idir[3], iband) *
10;
debuggmskb3_2.jtab[i__ - 1] = brkval_(&r__1);
} else if (gmsxxgmskb3_1.jtype == 3) {
/* RAD */
r__2 = itab[i__ - 1] / 1e3f;
r__1 = vplancgmskb3_(&r__2, &i__, &idir[3], iband) *
100.f;
debuggmskb3_2.jtab[i__ - 1] = i_nint(&r__1);
}
xtemp = (real) itab[i__ - 1] / 1e3f;
xrad = vplancgmskb3_(&xtemp, &i__, &idir[3], iband);
debuggmskb3_2.xtab[i__ - 1] = xrad;
}
ivisn = 1;
}
if (gmsxxgmskb3_1.jtype == 6 || gmsxxgmskb3_1.jtype == 7) {
lastyp = gmsxxgmskb3_1.jtype;
for (i__ = 1; i__ <= 256; ++i__) {
xtemp = (real) itab[i__ - 1] / 1e3f;
gryscl_(&xtemp, &ibrit);
debuggmskb3_2.xtab[i__ - 1] = (real) ibrit;
if (s_cmp(brkpntgmskb3_1.caltyp, "BRIT", (ftnlen)4, (
ftnlen)4) == 0 && gmsxxgmskb3_1.jtype != 6) {
/* MODB */
r__1 = (real) ibrit;
debuggmskb3_2.jtab[i__ - 1] = brkval_(&r__1);
} else if (gmsxxgmskb3_1.jtype == 6) {
/* BRIT */
debuggmskb3_2.jtab[i__ - 1] = ibrit;
}
}
ivisn = 1;
}
lastyp = gmsxxgmskb3_1.jtype;
}
ret_val = 0;
} else {
ret_val = 0;
}
mpixtb_(nval, &gmsxxgmskb3_1.isou, &gmsxxgmskb3_1.ides, &ibuf[1], &jtabv[(
ivisn << 8) - 256]);
return ret_val;
} /* kb3calgms_ */
/* Subroutine */ int vparms_(integer *vwin, real *inbuf, real *lpbuf, integer
*buflim, integer *half, real *dither, integer *mintau, integer *zc,
integer *lbe, integer *fbe, real *qs, real *rc1, real *ar_b__, real *
ar_f__)
{
/* System generated locals */
integer inbuf_offset, lpbuf_offset, i__1;
real r__1, r__2;
/* Builtin functions */
double r_sign(real *, real *);
integer i_nint(real *);
/* Local variables */
integer vlen, stop, i__;
real e_pre__;
integer start;
real ap_rms__, e_0__, oldsgn, lp_rms__, e_b__, e_f__, r_b__, r_f__, e0ap;
/* Arguments */
/* Local variables that need not be saved */
/* Calculate zero crossings (ZC) and several energy and correlation */
/* measures on low band and full band speech. Each measure is taken */
/* over either the first or the second half of the voicing window, */
/* depending on the variable HALF. */
/* Parameter adjustments */
--vwin;
--buflim;
lpbuf_offset = buflim[3];
lpbuf -= lpbuf_offset;
inbuf_offset = buflim[1];
inbuf -= inbuf_offset;
/* Function Body */
lp_rms__ = 0.f;
ap_rms__ = 0.f;
e_pre__ = 0.f;
e0ap = 0.f;
*rc1 = 0.f;
e_0__ = 0.f;
e_b__ = 0.f;
e_f__ = 0.f;
r_f__ = 0.f;
r_b__ = 0.f;
*zc = 0;
vlen = vwin[2] - vwin[1] + 1;
start = vwin[1] + (*half - 1) * vlen / 2 + 1;
stop = start + vlen / 2 - 1;
/* I'll use the symbol HVL in the table below to represent the value */
/* VLEN/2. Note that if VLEN is odd, then HVL should be rounded down, */
/* i.e., HVL = (VLEN-1)/2. */
/* HALF START STOP */
/* 1 VWIN(1)+1 VWIN(1)+HVL */
/* 2 VWIN(1)+HVL+1 VWIN(1)+2*HVL */
/* Note that if VLEN is even and HALF is 2, then STOP will be */
/* VWIN(1)+VLEN = VWIN(2)+1. That could be bad, if that index of INBUF */
/* is undefined. */
r__1 = inbuf[start - 1] - *dither;
oldsgn = r_sign(&c_b2, &r__1);
i__1 = stop;
for (i__ = start; i__ <= i__1; ++i__) {
lp_rms__ += (r__1 = lpbuf[i__], abs(r__1));
ap_rms__ += (r__1 = inbuf[i__], abs(r__1));
e_pre__ += (r__1 = inbuf[i__] - inbuf[i__ - 1], abs(r__1));
/* Computing 2nd power */
r__1 = inbuf[i__];
e0ap += r__1 * r__1;
*rc1 += inbuf[i__] * inbuf[i__ - 1];
/* Computing 2nd power */
r__1 = lpbuf[i__];
e_0__ += r__1 * r__1;
/* Computing 2nd power */
r__1 = lpbuf[i__ - *mintau];
e_b__ += r__1 * r__1;
/* Computing 2nd power */
r__1 = lpbuf[i__ + *mintau];
e_f__ += r__1 * r__1;
r_f__ += lpbuf[i__] * lpbuf[i__ + *mintau];
r_b__ += lpbuf[i__] * lpbuf[i__ - *mintau];
r__1 = inbuf[i__] + *dither;
if (r_sign(&c_b2, &r__1) != oldsgn) {
++(*zc);
oldsgn = -oldsgn;
}
*dither = -(*dither);
}
/* Normalized short-term autocovariance coefficient at unit sample delay
*/
*rc1 /= max(e0ap,1.f);
/* Ratio of the energy of the first difference signal (6 dB/oct preemphas
is)*/
/* to the energy of the full band signal */
/* Computing MAX */
r__1 = ap_rms__ * 2.f;
*qs = e_pre__ / max(r__1,1.f);
/* aR_b is the product of the forward and reverse prediction gains, */
/* looking backward in time (the causal case). */
*ar_b__ = r_b__ / max(e_b__,1.f) * (r_b__ / max(e_0__,1.f));
/* aR_f is the same as aR_b, but looking forward in time (non causal case
).*/
*ar_f__ = r_f__ / max(e_f__,1.f) * (r_f__ / max(e_0__,1.f));
/* Normalize ZC, LBE, and FBE to old fixed window length of 180. */
/* (The fraction 90/VLEN has a range of .58 to 1) */
r__2 = (real) (*zc << 1);
r__1 = r__2 * (90.f / vlen);
*zc = i_nint(&r__1);
/* Computing MIN */
r__1 = lp_rms__ / 4 * (90.f / vlen);
i__1 = i_nint(&r__1);
*lbe = min(i__1,32767);
/* Computing MIN */
r__1 = ap_rms__ / 4 * (90.f / vlen);
i__1 = i_nint(&r__1);
*fbe = min(i__1,32767);
return 0;
} /* vparms_ */
integer kb3calmsat_(integer *calb, integer *idir, integer *nval, integer *
jband, integer *ibuf)
{
/* Initialized data */
static real ycal[2] = { .04f,.008f };
static integer m4 = 54516;
static integer m5 = 54517;
static integer m6 = 54518;
static integer m7 = 54519;
static integer irad[612] /* was [34][18] */ = { 217,271,335,409,494,
591,700,823,959,1111,1277,1459,1658,1873,2106,2356,2623,2910,3214,
3537,3879,4239,4619,5017,5435,5872,6327,6802,7296,7808,8339,8889,
9457,10043,12,17,25,35,49,66,89,117,153,196,250,315,392,484,592,
719,866,1035,1229,1450,1701,1983,2299,2651,3043,3477,3954,4479,
5052,5677,6357,7093,7889,8745,230,287,354,432,521,622,737,865,
1008,1167,1341,1531,1739,1963,2206,2467,2746,3044,3362,3698,4054,
4429,4825,5239,5674,6128,6602,7096,7609,8141,8693,9264,9854,10463,
14,21,30,43,59,80,107,141,183,235,298,375,467,575,703,852,1024,
1223,1451,1709,2002,2331,2700,3111,3567,4071,4626,5235,5900,6625,
7411,8263,9183,10172,300,475,587,717,867,1037,1230,1446,1687,1954,
2248,2570,2921,3302,3713,4155,4630,5136,5676,6248,6854,7494,8167,
8875,9616,10392,11201,12045,12922,13833,14777,15755,16765,17809,7,
15,22,31,43,60,81,107,141,183,235,299,375,466,574,702,850,1023,
1221,1449,1707,2000,2330,2700,3113,3571,4078,4636,5250,5921,6653,
7448,8310,9241,368,478,590,721,871,1042,1236,1453,1695,1963,2258,
2582,2934,3317,3730,4175,4651,5160,5702,6277,6886,7529,8206,8917,
9662,10441,11255,12103,12985,13900,14850,15832,16848,17897,10,18,
26,37,52,72,98,130,172,223,286,363,457,568,700,856,1038,1248,1492,
1770,2087,2447,2851,3305,3812,4375,4999,5686,6441,7268,8169,9150,
10212,11362,348,452,559,684,827,990,1175,1382,1614,1870,2153,2462,
2800,3166,3563,3989,4446,4935,5455,6008,6593,7211,7861,8545,9262,
10012,10795,11612,12461,13343,14257,15204,16183,17194,10,17,25,35,
49,68,92,122,161,209,269,341,429,534,658,805,977,1176,1405,1668,
1967,2307,2689,3118,3598,4130,4720,5370,6085,6867,7721,8649,9656,
10744,387,505,624,761,919,1099,1302,1530,1784,2065,2374,2713,3082,
3482,3913,4378,4876,5407,5972,6572,7207,7877,8582,9323,10098,
10910,11756,12638,13555,14507,15493,16514,17569,18658,8,15,22,32,
44,61,82,110,145,188,242,307,385,479,591,722,876,1054,1259,1494,
1762,2065,2406,2789,3217,3692,4217,4797,5433,6130,6890,7716,8611,
9580,387,503,621,758,915,1094,1296,1523,1776,2055,2363,2700,3067,
3466,3896,4358,4853,5382,5945,6543,7175,7842,8544,9281,10053,
10861,11704,12582,13495,14443,15425,16442,17492,18577,8,15,22,31,
44,61,82,110,144,187,241,306,384,478,589,720,873,1051,1256,1490,
1758,2060,2401,2784,3211,3685,4210,4790,5426,6122,6881,7707,8602,
9570,537,667,822,1002,1207,1441,1704,1999,2328,2690,3089,3526,
4000,4514,5069,5665,6303,6983,7707,8474,9285,10141,11040,11984,
12973,14006,15083,16205,17371,18580,19833,21130,22469,23850,13,21,
30,43,60,82,111,147,193,250,320,405,507,628,772,941,1138,1366,
1627,1927,2267,2651,3083,3566,4105,4703,5363,6089,6886,7756,8705,
9734,10849,12052,534,664,818,996,1200,1433,1695,1988,2315,2676,
3072,3506,3978,4490,5041,5634,6268,6945,7664,8427,9234,10084,
10979,11918,12901,13928,14999,16115,17274,18477,19723,21012,22343,
23717,11,20,30,42,59,80,108,144,189,244,313,396,496,615,756,922,
1115,1339,1596,1890,2224,2602,3026,3502,4031,4619,5268,5983,6767,
7624,8558,9571,10669,11854 };
static integer itemp = 165;
static integer inc = 5;
static integer lasara = -999;
static integer lastyp = -1;
static integer ip2 = 88224;
static integer newcal = 89128;
static integer lasbnd = -999;
static integer m3 = 54515;
/* System generated locals */
integer ret_val, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), i_nint(real *);
/* Local variables */
static real a, b, e;
static integer i__, j, ie;
static real bbc, xco;
static integer ical;
static real coef[136] /* was [4][34] */;
static integer ioff;
extern real fval_(integer *, real *, real *, real *);
static real xcal[2], xrad[34];
static integer isen, iband;
extern /* Subroutine */ int edestX_(char *, integer *, ftnlen);
extern integer grysclmsatkb3_(real *);
static real xtemp[34];
extern /* Subroutine */ int asspl2_(integer *, real *, real *, real *);
static integer itable[256];
extern integer brkval_(real *);
extern /* Subroutine */ int mpixtb_(integer *, integer *, integer *,
integer *, integer *);
/* symbolic constants & shared data */
/* 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 */
/* external functions */
/* local variables */
/* initialized variables */
/* DATA M3/ #0000D4F3 /,M4/ #0000D4F4 / */
/* NOTE #D4F3= 54515 , #D4F4=54516 */
/* Parameter adjustments */
--ibuf;
--idir;
--calb;
/* Function Body */
ret_val = 0;
iband = *jband;
if (iband == 0) {
if (idir[19] == 1) {
iband = 1;
}
if (idir[19] == 128) {
iband = 8;
}
if (idir[19] == 512) {
iband = 10;
}
}
if (lasara != idir[33] || metxxxmsatkb3_1.jtype != lastyp || lasbnd !=
iband) {
lasbnd = iband;
lasara = idir[33];
lastyp = metxxxmsatkb3_1.jtype;
if (iband != 8 && iband != 10) {
if (s_cmp(brkpntmsatkb3_1.caltyp, "BRIT", (ftnlen)4, (ftnlen)4) ==
0 || s_cmp(brkpntmsatkb3_1.caltyp, "RAW", (ftnlen)4, (
ftnlen)3) == 0) {
for (j = 0; j <= 255; ++j) {
r__1 = (real) j;
itable[j] = brkval_(&r__1);
/* L1: */
}
} else {
for (j = 0; j <= 255; ++j) {
itable[j] = j;
/* L5: */
}
}
goto L150;
}
xco = 5.f;
/* (we won't allow negative radiances */
/* Default zero radiance level = 5 DN */
b = 0.f;
/* Default slope (should never be use */
ioff = 1;
/* Tables alternate 11 MU & 6 MU */
/* Default Offset into Temp tables */
if (idir[4] >= ip2) {
ioff = 2;
}
if (idir[4] >= newcal) {
b = idir[22] / 1e5f;
/* Slope constant for radiance */
xco = idir[23] / 10.f;
/* Offset constant (zero radiance */
isen = idir[24];
/* Primary or backup sensor ID (M5 */
ical = 1;
/* Index to cal constants for band */
if (iband == 10) {
ical = 2;
}
/* Index to cal constants for band */
if (isen < 0 || isen > 2) {
edestX_("Invalid sensor ID for band ", &iband, (ftnlen)27);
edestX_("Valid IR sensors are 1, 2, or 0, not ", &isen, (
ftnlen)37);
ret_val = -1;
}
if (idir[21] == m3 && iband == 8) {
ioff = 3;
} else if (idir[21] == m3 && iband == 10) {
ioff = 4;
} else if (idir[21] == m4 && iband == 8) {
ioff = 5;
} else if (idir[21] == m4 && iband == 10) {
ioff = 6;
} else if (idir[21] == m5 && iband == 8 && isen == 1) {
ioff = 7;
/* I */
} else if (idir[21] == m5 && iband == 10 && isen == 1) {
ioff = 8;
/* W */
} else if (idir[21] == m5 && iband == 8 && isen == 2) {
ioff = 9;
/* I */
} else if (idir[21] == m5 && iband == 10 && isen == 2) {
ioff = 10;
/* W */
} else if (idir[21] == m6 && iband == 8 && isen == 1) {
ioff = 11;
/* I */
} else if (idir[21] == m6 && iband == 10 && isen == 1) {
ioff = 12;
/* W */
} else if (idir[21] == m6 && iband == 8 && isen == 2) {
ioff = 13;
/* I */
} else if (idir[21] == m6 && iband == 10 && isen == 2) {
ioff = 14;
/* W */
} else if (idir[21] == m7 && iband == 8 && isen == 1) {
ioff = 15;
/* I */
} else if (idir[21] == m7 && iband == 10 && isen == 1) {
ioff = 16;
/* W */
} else if (idir[21] == m7 && iband == 8 && isen == 2) {
ioff = 17;
/* I */
} else if (idir[21] == m7 && iband == 10 && isen == 2) {
ioff = 18;
/* W */
} else {
edestX_("TABLE UNIDENTIFIED: IDIR(21)=", &idir[21], (ftnlen)29)
;
edestX_(" IBAND=", &iband, (ftnlen)29);
edestX_(" SENSOR=", &idir[24], (ftnlen)29)
;
edestX_(" OFFSET=", &ioff, (ftnlen)29);
}
} else if (idir[21] == 0) {
a = ycal[ical - 1];
b = 1.f;
b *= a;
} else {
bbc = idir[21] / 100.f;
xcal[0] = idir[22] / 1e6f;
xcal[1] = idir[23] / 1e6f;
if (idir[23] < 5000) {
xcal[1] = idir[23] / 1e5f;
}
b = 121.f / bbc;
a = xcal[ical - 1];
b *= a;
}
if (b == 0.f) {
edestX_("ERROR: Radiance slope = 0.0", &c__0, (ftnlen)27);
edestX_(" Check IDIR(21-24)", &c__0, (ftnlen)24);
}
if (s_cmp(brkpntmsatkb3_1.caltyp, "RAW", (ftnlen)4, (ftnlen)3) == 0 &&
metxxxmsatkb3_1.jtype == 3) {
for (i__ = 0; i__ <= 255; ++i__) {
r__1 = (real) i__;
itable[i__] = brkval_(&r__1);
/* L10: */
}
goto L150;
}
if (s_cmp(brkpntmsatkb3_1.caltyp, "RAD", (ftnlen)4, (ftnlen)3) == 0 &&
metxxxmsatkb3_1.jtype == 3) {
for (i__ = 0; i__ <= 255; ++i__) {
/* Computing MAX */
r__1 = 0.f, r__2 = b * (i__ - xco);
e = max(r__1,r__2);
r__1 = e;
itable[i__] = brkval_(&r__1);
/* L15: */
}
goto L150;
} else {
for (i__ = 0; i__ <= 255; ++i__) {
e = b * (i__ - xco);
/* Computing MAX */
r__1 = e * 1e3f;
i__1 = 0, i__2 = i_nint(&r__1);
ie = max(i__1,i__2);
itable[i__] = ie;
/* L20: */
}
if (metxxxmsatkb3_1.jtype == 1) {
goto L150;
}
}
for (i__ = 1; i__ <= 34; ++i__) {
xtemp[i__ - 1] = (itemp + (i__ - 1) * inc) * 10.f;
xrad[i__ - 1] = (real) irad[i__ + ioff * 34 - 35];
/* L30: */
}
asspl2_(&c__34, xrad, xtemp, coef);
for (i__ = 1; i__ <= 256; ++i__) {
if (s_cmp(brkpntmsatkb3_1.caltyp, "TEMP", (ftnlen)4, (ftnlen)4) ==
0 && metxxxmsatkb3_1.jtype == 3) {
r__2 = (real) itable[i__ - 1];
r__1 = fval_(&c__34, &r__2, xrad, coef) / 10;
itable[i__ - 1] = brkval_(&r__1);
} else {
r__2 = (real) itable[i__ - 1];
r__1 = fval_(&c__34, &r__2, xrad, coef);
itable[i__ - 1] = i_nint(&r__1);
}
/* L60: */
}
if (metxxxmsatkb3_1.jtype == 2) {
goto L150;
}
if (s_cmp(brkpntmsatkb3_1.caltyp, "TEMP", (ftnlen)4, (ftnlen)4) == 0
&& metxxxmsatkb3_1.jtype == 3) {
goto L150;
}
if (s_cmp(brkpntmsatkb3_1.caltyp, "BRIT", (ftnlen)4, (ftnlen)4) == 0
&& metxxxmsatkb3_1.jtype == 3) {
for (i__ = 1; i__ <= 256; ++i__) {
r__2 = itable[i__ - 1] / 10.f;
r__1 = (real) grysclmsatkb3_(&r__2);
itable[i__ - 1] = brkval_(&r__1);
/* L70: */
}
} else {
for (i__ = 1; i__ <= 256; ++i__) {
r__1 = itable[i__ - 1] / 10.f;
itable[i__ - 1] = grysclmsatkb3_(&r__1);
/* L80: */
}
}
L150:
;
}
mpixtb_(nval, &metxxxmsatkb3_1.isou, &metxxxmsatkb3_1.ides, &ibuf[1],
itable);
return ret_val;
} /* kb3calmsat_ */
/* Subroutine */ int slacon_(integer *n, real *v, real *x, integer *isgn,
real *est, integer *kase)
{
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static integer i__, j, iter;
static real temp;
static integer jump, jlast;
static real altsgn, estold;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLACON estimates the 1-norm of a square, real matrix A. */
/* Reverse communication is used for evaluating matrix-vector products. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 1. */
/* V (workspace) REAL array, dimension (N) */
/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
/* (W is not returned). */
/* X (input/output) REAL array, dimension (N) */
/* On an intermediate return, X should be overwritten by */
/* A * X, if KASE=1, */
/* A' * X, if KASE=2, */
/* and SLACON must be re-called with all the other parameters */
/* unchanged. */
/* ISGN (workspace) INTEGER array, dimension (N) */
/* EST (input/output) REAL */
/* On entry with KASE = 1 or 2 and JUMP = 3, EST should be */
/* unchanged from the previous call to SLACON. */
/* On exit, EST is an estimate (a lower bound) for norm(A). */
/* KASE (input/output) INTEGER */
/* On the initial call to SLACON, KASE should be 0. */
/* On an intermediate return, KASE will be 1 or 2, indicating */
/* whether X should be overwritten by A * X or A' * X. */
/* On the final return from SLACON, KASE will again be 0. */
/* Further Details */
/* ======= ======= */
/* Contributed by Nick Higham, University of Manchester. */
/* Originally named SONEST, dated March 16, 1988. */
/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/* a real or complex matrix, with applications to condition estimation", */
/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
/* ===================================================================== */
/* Parameter adjustments */
--isgn;
--x;
--v;
/* Function Body */
if (*kase == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 1.f / (real) (*n);
}
*kase = 1;
jump = 1;
return 0;
}
switch (jump) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[1] = x[1];
*est = dabs(v[1]);
goto L150;
}
*est = sasum_(n, &x[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = r_sign(&c_b11, &x[i__]);
isgn[i__] = i_nint(&x[i__]);
}
*kase = 2;
jump = 2;
return 0;
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
j = isamax_(n, &x[1], &c__1);
iter = 2;
L50:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 0.f;
}
x[j] = 1.f;
*kase = 1;
jump = 3;
return 0;
/* X HAS BEEN OVERWRITTEN BY A*X. */
L70:
scopy_(n, &x[1], &c__1, &v[1], &c__1);
estold = *est;
*est = sasum_(n, &v[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
r__1 = r_sign(&c_b11, &x[i__]);
if (i_nint(&r__1) != isgn[i__]) {
goto L90;
}
}
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) {
goto L120;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = r_sign(&c_b11, &x[i__]);
isgn[i__] = i_nint(&x[i__]);
}
*kase = 2;
jump = 4;
return 0;
/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L110:
jlast = j;
j = isamax_(n, &x[1], &c__1);
if (x[jlast] != (r__1 = x[j], dabs(r__1)) && iter < 5) {
++iter;
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f);
altsgn = -altsgn;
}
*kase = 1;
jump = 5;
return 0;
/* X HAS BEEN OVERWRITTEN BY A*X. */
L140:
temp = sasum_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f;
if (temp > *est) {
scopy_(n, &x[1], &c__1, &v[1], &c__1);
*est = temp;
}
L150:
*kase = 0;
return 0;
/* End of SLACON */
} /* slacon_ */
/* Subroutine */ int slaqps_(integer *m, integer *n, integer *offset, integer
*nb, integer *kb, real *a, integer *lda, integer *jpvt, real *tau,
real *vn1, real *vn2, real *auxv, real *f, integer *ldf)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
SLAQPS computes a step of QR factorization with column pivoting
of a real M-by-N matrix A by using Blas-3. It tries to factorize
NB columns from A starting from the row OFFSET+1, and updates all
of the matrix with Blas-3 xGEMM.
In some cases, due to catastrophic cancellations, it cannot
factorize NB columns. Hence, the actual number of factorized
columns is returned in KB.
Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
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
OFFSET (input) INTEGER
The number of rows of A that have been factorized in
previous steps.
NB (input) INTEGER
The number of columns to factorize.
KB (output) INTEGER
The number of columns actually factorized.
A (input/output) REAL array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, block A(OFFSET+1:M,1:KB) is the triangular
factor obtained and block A(1:OFFSET,1:N) has been
accordingly pivoted, but no factorized.
The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has
been updated.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
JPVT (input/output) INTEGER array, dimension (N)
JPVT(I) = K <==> Column K of the full matrix A has been
permuted into position I in AP.
TAU (output) REAL array, dimension (KB)
The scalar factors of the elementary reflectors.
VN1 (input/output) REAL array, dimension (N)
The vector with the partial column norms.
VN2 (input/output) REAL array, dimension (N)
The vector with the exact column norms.
AUXV (input/output) REAL array, dimension (NB)
Auxiliar vector.
F (input/output) REAL array, dimension (LDF,NB)
Matrix F' = L*Y'*A.
LDF (input) INTEGER
The leading dimension of the array F. LDF >= max(1,N).
Further Details
===============
Based on contributions by
G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
X. Sun, Computer Science Dept., Duke University, USA
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static real c_b7 = -1.f;
static real c_b8 = 1.f;
static real c_b15 = 0.f;
/* System generated locals */
integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
integer i_nint(real *);
/* Local variables */
static real temp, temp2;
extern doublereal snrm2_(integer *, real *, integer *);
static integer j, k;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static integer itemp;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer *);
static integer rk;
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
static integer lsticc;
extern integer isamax_(integer *, real *, integer *);
static integer lastrk;
static real akk;
static integer pvt;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define f_ref(a_1,a_2) f[(a_2)*f_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--auxv;
f_dim1 = *ldf;
f_offset = 1 + f_dim1 * 1;
f -= f_offset;
/* Function Body
Computing MIN */
i__1 = *m, i__2 = *n + *offset;
lastrk = min(i__1,i__2);
lsticc = 0;
k = 0;
/* Beginning of while loop. */
L10:
if (k < *nb && lsticc == 0) {
++k;
rk = *offset + k;
/* Determine ith pivot column and swap if necessary */
i__1 = *n - k + 1;
pvt = k - 1 + isamax_(&i__1, &vn1[k], &c__1);
if (pvt != k) {
sswap_(m, &a_ref(1, pvt), &c__1, &a_ref(1, k), &c__1);
i__1 = k - 1;
sswap_(&i__1, &f_ref(pvt, 1), ldf, &f_ref(k, 1), ldf);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[k];
jpvt[k] = itemp;
vn1[pvt] = vn1[k];
vn2[pvt] = vn2[k];
}
/* Apply previous Householder reflectors to column K:
A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */
if (k > 1) {
i__1 = *m - rk + 1;
i__2 = k - 1;
sgemv_("No transpose", &i__1, &i__2, &c_b7, &a_ref(rk, 1), lda, &
f_ref(k, 1), ldf, &c_b8, &a_ref(rk, k), &c__1)
;
}
/* Generate elementary reflector H(k). */
if (rk < *m) {
i__1 = *m - rk + 1;
slarfg_(&i__1, &a_ref(rk, k), &a_ref(rk + 1, k), &c__1, &tau[k]);
} else {
slarfg_(&c__1, &a_ref(rk, k), &a_ref(rk, k), &c__1, &tau[k]);
}
akk = a_ref(rk, k);
a_ref(rk, k) = 1.f;
/* Compute Kth column of F:
Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */
if (k < *n) {
i__1 = *m - rk + 1;
i__2 = *n - k;
sgemv_("Transpose", &i__1, &i__2, &tau[k], &a_ref(rk, k + 1), lda,
&a_ref(rk, k), &c__1, &c_b15, &f_ref(k + 1, k), &c__1);
}
/* Padding F(1:K,K) with zeros. */
i__1 = k;
for (j = 1; j <= i__1; ++j) {
f_ref(j, k) = 0.f;
/* L20: */
}
/* Incremental updating of F:
F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)'
*A(RK:M,K). */
if (k > 1) {
i__1 = *m - rk + 1;
i__2 = k - 1;
r__1 = -tau[k];
sgemv_("Transpose", &i__1, &i__2, &r__1, &a_ref(rk, 1), lda, &
a_ref(rk, k), &c__1, &c_b15, &auxv[1], &c__1);
i__1 = k - 1;
sgemv_("No transpose", n, &i__1, &c_b8, &f_ref(1, 1), ldf, &auxv[
1], &c__1, &c_b8, &f_ref(1, k), &c__1);
}
/* Update the current row of A:
A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */
if (k < *n) {
i__1 = *n - k;
sgemv_("No transpose", &i__1, &k, &c_b7, &f_ref(k + 1, 1), ldf, &
a_ref(rk, 1), lda, &c_b8, &a_ref(rk, k + 1), lda);
}
/* Update partial column norms. */
if (rk < lastrk) {
i__1 = *n;
for (j = k + 1; j <= i__1; ++j) {
if (vn1[j] != 0.f) {
temp = (r__1 = a_ref(rk, j), dabs(r__1)) / vn1[j];
/* Computing MAX */
r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp);
temp = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = vn1[j] / vn2[j];
temp2 = temp * .05f * (r__1 * r__1) + 1.f;
if (temp2 == 1.f) {
vn2[j] = (real) lsticc;
lsticc = j;
} else {
vn1[j] *= sqrt(temp);
}
}
/* L30: */
}
}
a_ref(rk, k) = akk;
/* End of while loop. */
goto L10;
}
*kb = k;
rk = *offset + *kb;
/* Apply the block reflector to the rest of the matrix:
A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) -
A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'.
Computing MIN */
i__1 = *n, i__2 = *m - *offset;
if (*kb < min(i__1,i__2)) {
i__1 = *m - rk;
i__2 = *n - *kb;
sgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b7, &a_ref(
rk + 1, 1), lda, &f_ref(*kb + 1, 1), ldf, &c_b8, &a_ref(rk +
1, *kb + 1), lda);
}
/* Recomputation of difficult columns. */
L40:
if (lsticc > 0) {
itemp = i_nint(&vn2[lsticc]);
i__1 = *m - rk;
vn1[lsticc] = snrm2_(&i__1, &a_ref(rk + 1, lsticc), &c__1);
vn2[lsticc] = vn1[lsticc];
lsticc = itemp;
goto L40;
}
return 0;
/* End of SLAQPS */
} /* slaqps_ */
