c_exp c_exp::conversionTo(DataType outType) const {
QString inCode = code();
DataType inType = type();
QString outCode;
if (outType.isFloat()) {
if (inType.isFloat()) {
outCode = inCode;
} else if (inType.isAFP()) {
if (inType.afpPrecision() >= 0) {
outCode = "(float)(" + inCode + ") / " + QString::number(1 << inType.afpPrecision());
} else {
outCode = "(float)(" + inCode + ") * " + QString::number(1 << (-inType.afpPrecision()));
}
} else if (inType.isInt()) {
outCode = "(float)(" + inCode + ")";
} else {
outCode = inCode; // error condition
}
} else if (outType.isAFP()) {
if (inType.isFloat()) {
if (outType.afpPrecision() >= 0) {
outCode = "(int)(" + inCode + " * 1.6 * (1 << " + QString::number(outType.afpPrecision()) + "))";
} else {
outCode = "(int)(" + inCode + " * 1.6 / (1 << " + QString::number(-outType.afpPrecision()) + "))";
}
} else if (inType.isAFP()) {
int numLeftShifts = outType.afpPrecision() - inType.afpPrecision();
if (numLeftShifts > 0) {
outCode = "(" + inCode + ") << " + QString::number(numLeftShifts);
} else {
outCode = "(" + inCode + ") >> " + QString::number(-numLeftShifts);
}
} else if (inType.isInt()) {
if (outType.afpPrecision() >= 0) {
outCode = "(" + inCode + ") << " + QString::number(outType.afpPrecision());
} else {
outCode = "(" + inCode + ") >> " + QString::number(-(outType.afpPrecision()));
}
} else {
outCode = inCode; // error condition
}
} else if (outType.isInt()) {
if (inType.isFloat()) {
return c_exp(); // error condition
} else if (inType.isAFP()) {
return c_exp(); // error condition
} else if (inType.isInt()) {
outCode = inCode;
} else {
outCode = inCode; // error condition
}
}
return c_exp(outCode, outType);
}
int main() /* テスト (ごく一部) */
{
double x, y;
complex z;
printf("x, y ? "); scanf("%lf%lf", &x, &y);
z = c_conv(x, y);
printf("z = %s\n", c_string(z));
z = c_exp(z);
printf("exp(z) = %s\n", c_string(z));
z = c_log(z);
printf("log(exp(z)) = %s\n", c_string(z));
return EXIT_SUCCESS;
}
/* DECK CGAMR */
/* Complex */ void cgamr_(complex * ret_val, complex *z__)
{
/* System generated locals */
complex q__1, q__2;
/* Local variables */
static real x;
static integer irold;
extern /* Subroutine */ int xgetf_(integer *), xsetf_(integer *);
extern /* Complex */ void clngam_(complex *, complex *);
extern /* Subroutine */ int xerclr_(void);
/* ***BEGIN PROLOGUE CGAMR */
/* ***PURPOSE Compute the reciprocal of the Gamma function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7A */
/* ***TYPE COMPLEX (GAMR-S, DGAMR-D, CGAMR-C) */
/* ***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* CGAMR(Z) calculates the reciprocal gamma function for COMPLEX */
/* argument Z. This is a preliminary version that is not accurate. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED CLNGAM, XERCLR, XGETF, XSETF */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 DATE WRITTEN */
/* 861211 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE CGAMR */
/* ***FIRST EXECUTABLE STATEMENT CGAMR */
ret_val->r = 0.f, ret_val->i = 0.f;
x = z__->r;
if (x <= 0.f && r_int(&x) == x && r_imag(z__) == 0.f) {
return ;
}
xgetf_(&irold);
xsetf_(&c__1);
clngam_(&q__1, z__);
ret_val->r = q__1.r, ret_val->i = q__1.i;
xerclr_();
xsetf_(&irold);
q__2.r = - ret_val->r, q__2.i = - ret_val->i;
c_exp(&q__1, &q__2);
ret_val->r = q__1.r, ret_val->i = q__1.i;
return ;
} /* cgamr_ */
int clarnv_(int *idist, int *iseed, int *n,
complex *x)
{
/* System generated locals */
int i__1, i__2, i__3, i__4, i__5;
float r__1, r__2;
complex q__1, q__2, q__3;
/* Builtin functions */
double log(double), sqrt(double);
void c_exp(complex *, complex *);
/* Local variables */
int i__;
float u[128];
int il, iv;
extern int slaruv_(int *, int *, float *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARNV returns a vector of n random complex numbers from a uniform or */
/* normal distribution. */
/* Arguments */
/* ========= */
/* IDIST (input) INTEGER */
/* Specifies the distribution of the random numbers: */
/* = 1: float and imaginary parts each uniform (0,1) */
/* = 2: float and imaginary parts each uniform (-1,1) */
/* = 3: float and imaginary parts each normal (0,1) */
/* = 4: uniformly distributed on the disc ABS(z) < 1 */
/* = 5: uniformly distributed on the circle ABS(z) = 1 */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* N (input) INTEGER */
/* The number of random numbers to be generated. */
/* X (output) COMPLEX array, dimension (N) */
/* The generated random numbers. */
/* Further Details */
/* =============== */
/* This routine calls the auxiliary routine SLARUV to generate random */
/* float numbers from a uniform (0,1) distribution, in batches of up to */
/* 128 using vectorisable code. The Box-Muller method is used to */
/* transform numbers from a uniform to a normal distribution. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
--iseed;
/* Function Body */
i__1 = *n;
for (iv = 1; iv <= i__1; iv += 64) {
/* Computing MIN */
i__2 = 64, i__3 = *n - iv + 1;
il = MIN(i__2,i__3);
/* Call SLARUV to generate 2*IL float numbers from a uniform (0,1) */
/* distribution (2*IL <= LV) */
i__2 = il << 1;
slaruv_(&iseed[1], &i__2, u);
if (*idist == 1) {
/* Copy generated numbers */
i__2 = il;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iv + i__ - 1;
i__4 = (i__ << 1) - 2;
i__5 = (i__ << 1) - 1;
q__1.r = u[i__4], q__1.i = u[i__5];
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L10: */
}
} else if (*idist == 2) {
/* Convert generated numbers to uniform (-1,1) distribution */
i__2 = il;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iv + i__ - 1;
r__1 = u[(i__ << 1) - 2] * 2.f - 1.f;
r__2 = u[(i__ << 1) - 1] * 2.f - 1.f;
q__1.r = r__1, q__1.i = r__2;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L20: */
}
} else if (*idist == 3) {
/* Convert generated numbers to normal (0,1) distribution */
i__2 = il;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iv + i__ - 1;
r__1 = sqrt(log(u[(i__ << 1) - 2]) * -2.f);
r__2 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663f;
q__3.r = 0.f, q__3.i = r__2;
c_exp(&q__2, &q__3);
q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L30: */
}
} else if (*idist == 4) {
/* Convert generated numbers to complex numbers uniformly */
/* distributed on the unit disk */
i__2 = il;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iv + i__ - 1;
r__1 = sqrt(u[(i__ << 1) - 2]);
r__2 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663f;
q__3.r = 0.f, q__3.i = r__2;
c_exp(&q__2, &q__3);
q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L40: */
}
} else if (*idist == 5) {
/* Convert generated numbers to complex numbers uniformly */
/* distributed on the unit circle */
i__2 = il;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iv + i__ - 1;
r__1 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663f;
q__2.r = 0.f, q__2.i = r__1;
c_exp(&q__1, &q__2);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L50: */
}
}
/* L60: */
}
return 0;
/* End of CLARNV */
} /* clarnv_ */
/* DECK CAIRY */
/* Subroutine */ int cairy_(complex *z__, integer *id, integer *kode, complex
*ai, integer *nz, integer *ierr)
{
/* Initialized data */
static real tth = .666666666666666667f;
static real c1 = .35502805388781724f;
static real c2 = .258819403792806799f;
static real coef = .183776298473930683f;
static complex cone = {1.f,0.f};
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
doublereal d__1, d__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Local variables */
static integer k;
static real d1, d2;
static integer k1, k2;
static complex s1, s2, z3;
static real aa, bb, ad, ak, bk, ck, dk, az;
static complex cy[1];
static integer nn;
static real rl;
static integer mr;
static real zi, zr, az3, z3i, z3r, fid, dig, r1m5;
static complex csq;
static real fnu;
static complex zta;
static real tol;
static complex trm1, trm2;
static real sfac, alim, elim, alaz, atrm;
extern /* Subroutine */ int cacai_(complex *, real *, integer *, integer *
, integer *, complex *, integer *, real *, real *, real *, real *)
;
static integer iflag;
extern /* Subroutine */ int cbknu_(complex *, real *, integer *, integer *
, complex *, integer *, real *, real *, real *);
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE CAIRY */
/* ***PURPOSE Compute the Airy function Ai(z) or its derivative dAi/dz */
/* for complex argument z. A scaling option is available */
/* to help avoid underflow and overflow. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10D */
/* ***TYPE COMPLEX (CAIRY-C, ZAIRY-C) */
/* ***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, */
/* BESSEL FUNCTION OF ORDER TWO THIRDS */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* On KODE=1, CAIRY computes the complex Airy function Ai(z) */
/* or its derivative dAi/dz on ID=0 or ID=1 respectively. On */
/* KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz */
/* is provided to remove the exponential decay in -pi/3<arg(z) */
/* <pi/3 and the exponential growth in pi/3<abs(arg(z))<pi where */
/* zeta=(2/3)*z**(3/2). */
/* While the Airy functions Ai(z) and dAi/dz are analytic in */
/* the whole z-plane, the corresponding scaled functions defined */
/* for KODE=2 have a cut along the negative real axis. */
/* Input */
/* Z - Argument of type COMPLEX */
/* ID - Order of derivative, ID=0 or ID=1 */
/* KODE - A parameter to indicate the scaling option */
/* KODE=1 returns */
/* AI=Ai(z) on ID=0 */
/* AI=dAi/dz on ID=1 */
/* at z=Z */
/* =2 returns */
/* AI=exp(zeta)*Ai(z) on ID=0 */
/* AI=exp(zeta)*dAi/dz on ID=1 */
/* at z=Z where zeta=(2/3)*z**(3/2) */
/* Output */
/* AI - Result of type COMPLEX */
/* NZ - Underflow indicator */
/* NZ=0 Normal return */
/* NZ=1 AI=0 due to underflow in */
/* -pi/3<arg(Z)<pi/3 on KODE=1 */
/* IERR - Error flag */
/* IERR=0 Normal return - COMPUTATION COMPLETED */
/* IERR=1 Input error - NO COMPUTATION */
/* IERR=2 Overflow - NO COMPUTATION */
/* (Re(Z) too large with KODE=1) */
/* IERR=3 Precision warning - COMPUTATION COMPLETED */
/* (Result has less than half precision) */
/* IERR=4 Precision error - NO COMPUTATION */
/* (Result has no precision) */
/* IERR=5 Algorithmic error - NO COMPUTATION */
/* (Termination condition not met) */
/* *Long Description: */
/* Ai(z) and dAi/dz are computed from K Bessel functions by */
/* Ai(z) = c*sqrt(z)*K(1/3,zeta) */
/* dAi/dz = -c* z *K(2/3,zeta) */
/* c = 1/(pi*sqrt(3)) */
/* zeta = (2/3)*z**(3/2) */
/* when abs(z)>1 and from power series when abs(z)<=1. */
/* In most complex variable computation, one must evaluate ele- */
/* mentary functions. When the magnitude of Z is large, losses */
/* of significance by argument reduction occur. Consequently, if */
/* the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), */
/* then losses exceeding half precision are likely and an error */
/* flag IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. */
/* Also, if the magnitude of ZETA is larger than U2=0.5/UR, then */
/* all significance is lost and IERR=4. In order to use the INT */
/* function, ZETA must be further restricted not to exceed */
/* U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA */
/* must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, */
/* and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single */
/* precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. */
/* This makes U2 limiting is single precision and U3 limiting */
/* in double precision. This means that the magnitude of Z */
/* cannot exceed approximately 3.4E+4 in single precision and */
/* 2.1E+6 in double precision. This also means that one can */
/* expect to retain, in the worst cases on 32-bit machines, */
/* no digits in single precision and only 6 digits in double */
/* precision. */
/* The approximate relative error in the magnitude of a complex */
/* Bessel function can be expressed as P*10**S where P=MAX(UNIT */
/* ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- */
/* sents the increase in error due to argument reduction in the */
/* elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), */
/* ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF */
/* ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may */
/* have only absolute accuracy. This is most likely to occur */
/* when one component (in magnitude) is larger than the other by */
/* several orders of magnitude. If one component is 10**K larger */
/* than the other, then one can expect only MAX(ABS(LOG10(P))-K, */
/* 0) significant digits; or, stated another way, when K exceeds */
/* the exponent of P, no significant digits remain in the smaller */
/* component. However, the phase angle retains absolute accuracy */
/* because, in complex arithmetic with precision P, the smaller */
/* component will not (as a rule) decrease below P times the */
/* magnitude of the larger component. In these extreme cases, */
/* the principal phase angle is on the order of +P, -P, PI/2-P, */
/* or -PI/2+P. */
/* ***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- */
/* matical Functions, National Bureau of Standards */
/* Applied Mathematics Series 55, U. S. Department */
/* of Commerce, Tenth Printing (1972) or later. */
/* 2. D. E. Amos, Computation of Bessel Functions of */
/* Complex Argument and Large Order, Report SAND83-0643, */
/* Sandia National Laboratories, Albuquerque, NM, May */
/* 1983. */
/* 3. D. E. Amos, A Subroutine Package for Bessel Functions */
/* of a Complex Argument and Nonnegative Order, Report */
/* SAND85-1018, Sandia National Laboratory, Albuquerque, */
/* NM, May 1985. */
/* 4. D. E. Amos, A portable package for Bessel functions */
/* of a complex argument and nonnegative order, ACM */
/* Transactions on Mathematical Software, 12 (September */
/* 1986), pp. 265-273. */
/* ***ROUTINES CALLED CACAI, CBKNU, I1MACH, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 890801 REVISION DATE from Version 3.2 */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* 920128 Category corrected. (WRB) */
/* 920811 Prologue revised. (DWL) */
/* ***END PROLOGUE CAIRY */
/* ***FIRST EXECUTABLE STATEMENT CAIRY */
*ierr = 0;
*nz = 0;
if (*id < 0 || *id > 1) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
az = c_abs(z__);
/* Computing MAX */
r__1 = r1mach_(&c__4);
tol = dmax(r__1,1e-18f);
fid = (real) (*id);
if (az > 1.f) {
goto L60;
}
/* ----------------------------------------------------------------------- */
/* POWER SERIES FOR ABS(Z).LE.1. */
/* ----------------------------------------------------------------------- */
s1.r = cone.r, s1.i = cone.i;
s2.r = cone.r, s2.i = cone.i;
if (az < tol) {
goto L160;
}
aa = az * az;
if (aa < tol / az) {
goto L40;
}
trm1.r = cone.r, trm1.i = cone.i;
trm2.r = cone.r, trm2.i = cone.i;
atrm = 1.f;
q__2.r = z__->r * z__->r - z__->i * z__->i, q__2.i = z__->r * z__->i +
z__->i * z__->r;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i +
q__2.i * z__->r;
z3.r = q__1.r, z3.i = q__1.i;
az3 = az * aa;
ak = fid + 2.f;
bk = 3.f - fid - fid;
ck = 4.f - fid;
dk = fid + 3.f + fid;
d1 = ak * dk;
d2 = bk * ck;
ad = dmin(d1,d2);
ak = fid * 9.f + 24.f;
bk = 30.f - fid * 9.f;
z3r = z3.r;
z3i = r_imag(&z3);
for (k = 1; k <= 25; ++k) {
r__1 = z3r / d1;
r__2 = z3i / d1;
q__2.r = r__1, q__2.i = r__2;
q__1.r = trm1.r * q__2.r - trm1.i * q__2.i, q__1.i = trm1.r * q__2.i
+ trm1.i * q__2.r;
trm1.r = q__1.r, trm1.i = q__1.i;
q__1.r = s1.r + trm1.r, q__1.i = s1.i + trm1.i;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = z3r / d2;
r__2 = z3i / d2;
q__2.r = r__1, q__2.i = r__2;
q__1.r = trm2.r * q__2.r - trm2.i * q__2.i, q__1.i = trm2.r * q__2.i
+ trm2.i * q__2.r;
trm2.r = q__1.r, trm2.i = q__1.i;
q__1.r = s2.r + trm2.r, q__1.i = s2.i + trm2.i;
s2.r = q__1.r, s2.i = q__1.i;
atrm = atrm * az3 / ad;
d1 += ak;
d2 += bk;
ad = dmin(d1,d2);
if (atrm < tol * ad) {
goto L40;
}
ak += 18.f;
bk += 18.f;
/* L30: */
}
L40:
if (*id == 1) {
goto L50;
}
q__3.r = c1, q__3.i = 0.f;
q__2.r = s1.r * q__3.r - s1.i * q__3.i, q__2.i = s1.r * q__3.i + s1.i *
q__3.r;
q__5.r = z__->r * s2.r - z__->i * s2.i, q__5.i = z__->r * s2.i + z__->i *
s2.r;
q__6.r = c2, q__6.i = 0.f;
q__4.r = q__5.r * q__6.r - q__5.i * q__6.i, q__4.i = q__5.r * q__6.i +
q__5.i * q__6.r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
ai->r = q__1.r, ai->i = q__1.i;
if (*kode == 1) {
return 0;
}
c_sqrt(&q__3, z__);
q__2.r = z__->r * q__3.r - z__->i * q__3.i, q__2.i = z__->r * q__3.i +
z__->i * q__3.r;
q__4.r = tth, q__4.i = 0.f;
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
q__2.i * q__4.r;
zta.r = q__1.r, zta.i = q__1.i;
c_exp(&q__2, &zta);
q__1.r = ai->r * q__2.r - ai->i * q__2.i, q__1.i = ai->r * q__2.i + ai->i
* q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L50:
q__2.r = -s2.r, q__2.i = -s2.i;
q__3.r = c2, q__3.i = 0.f;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i +
q__2.i * q__3.r;
ai->r = q__1.r, ai->i = q__1.i;
if (az > tol) {
q__4.r = z__->r * z__->r - z__->i * z__->i, q__4.i = z__->r * z__->i
+ z__->i * z__->r;
q__3.r = q__4.r * s1.r - q__4.i * s1.i, q__3.i = q__4.r * s1.i +
q__4.i * s1.r;
r__1 = c1 / (fid + 1.f);
q__5.r = r__1, q__5.i = 0.f;
q__2.r = q__3.r * q__5.r - q__3.i * q__5.i, q__2.i = q__3.r * q__5.i
+ q__3.i * q__5.r;
q__1.r = ai->r + q__2.r, q__1.i = ai->i + q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
}
if (*kode == 1) {
return 0;
}
c_sqrt(&q__3, z__);
q__2.r = z__->r * q__3.r - z__->i * q__3.i, q__2.i = z__->r * q__3.i +
z__->i * q__3.r;
q__4.r = tth, q__4.i = 0.f;
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
q__2.i * q__4.r;
zta.r = q__1.r, zta.i = q__1.i;
c_exp(&q__2, &zta);
q__1.r = ai->r * q__2.r - ai->i * q__2.i, q__1.i = ai->r * q__2.i + ai->i
* q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
/* ----------------------------------------------------------------------- */
/* CASE FOR ABS(Z).GT.1.0 */
/* ----------------------------------------------------------------------- */
L60:
fnu = (fid + 1.f) / 3.f;
/* ----------------------------------------------------------------------- */
/* SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
/* TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
/* ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
/* EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND */
/* EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR */
/* UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
/* RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
/* DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
/* ----------------------------------------------------------------------- */
k1 = i1mach_(&c__12);
k2 = i1mach_(&c__13);
r1m5 = r1mach_(&c__5);
/* Computing MIN */
i__1 = abs(k1), i__2 = abs(k2);
k = min(i__1,i__2);
elim = (k * r1m5 - 3.f) * 2.303f;
k1 = i1mach_(&c__11) - 1;
aa = r1m5 * k1;
dig = dmin(aa,18.f);
aa *= 2.303f;
/* Computing MAX */
r__1 = -aa;
alim = elim + dmax(r__1,-41.45f);
rl = dig * 1.2f + 3.f;
alaz = log(az);
/* ----------------------------------------------------------------------- */
/* TEST FOR RANGE */
/* ----------------------------------------------------------------------- */
aa = .5f / tol;
bb = i1mach_(&c__9) * .5f;
aa = dmin(aa,bb);
d__1 = (doublereal) aa;
d__2 = (doublereal) tth;
aa = pow_dd(&d__1, &d__2);
if (az > aa) {
goto L260;
}
aa = sqrt(aa);
if (az > aa) {
*ierr = 3;
}
c_sqrt(&q__1, z__);
csq.r = q__1.r, csq.i = q__1.i;
q__2.r = z__->r * csq.r - z__->i * csq.i, q__2.i = z__->r * csq.i +
z__->i * csq.r;
q__3.r = tth, q__3.i = 0.f;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i +
q__2.i * q__3.r;
zta.r = q__1.r, zta.i = q__1.i;
/* ----------------------------------------------------------------------- */
/* RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL */
/* ----------------------------------------------------------------------- */
iflag = 0;
sfac = 1.f;
zi = r_imag(z__);
zr = z__->r;
ak = r_imag(&zta);
if (zr >= 0.f) {
goto L70;
}
bk = zta.r;
ck = -dabs(bk);
q__1.r = ck, q__1.i = ak;
zta.r = q__1.r, zta.i = q__1.i;
L70:
if (zi != 0.f) {
goto L80;
}
if (zr > 0.f) {
goto L80;
}
q__1.r = 0.f, q__1.i = ak;
zta.r = q__1.r, zta.i = q__1.i;
L80:
aa = zta.r;
if (aa >= 0.f && zr > 0.f) {
goto L100;
}
if (*kode == 2) {
goto L90;
}
/* ----------------------------------------------------------------------- */
/* OVERFLOW TEST */
/* ----------------------------------------------------------------------- */
if (aa > -alim) {
goto L90;
}
aa = -aa + alaz * .25f;
iflag = 1;
sfac = tol;
if (aa > elim) {
goto L240;
}
L90:
/* ----------------------------------------------------------------------- */
/* CBKNU AND CACAI RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 */
/* ----------------------------------------------------------------------- */
mr = 1;
if (zi < 0.f) {
mr = -1;
}
cacai_(&zta, &fnu, kode, &mr, &c__1, cy, &nn, &rl, &tol, &elim, &alim);
if (nn < 0) {
goto L250;
}
*nz += nn;
goto L120;
L100:
if (*kode == 2) {
goto L110;
}
/* ----------------------------------------------------------------------- */
/* UNDERFLOW TEST */
/* ----------------------------------------------------------------------- */
if (aa < alim) {
goto L110;
}
aa = -aa - alaz * .25f;
iflag = 2;
sfac = 1.f / tol;
if (aa < -elim) {
goto L180;
}
L110:
cbknu_(&zta, &fnu, kode, &c__1, cy, nz, &tol, &elim, &alim);
L120:
q__2.r = coef, q__2.i = 0.f;
q__1.r = cy[0].r * q__2.r - cy[0].i * q__2.i, q__1.i = cy[0].r * q__2.i +
cy[0].i * q__2.r;
s1.r = q__1.r, s1.i = q__1.i;
if (iflag != 0) {
goto L140;
}
if (*id == 1) {
goto L130;
}
q__1.r = csq.r * s1.r - csq.i * s1.i, q__1.i = csq.r * s1.i + csq.i *
s1.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L130:
q__2.r = -z__->r, q__2.i = -z__->i;
q__1.r = q__2.r * s1.r - q__2.i * s1.i, q__1.i = q__2.r * s1.i + q__2.i *
s1.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L140:
q__2.r = sfac, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
s1.r = q__1.r, s1.i = q__1.i;
if (*id == 1) {
goto L150;
}
q__1.r = s1.r * csq.r - s1.i * csq.i, q__1.i = s1.r * csq.i + s1.i *
csq.r;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = 1.f / sfac;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L150:
q__2.r = -s1.r, q__2.i = -s1.i;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i +
q__2.i * z__->r;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = 1.f / sfac;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L160:
aa = r1mach_(&c__1) * 1e3f;
s1.r = 0.f, s1.i = 0.f;
if (*id == 1) {
goto L170;
}
if (az > aa) {
q__2.r = c2, q__2.i = 0.f;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i
+ q__2.i * z__->r;
s1.r = q__1.r, s1.i = q__1.i;
}
q__2.r = c1, q__2.i = 0.f;
q__1.r = q__2.r - s1.r, q__1.i = q__2.i - s1.i;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L170:
q__2.r = c2, q__2.i = 0.f;
q__1.r = -q__2.r, q__1.i = -q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
aa = sqrt(aa);
if (az > aa) {
q__2.r = z__->r * z__->r - z__->i * z__->i, q__2.i = z__->r * z__->i
+ z__->i * z__->r;
q__1.r = q__2.r * .5f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i *
.5f;
s1.r = q__1.r, s1.i = q__1.i;
}
q__3.r = c1, q__3.i = 0.f;
q__2.r = s1.r * q__3.r - s1.i * q__3.i, q__2.i = s1.r * q__3.i + s1.i *
q__3.r;
q__1.r = ai->r + q__2.r, q__1.i = ai->i + q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L180:
*nz = 1;
ai->r = 0.f, ai->i = 0.f;
return 0;
L240:
*nz = 0;
*ierr = 2;
return 0;
L250:
if (nn == -1) {
goto L240;
}
*nz = 0;
*ierr = 5;
return 0;
L260:
*ierr = 4;
*nz = 0;
return 0;
} /* cairy_ */
/* Subroutine */ int clarnv_(integer *idist, integer *iseed, integer *n,
complex *x)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLARNV returns a vector of n random complex numbers from a uniform or
normal distribution.
Arguments
=========
IDIST (input) INTEGER
Specifies the distribution of the random numbers:
= 1: real and imaginary parts each uniform (0,1)
= 2: real and imaginary parts each uniform (-1,1)
= 3: real and imaginary parts each normal (0,1)
= 4: uniformly distributed on the disc abs(z) < 1
= 5: uniformly distributed on the circle abs(z) = 1
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
N (input) INTEGER
The number of random numbers to be generated.
X (output) COMPLEX array, dimension (N)
The generated random numbers.
Further Details
===============
This routine calls the auxiliary routine SLARUV to generate random
real numbers from a uniform (0,1) distribution, in batches of up to
128 using vectorisable code. The Box-Muller method is used to
transform numbers from a uniform to a normal distribution.
=====================================================================
Parameter adjustments */
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Builtin functions */
double log(doublereal), sqrt(doublereal);
void c_exp(complex *, complex *);
/* Local variables */
static integer i__;
static real u[128];
static integer il, iv;
extern /* Subroutine */ int slaruv_(integer *, integer *, real *);
--x;
--iseed;
/* Function Body */
i__1 = *n;
for (iv = 1; iv <= i__1; iv += 64) {
/* Computing MIN */
i__2 = 64, i__3 = *n - iv + 1;
il = min(i__2,i__3);
/* Call SLARUV to generate 2*IL real numbers from a uniform (0,1)
distribution (2*IL <= LV) */
i__2 = il << 1;
slaruv_(&iseed[1], &i__2, u);
if (*idist == 1) {
/* Copy generated numbers */
i__2 = il;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iv + i__ - 1;
i__4 = (i__ << 1) - 2;
i__5 = (i__ << 1) - 1;
q__1.r = u[i__4], q__1.i = u[i__5];
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L10: */
}
} else if (*idist == 2) {
/* Convert generated numbers to uniform (-1,1) distribution */
i__2 = il;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iv + i__ - 1;
r__1 = u[(i__ << 1) - 2] * 2.f - 1.f;
r__2 = u[(i__ << 1) - 1] * 2.f - 1.f;
q__1.r = r__1, q__1.i = r__2;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L20: */
}
} else if (*idist == 3) {
/* Convert generated numbers to normal (0,1) distribution */
i__2 = il;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iv + i__ - 1;
r__1 = sqrt(log(u[(i__ << 1) - 2]) * -2.f);
r__2 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663f;
q__3.r = 0.f, q__3.i = r__2;
c_exp(&q__2, &q__3);
q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L30: */
}
} else if (*idist == 4) {
/* Convert generated numbers to complex numbers uniformly
distributed on the unit disk */
i__2 = il;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iv + i__ - 1;
r__1 = sqrt(u[(i__ << 1) - 2]);
r__2 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663f;
q__3.r = 0.f, q__3.i = r__2;
c_exp(&q__2, &q__3);
q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L40: */
}
} else if (*idist == 5) {
/* Convert generated numbers to complex numbers uniformly
distributed on the unit circle */
i__2 = il;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = iv + i__ - 1;
r__1 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663f;
q__2.r = 0.f, q__2.i = r__1;
c_exp(&q__1, &q__2);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L50: */
}
}
/* L60: */
}
return 0;
/* End of CLARNV */
} /* clarnv_ */
/* DECK CLNGAM */
/* Complex */ void clngam_(complex * ret_val, complex *zin)
{
/* Initialized data */
static real pi = 3.14159265358979324f;
static real sq2pil = .91893853320467274f;
static logical first = TRUE_;
/* System generated locals */
integer i__1;
real r__1, r__2;
doublereal d__1, d__2;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8, q__9, q__10,
q__11, q__12, q__13, q__14, q__15, q__16;
/* Local variables */
static integer i__, n;
static real x, y;
static complex z__;
extern doublereal carg_(complex *);
static complex corr;
static real cabsz, bound, dxrel;
extern doublereal r1mach_(integer *);
extern /* Complex */ void c9lgmc_(complex *, complex *), clnrel_(complex *
, complex *);
static real argsum;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE CLNGAM */
/* ***PURPOSE Compute the logarithm of the absolute value of the Gamma */
/* function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7A */
/* ***TYPE COMPLEX (ALNGAM-S, DLNGAM-D, CLNGAM-C) */
/* ***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* CLNGAM computes the natural log of the complex valued gamma function */
/* at ZIN, where ZIN is a complex number. This is a preliminary version, */
/* which is not accurate. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED C9LGMC, CARG, CLNREL, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 780401 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* ***END PROLOGUE CLNGAM */
/* ***FIRST EXECUTABLE STATEMENT CLNGAM */
if (first) {
n = log(r1mach_(&c__3)) * -.3f;
/* BOUND = N*(0.1*EPS)**(-1/(2*N-1))/(PI*EXP(1)) */
d__1 = (doublereal) (r1mach_(&c__3) * .1f);
d__2 = (doublereal) (-1.f / ((n << 1) - 1));
bound = n * .1171f * pow_dd(&d__1, &d__2);
dxrel = sqrt(r1mach_(&c__4));
}
first = FALSE_;
z__.r = zin->r, z__.i = zin->i;
x = zin->r;
y = r_imag(zin);
corr.r = 0.f, corr.i = 0.f;
cabsz = c_abs(&z__);
if (x >= 0.f && cabsz > bound) {
goto L50;
}
if (x < 0.f && dabs(y) > bound) {
goto L50;
}
if (cabsz < bound) {
goto L20;
}
/* USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND */
/* ABS(AIMAG(Y)) SMALL. */
if (y > 0.f) {
r_cnjg(&q__1, &z__);
z__.r = q__1.r, z__.i = q__1.i;
}
r__1 = pi * 2.f;
q__4.r = 0.f, q__4.i = r__1;
q__3.r = -q__4.r, q__3.i = -q__4.i;
q__2.r = q__3.r * z__.r - q__3.i * z__.i, q__2.i = q__3.r * z__.i +
q__3.i * z__.r;
c_exp(&q__1, &q__2);
corr.r = q__1.r, corr.i = q__1.i;
if (corr.r == 1.f && r_imag(&corr) == 0.f) {
xermsg_("SLATEC", "CLNGAM", "Z IS A NEGATIVE INTEGER", &c__3, &c__2, (
ftnlen)6, (ftnlen)6, (ftnlen)23);
}
r__1 = sq2pil + 1.f;
q__7.r = 0.f, q__7.i = pi;
q__8.r = z__.r - .5f, q__8.i = z__.i;
q__6.r = q__7.r * q__8.r - q__7.i * q__8.i, q__6.i = q__7.r * q__8.i +
q__7.i * q__8.r;
q__5.r = r__1 - q__6.r, q__5.i = -q__6.i;
q__10.r = -corr.r, q__10.i = -corr.i;
clnrel_(&q__9, &q__10);
q__4.r = q__5.r - q__9.r, q__4.i = q__5.i - q__9.i;
q__12.r = z__.r - .5f, q__12.i = z__.i;
q__14.r = 1.f - z__.r, q__14.i = -z__.i;
c_log(&q__13, &q__14);
q__11.r = q__12.r * q__13.r - q__12.i * q__13.i, q__11.i = q__12.r *
q__13.i + q__12.i * q__13.r;
q__3.r = q__4.r + q__11.r, q__3.i = q__4.i + q__11.i;
q__2.r = q__3.r - z__.r, q__2.i = q__3.i - z__.i;
q__16.r = 1.f - z__.r, q__16.i = -z__.i;
c9lgmc_(&q__15, &q__16);
q__1.r = q__2.r - q__15.r, q__1.i = q__2.i - q__15.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
if (y > 0.f) {
r_cnjg(&q__1, ret_val);
ret_val->r = q__1.r, ret_val->i = q__1.i;
}
return ;
/* USE THE RECURSION RELATION FOR ABS(Z) SMALL. */
L20:
if (x >= -.5f || dabs(y) > dxrel) {
goto L30;
}
r__2 = x - .5f;
r__1 = r_int(&r__2);
q__2.r = z__.r - r__1, q__2.i = z__.i;
q__1.r = q__2.r / x, q__1.i = q__2.i / x;
if (c_abs(&q__1) < dxrel) {
xermsg_("SLATEC", "CLNGAM", "ANSWER LT HALF PRECISION BECAUSE Z TOO "
"NEAR NEGATIVE INTEGER", &c__1, &c__1, (ftnlen)6, (ftnlen)6, (
ftnlen)60);
}
L30:
/* Computing 2nd power */
r__1 = bound;
/* Computing 2nd power */
r__2 = y;
n = sqrt(r__1 * r__1 - r__2 * r__2) - x + 1.f;
argsum = 0.f;
corr.r = 1.f, corr.i = 0.f;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
argsum += carg_(&z__);
q__1.r = z__.r * corr.r - z__.i * corr.i, q__1.i = z__.r * corr.i +
z__.i * corr.r;
corr.r = q__1.r, corr.i = q__1.i;
q__1.r = z__.r + 1.f, q__1.i = z__.i;
z__.r = q__1.r, z__.i = q__1.i;
/* L40: */
}
if (corr.r == 0.f && r_imag(&corr) == 0.f) {
xermsg_("SLATEC", "CLNGAM", "Z IS A NEGATIVE INTEGER", &c__3, &c__2, (
ftnlen)6, (ftnlen)6, (ftnlen)23);
}
r__1 = log(c_abs(&corr));
q__2.r = r__1, q__2.i = argsum;
q__1.r = -q__2.r, q__1.i = -q__2.i;
corr.r = q__1.r, corr.i = q__1.i;
/* USE STIRLING-S APPROXIMATION FOR LARGE Z. */
L50:
q__6.r = z__.r - .5f, q__6.i = z__.i;
c_log(&q__7, &z__);
q__5.r = q__6.r * q__7.r - q__6.i * q__7.i, q__5.i = q__6.r * q__7.i +
q__6.i * q__7.r;
q__4.r = sq2pil + q__5.r, q__4.i = q__5.i;
q__3.r = q__4.r - z__.r, q__3.i = q__4.i - z__.i;
q__2.r = q__3.r + corr.r, q__2.i = q__3.i + corr.i;
c9lgmc_(&q__8, &z__);
q__1.r = q__2.r + q__8.r, q__1.i = q__2.i + q__8.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
return ;
} /* clngam_ */
/* Complex */ VOID clarnd_(complex * ret_val, integer *idist, integer *iseed)
{
/* System generated locals */
doublereal d__1, d__2;
complex q__1, q__2, q__3;
/* Builtin functions */
double log(doublereal), sqrt(doublereal);
void c_exp(complex *, complex *);
/* Local variables */
static real t1, t2;
extern doublereal slaran_(integer *);
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLARND returns a random complex number from a uniform or normal
distribution.
Arguments
=========
IDIST (input) INTEGER
Specifies the distribution of the random numbers:
= 1: real and imaginary parts each uniform (0,1)
= 2: real and imaginary parts each uniform (-1,1)
= 3: real and imaginary parts each normal (0,1)
= 4: uniformly distributed on the disc abs(z) <= 1
= 5: uniformly distributed on the circle abs(z) = 1
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
Further Details
===============
This routine calls the auxiliary routine SLARAN to generate a random
real number from a uniform (0,1) distribution. The Box-Muller method
is used to transform numbers from a uniform to a normal distribution.
=====================================================================
Generate a pair of real random numbers from a uniform (0,1)
distribution
Parameter adjustments */
--iseed;
/* Function Body */
t1 = slaran_(&iseed[1]);
t2 = slaran_(&iseed[1]);
if (*idist == 1) {
/* real and imaginary parts each uniform (0,1) */
q__1.r = t1, q__1.i = t2;
ret_val->r = q__1.r, ret_val->i = q__1.i;
} else if (*idist == 2) {
/* real and imaginary parts each uniform (-1,1) */
d__1 = t1 * 2.f - 1.f;
d__2 = t2 * 2.f - 1.f;
q__1.r = d__1, q__1.i = d__2;
ret_val->r = q__1.r, ret_val->i = q__1.i;
} else if (*idist == 3) {
/* real and imaginary parts each normal (0,1) */
d__1 = sqrt(log(t1) * -2.f);
d__2 = t2 * 6.2831853071795864769252867663f;
q__3.r = 0.f, q__3.i = d__2;
c_exp(&q__2, &q__3);
q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
} else if (*idist == 4) {
/* uniform distribution on the unit disc abs(z) <= 1 */
d__1 = sqrt(t1);
d__2 = t2 * 6.2831853071795864769252867663f;
q__3.r = 0.f, q__3.i = d__2;
c_exp(&q__2, &q__3);
q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i;
ret_val->r = q__1.r, ret_val->i = q__1.i;
} else if (*idist == 5) {
/* uniform distribution on the unit circle abs(z) = 1 */
d__1 = t2 * 6.2831853071795864769252867663f;
q__2.r = 0.f, q__2.i = d__1;
c_exp(&q__1, &q__2);
ret_val->r = q__1.r, ret_val->i = q__1.i;
}
return ;
/* End of CLARND */
} /* clarnd_ */
complex c_pow(complex x, complex y) /* 累乗 $x^y$ */
{
return c_exp(c_mul(y, c_log(x)));
}
int main(int argc, char* args[])
{
if (argc == 2)
{
sscanf(args[1],"%d",&NUM_THREADS);
}
printf("\nusing %d threads\n", NUM_THREADS);
double pi = M_PI;
double c0=3e8;
double delt = 1;
double delz = 2*c0*delt;
tsteps=200000;
zsteps=500;
double* eps_yy = (double*)malloc(zsteps*sizeof(double));
double* mu_xx = (double*)malloc(zsteps*sizeof(double));
Ey=(double*)malloc(zsteps*sizeof(double));
Hx=(double*)malloc(zsteps*sizeof(double));
up_hx = (double*)malloc(zsteps*sizeof(double));
up_ey = (double*)malloc(zsteps*sizeof(double));
double k_grid = (c0*delt)/delz;
//device specification
int start_device = 100;
int end_device = 300;
int eps_device = 9;
int iz = 0;
for (iz=0;iz<zsteps;iz++)
{
Ey[iz] = 0;
Hx[iz] = 0;
eps_yy[iz] = 1.0;
mu_xx[iz] = 1.0;
up_hx[iz] = k_grid;
up_ey[iz] = k_grid;
}
//set device parameters
for (iz=start_device;iz<=end_device;iz++)
{
eps_yy[iz] = eps_device;
}
//set update coefficients
for(iz=0;iz<zsteps;iz++)
{
up_hx[iz] /= eps_yy[iz];
up_ey[iz] /= mu_xx[iz];
}
//calculate source
zsource = 50;
double src_lambda = 100*delz;
double src_omega = 2*pi*c0/src_lambda;
double src_period = 0.2*src_lambda/c0;
double src_freq = 1/src_period;
double max_freq = 0.5*src_freq;
//prepare fourier transform arrays
nfreqs = 400;
K = (complex double*)malloc(nfreqs*sizeof(complex double));
ref = (complex double*)malloc(nfreqs*sizeof(complex double));
trans = (complex double*)malloc(nfreqs*sizeof(complex double));
norm_src = (complex double*)malloc(nfreqs*sizeof(complex double));
double del_freq = max_freq/nfreqs;
for(iz=0;iz<nfreqs; iz++)
{
K[iz] = c_exp(-I*2*pi*delt*del_freq*iz);
ref[iz] = 0;
trans[iz] = 0;
norm_src[iz] = 0;
}
Ey_source = (double*)malloc(tsteps*sizeof(double));
Ey_time = (double*)malloc(tsteps*sizeof(double));
Hx_source = (double*)malloc(tsteps*sizeof(double));
double time = 0;
double nsrc = sqrt(eps_yy[zsource]*mu_xx[zsource]);
for(iz=0;iz<tsteps;iz++)
{
time = delt*iz;
Ey_source[iz] = exp(-((time-6*src_period)/(src_period))*((time-6*src_period)/(src_period)));
Hx_source[iz] = -sqrt(eps_yy[zsource]/mu_xx[zsource])*exp(-((time+0.5*delz*nsrc/c0+0.5*delt)-6*src_period)/(src_period)*((time+0.5*delz*nsrc/c0+0.5*delt)-6*src_period)/(src_period));
}
#ifdef GNUPLOT_PIPING
gnuplotPipe = popen ("gnuplot ", "w");
#endif
int t;
pthread_t threads[NUM_THREADS];
pthread_attr_t attr;
pthread_attr_init(&attr);
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE);
int rc;
void* status;
chunk_info_t info[NUM_THREADS];
pthread_barrier_init(&time_step_barrier,NULL,NUM_THREADS);
for(iz=0;iz<NUM_THREADS;iz++)
{
info[iz].tid = iz;
rc = pthread_create(&threads[iz], &attr, do_time_step, (void*)&info[iz]);
if (rc)
{
printf("ERROR; return code from pthread_create() is %d\n", rc);
exit(-1);
}
}
for(iz=0;iz<NUM_THREADS;iz++)
{
info[iz].tid = iz;
rc = pthread_join(threads[iz], &status);
if (rc) {
printf("ERROR; return code from pthread_join() is %d\n", rc);
exit(-1);
}
}
pthread_attr_destroy(&attr);
pthread_barrier_destroy(&time_step_barrier);
FILE* fout = fopen("out.txt","w");
for(iz=0;iz<nfreqs; iz++)
{
fprintf(fout,"%e %e %e %e\n",
2*pi*del_freq*iz,
cabs(norm_src[iz]),
cabs(ref[iz])*cabs(ref[iz])/(cabs(norm_src[iz])*cabs(norm_src[iz])),
cabs(trans[iz])*cabs(trans[iz])/(cabs(norm_src[iz])*cabs(norm_src[iz]))
);
}
fclose(fout);
fout = fopen("time_out.txt", "w");
for(iz=0;iz<tsteps;iz++)
{
fprintf(fout,"%e %e %e\n",
iz*delt,
Ey_time[iz],
Ey_source[iz]
);
}
fclose(fout);
#ifdef GNUPLOT_PIPING
pclose(gnuplotPipe);
#endif
free(eps_yy);
free(mu_xx);
free(Ey);
free(Hx);
free(up_hx);
free(up_ey);
free(K);
free(ref);
free(trans);
free(norm_src);
free(Hx_source);
free(Ey_source);
pthread_exit(NULL);
}
c_exp c_exp::fromLispExp(lisp_exp exp, QHash<QString, DataType> dataTypes, QHash<QString, QString> wireNames) {
if (exp.isLeaf()) {
if (wireNames.contains(exp.value())) {
DataType dt = dataTypes.value(exp.value());
QString wireName = wireNames.value(exp.value());
return c_exp(wireName, dt);
} else {
bool success;
exp.value().toInt(&success);
if (success) {
return c_exp(exp.value(), DATATYPE_INT);
} else {
exp.value().toFloat(&success);
if (success) {
return c_exp(exp.value(), DATATYPE_FLOAT);
} else {
return c_exp(); // error condition
}
}
}
} else {
QString theOperator = exp.element(0).value();
if (theOperator == "+" || theOperator == "-") {
QList<c_exp> results = evaluateArguments(exp, dataTypes, wireNames);
DataType mostGeneralType = getMostGeneralType(results);
DataType resultType;
if (mostGeneralType.isAFP()) {
resultType = DATATYPE_AFP(mostGeneralType.afpPrecision() - intLog2(results.size()));
} else {
resultType = mostGeneralType;
}
QList<QString> conversionCodes = getConversionCodes(results, resultType);
QString code = conversionCodes.join(" " + theOperator + " ");
return c_exp(code, resultType);
} else if (theOperator == "*") {
QList<c_exp > results = evaluateArguments(exp, dataTypes, wireNames);
DataType mostGeneralType = getMostGeneralType(results);
if (mostGeneralType.isAFP()) {
QString lastCode = "(int64_t)(" + results[0].code() + ")";
DataType lastType = results[0].type();
for (int i = 1; i < results.size(); i++) {
c_exp result = results[i];
if (! result.isValid()) {
lastType = DataType();
}
lastCode = "(" + lastCode + ") * (" + result.code() + ")";
lastCode = "(" + lastCode + ") >> 32";
int lastAFPPrecision = lastType.isAFP() ? lastType.afpPrecision() : 0;
int resultAFPPrecision = result.type().isAFP() ? result.type().afpPrecision() : 0;
if (lastType.isValid()) {
lastType = DATATYPE_AFP(32 - ((32 - lastAFPPrecision) + (32 - resultAFPPrecision)));
}
}
lastCode = "(int)(" + lastCode + ")";
return c_exp(lastCode, lastType);
} else {
DataType resultType = mostGeneralType;
QList<QString> codes = getCodes(results);
QString code = codes.join(" * ");
return c_exp(code, resultType);
}
} else if (theOperator == "/") {
return c_exp();
} else if (theOperator == "//") {
return c_exp();
} else if (theOperator == "%") {
return c_exp();
} else if (theOperator == "mod") {
return c_exp();
} else if (theOperator == "if") {
c_exp condResult = c_exp::fromLispExp(exp.element(1), dataTypes, wireNames);
c_exp ifTrueResult = c_exp::fromLispExp(exp.element(2), dataTypes, wireNames);
c_exp ifFalseResult = c_exp::fromLispExp(exp.element(3), dataTypes, wireNames);
DataType resultType = moreGeneralType(ifTrueResult.type(), ifFalseResult.type());
QString code = "(" + condResult.code() + ") ? (" + ifTrueResult.conversionTo(resultType).code() + ") : (" + ifFalseResult.conversionTo(resultType).code() + ")";
return c_exp(code, resultType);
} else if (theOperator == ">" || theOperator == "<" || theOperator == ">=" || theOperator == "<=" || theOperator == "==" || theOperator == "!=") {
c_exp leftOperand = c_exp::fromLispExp(exp.element(1), dataTypes, wireNames);
c_exp rightOperand = c_exp::fromLispExp(exp.element(2), dataTypes, wireNames);
DataType resultType = moreGeneralType(leftOperand.type(), rightOperand.type());
QString code = "(" + leftOperand.conversionTo(resultType).code() + ") " + theOperator + " (" + rightOperand.conversionTo(resultType).code() + ")";
return c_exp(code, resultType);
} else if (theOperator == "sqrt") {
c_exp operand = c_exp::fromLispExp(exp.element(1), dataTypes, wireNames);
QString code = "sqrt(" + operand.code() + ")";
return c_exp(code, DATATYPE_FLOAT);
} else if (theOperator == "read_adc") {
QString code = "((int)read_adc(" + c_exp::fromLispExp(exp.element(1), dataTypes, wireNames).conversionTo(DATATYPE_INT).code() + ") << 16)";
return c_exp(code, DATATYPE_AFP(27));
} else {
return c_exp(); // error condition
}
}
}
filterrep_t* create_resonator_representation( filter_t *f ) {
double theta, r, thm, th1, th2, phi;
int i, cvg;
complex_t z, g;
complex_t topco[MAXPZ+1], botco[MAXPZ+1];
filterrep_t *zrep;
// allocate memory for the filterrepresentation...
zrep = (filterrep_t*) calloc( 1, sizeof( filterrep_t) );
if ( ! zrep ) {
bpm_error( "Cannot allocate memory for resonator representation.", __FILE__, __LINE__ );
return NULL;
}
// for all :
zrep->nzeros = 2;
zrep->npoles = 2;
zrep->zero[0] = complex( 1., 0. );
zrep->zero[1] = complex( -1., 0. );
theta = 2.*PI*f->alpha1;
if ( f->Q <= 0. ) {
// negative Q, so assume infinte Q : pure oscillator, calculate the poles
z = c_exp( complex(0., theta) );
zrep->pole[0] = z;
zrep->pole[1] = c_conj( z );
} else {
// finite Q factor for the resonator, calculate the poles
_expand_complex_polynomial( zrep->zero, zrep->nzeros, topco);
r = exp(-theta / (2.0 * f->Q));
thm = theta;
th1 = 0.0;
th2 = PI;
cvg = 0;
for ( i=0; ( i<MAX_RESONATOR_ITER ) && ( cvg == 0 ); i++ ) {
z = complex( r*cos(thm), r*sin(thm));
zrep->pole[0] = z;
zrep->pole[1] = c_conj(z);
_expand_complex_polynomial( zrep->pole, zrep->npoles, botco);
g = c_div( _eval_complex_polynomial( topco, zrep->nzeros, complex(cos(theta),sin(theta))),
_eval_complex_polynomial( botco, zrep->npoles, complex(cos(theta),sin(theta))) );
phi = g.im / g.re;
if ( phi > 0.0 ) th2 = thm; else th1 = thm;
if ( fabs(phi) < FILT_EPS ) cvg = 1;
thm = 0.5 * ( th1 + th2 );
}
if ( ! cvg ) {
bpm_error( "Finite Q resonator failed to converge on pole/zero calculation.",
__FILE__, __LINE__ );
free(zrep);
return NULL;
}
}
// adjust the zeros for a bandstop resonator
if ( f->options & BANDSTOP ) {
theta = 2.*PI*f->alpha1;
z = complex( cos(theta), sin(theta) );
zrep->zero[0] = z;
zrep->zero[1] = c_conj( z );
}
// adjust the zeros for an allpas resonator
if ( f->options & ALLPASS ) {
zrep->zero[0] = _reflect( zrep->pole[0] );
zrep->zero[1] = _reflect( zrep->pole[1] );
}
return zrep;
}
