int dlabad_(doublereal *small, doublereal *large)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DLABAD takes as input the values computed by DLAMCH for underflow and
overflow, and returns the square root of each of these values if the
log of LARGE is sufficiently large. This subroutine is intended to
identify machines with a large exponent range, such as the Crays, and
redefine the underflow and overflow limits to be the square roots of
the values computed by DLAMCH. This subroutine is needed because
DLAMCH does not compensate for poor arithmetic in the upper half of
the exponent range, as is found on a Cray.
Arguments
=========
SMALL (input/output) DOUBLE PRECISION
On entry, the underflow threshold as computed by DLAMCH.
On exit, if LOG10(LARGE) is sufficiently large, the square
root of SMALL, otherwise unchanged.
LARGE (input/output) DOUBLE PRECISION
On entry, the overflow threshold as computed by DLAMCH.
On exit, if LOG10(LARGE) is sufficiently large, the square
root of LARGE, otherwise unchanged.
=====================================================================
If it looks like we're on a Cray, take the square root of
SMALL and LARGE to avoid overflow and underflow problems. */
/* Builtin functions */
doublereal d_lg10(doublereal *);
doublereal d_sqrt(doublereal *);
if (d_lg10(large) > 2e3)
{
*small = d_sqrt(small); // YC: *small avant
*large = d_sqrt(large); // YC: *large avant
}
return 0;
/* End of DLABAD */
} /* dlabad_ */
int map_setup_proxy (int n_proj, char* ellipsoid_name) {
int num_ellipsoid;
double f;
/*mknan (gmt_NaN);*/
/* determine ellipsoid */
for (num_ellipsoid = 0;
num_ellipsoid < N_ELLIPSOIDS
&& strcmp (ellipsoid_name, ellipse[num_ellipsoid].name);
num_ellipsoid++);
if (num_ellipsoid == N_ELLIPSOIDS)
return(-1);
EQ_RAD[n_proj] = ellipse[num_ellipsoid].eq_radius;
f = ellipse[num_ellipsoid].flattening;
ECC2[n_proj] = 2 * f - f * f;
ECC4[n_proj] = ECC2[n_proj] * ECC2[n_proj];
ECC6[n_proj] = ECC2[n_proj] * ECC4[n_proj];
ECC[n_proj] = d_sqrt (ECC2[n_proj]);
return(0);
}
/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__,
doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal *
csr, doublereal *snl, doublereal *csl)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
DLASV2 computes the singular value decomposition of a 2-by-2
triangular matrix
[ F G ]
[ 0 H ].
On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
right singular vectors for abs(SSMAX), giving the decomposition
[ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]
[-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].
Arguments
=========
F (input) DOUBLE PRECISION
The (1,1) element of the 2-by-2 matrix.
G (input) DOUBLE PRECISION
The (1,2) element of the 2-by-2 matrix.
H (input) DOUBLE PRECISION
The (2,2) element of the 2-by-2 matrix.
SSMIN (output) DOUBLE PRECISION
abs(SSMIN) is the smaller singular value.
SSMAX (output) DOUBLE PRECISION
abs(SSMAX) is the larger singular value.
SNL (output) DOUBLE PRECISION
CSL (output) DOUBLE PRECISION
The vector (CSL, SNL) is a unit left singular vector for the
singular value abs(SSMAX).
SNR (output) DOUBLE PRECISION
CSR (output) DOUBLE PRECISION
The vector (CSR, SNR) is a unit right singular vector for the
singular value abs(SSMAX).
Further Details
===============
Any input parameter may be aliased with any output parameter.
Barring over/underflow and assuming a guard digit in subtraction, all
output quantities are correct to within a few units in the last
place (ulps).
In IEEE arithmetic, the code works correctly if one matrix element is
infinite.
Overflow will not occur unless the largest singular value itself
overflows or is within a few ulps of overflow. (On machines with
partial overflow, like the Cray, overflow may occur if the largest
singular value is within a factor of 2 of overflow.)
Underflow is harmless if underflow is gradual. Otherwise, results
may correspond to a matrix modified by perturbations of size near
the underflow threshold.
===================================================================== */
/* Table of constant values */
static doublereal c_b3 = 2.;
static doublereal c_b4 = 1.;
doublereal AuxRes;
/* System generated locals */
doublereal d__1;
/* Builtin functions */
doublereal d_sqrt(doublereal *), d_sign(doublereal *, doublereal *);
doublereal d_abs(doublereal);
/* Local variables */
static integer pmax;
static doublereal temp;
static logical swap;
static doublereal a, d__, l, m, r__, s, t, tsign, fa, ga, ha;
extern doublereal dlamch_(char *);
static doublereal ft, gt, ht, mm;
static logical gasmal;
static doublereal tt, clt, crt, slt, srt;
ft = *f;
fa = d_abs(ft);
ht = *h__;
ha = d_abs(*h__);
/* PMAX points to the maximum absolute element of matrix
PMAX = 1 if F largest in absolute values
PMAX = 2 if G largest in absolute values
PMAX = 3 if H largest in absolute values */
pmax = 1;
swap = ha > fa;
if (swap) {
pmax = 3;
temp = ft;
ft = ht;
ht = temp;
temp = fa;
fa = ha;
ha = temp;
/* Now FA .ge. HA */
}
gt = *g;
ga = d_abs(gt);
if (ga == 0.) {
/* Diagonal matrix */
*ssmin = ha;
*ssmax = fa;
clt = 1.;
crt = 1.;
slt = 0.;
srt = 0.;
} else {
gasmal = TRUE_;
if (ga > fa) {
pmax = 2;
if (fa / ga < dlamch_("EPS")) {
/* Case of very large GA */
gasmal = FALSE_;
*ssmax = ga;
if (ha > 1.) {
*ssmin = fa / (ga / ha);
} else {
*ssmin = fa / ga * ha;
}
clt = 1.;
slt = ht / gt;
srt = 1.;
crt = ft / gt;
}
}
if (gasmal) {
/* Normal case */
d__ = fa - ha;
if (d__ == fa) {
/* Copes with infinite F or H */
l = 1.;
} else {
l = d__ / fa;
}
/* Note that 0 .le. L .le. 1 */
m = gt / ft;
/* Note that abs(M) .le. 1/macheps */
t = 2. - l;
/* Note that T .ge. 1 */
mm = m * m;
tt = t * t;
AuxRes = tt + mm;
s = d_sqrt(&AuxRes);
/* Note that 1 .le. S .le. 1 + 1/macheps */
if (l == 0.) {
r__ = d_abs(m);
} else
{
AuxRes= l * l + mm;
r__ = d_sqrt(&AuxRes);
}
/* Note that 0 .le. R .le. 1 + 1/macheps */
a = (s + r__) * .5;
/* Note that 1 .le. A .le. 1 + abs(M) */
*ssmin = ha / a;
*ssmax = fa * a;
if (mm == 0.) {
/* Note that M is very tiny */
if (l == 0.) {
t = d_sign(&c_b3, &ft) * d_sign(&c_b4, >);
} else {
t = gt / d_sign(&d__, &ft) + m / t;
}
} else {
t = (m / (s + t) + m / (r__ + l)) * (a + 1.);
}
AuxRes = t*t + 4.;
l = d_sqrt(&AuxRes);
crt = 2. / l;
srt = t / l;
clt = (crt + srt * m) / a;
slt = ht / ft * srt / a;
}
}
if (swap) {
*csl = srt;
*snl = crt;
*csr = slt;
*snr = clt;
} else {
*csl = clt;
*snl = slt;
*csr = crt;
*snr = srt;
}
/* Correct signs of SSMAX and SSMIN */
if (pmax == 1) {
tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f);
}
if (pmax == 2) {
tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g);
}
if (pmax == 3) {
tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__);
}
*ssmax = d_sign(ssmax, &tsign);
d__1 = tsign * d_sign(&c_b4, f) * d_sign(&c_b4, h__);
*ssmin = d_sign(ssmin, &d__1);
return 0;
/* End of DLASV2 */
} /* dlasv2_ */
