/*
* catan(z) = reverse(catanh(reverse(z)))
* where reverse(x + I*y) = y + I*x = I*conj(z).
*/
double complex
catan(double complex z)
{
double complex w = catanh(CMPLX(cimag(z), creal(z)));
return (CMPLX(cimag(w), creal(w)));
}
/*
* Optimized version of clog() for |z| finite and larger than ~RECIP_EPSILON.
*/
static double complex
clog_for_large_values(double complex z)
{
double x, y;
double ax, ay, t;
x = creal(z);
y = cimag(z);
ax = fabs(x);
ay = fabs(y);
if (ax < ay) {
t = ax;
ax = ay;
ay = t;
}
/*
* Avoid overflow in hypot() when x and y are both very large.
* Divide x and y by E, and then add 1 to the logarithm. This depends
* on E being larger than sqrt(2).
* Dividing by E causes an insignificant loss of accuracy; however
* this method is still poor since it is uneccessarily slow.
*/
if (ax > DBL_MAX / 2)
return (CMPLX(log(hypot(x / m_e, y / m_e)) + 1, atan2(y, x)));
/*
* Avoid overflow when x or y is large. Avoid underflow when x or
* y is small.
*/
if (ax > QUARTER_SQRT_MAX || ay < SQRT_MIN)
return (CMPLX(log(hypot(x, y)), atan2(y, x)));
return (CMPLX(log(ax * ax + ay * ay) / 2, atan2(y, x)));
}
DLLEXPORT double complex
csin(double complex z)
{
/* csin(z) = -I * csinh(I * z) */
z = csinh(CMPLX(-cimag(z), creal(z)));
return (CMPLX(cimag(z), -creal(z)));
}
double complex
ctan(double complex z)
{
/* ctan(z) = -I * ctanh(I * z) */
z = ctanh(CMPLX(-cimag(z), creal(z)));
return (CMPLX(cimag(z), -creal(z)));
}
double complex casin(double complex z) {
double complex w;
double x, y;
x = creal(z);
y = cimag(z);
w = CMPLX(1.0 - (x - y) * (x + y), -2.0 * x * y);
return clog(CMPLX(-y, x) + csqrt(w));
}
/*
* Manual page at function.def
*/
INT16 CGEN_PUBLIC CFunction::OnGet()
{
// Delegate to running function // ------------------------------------
FNC_DELEGATE OnGet(); // Use a weird macro (see function.def)
// Initialize // ------------------------------------
CDlpObject* iCont = GetActiveInstance(); // Determine field container
const char* lpsId = GetNextToken(TRUE); // Determine field name
// Validate // ------------------------------------
DLPASSERT(iCont); // Check set target
if (!dlp_strlen(lpsId)) // If no field name committed
return IERROR(this,FNC_EXPECT,"field identifier after -get",0,0); // Error
SWord* lpWrd = iCont->FindWord(lpsId,WL_TYPE_FIELD); // Find field in container
if (!lpWrd) // If not found
{ // >>
iCont = this; // Use this instance as container
lpWrd = FindWord(lpsId,WL_TYPE_FIELD); // And seek again
} // <<
if (!lpWrd) return IERROR(this,ERR_NOTFIELD,lpsId,0,0); // If still not found --> Error
// Push field value // ------------------------------------
switch (lpWrd->ex.fld.nType) // Branch for field variable type
{ // >>
case T_BOOL : { PushLogic ( *( BOOL*)lpWrd->lpData); break; }// - Boolean
case T_UCHAR : { PushNumber (CMPLX(*( UINT8*)lpWrd->lpData)); break; }// - Unsigned character
case T_CHAR : { PushNumber (CMPLX(*( INT8*)lpWrd->lpData)); break; }// - Signed character
case T_USHORT : { PushNumber (CMPLX(*( UINT16*)lpWrd->lpData)); break; }// - Unsigned short integer
case T_SHORT : { PushNumber (CMPLX(*( INT16*)lpWrd->lpData)); break; }// - Signed short integer
case T_UINT : { PushNumber (CMPLX(*( UINT32*)lpWrd->lpData)); break; }// - Unsigned integer
case T_INT : { PushNumber (CMPLX(*( INT32*)lpWrd->lpData)); break; }// - Signed integer
case T_ULONG : { PushNumber (CMPLX(*( UINT64*)lpWrd->lpData)); break; }// - Unsigned long integer
case T_LONG : { PushNumber (CMPLX(*( INT64*)lpWrd->lpData)); break; }// - Signed long integer
case T_FLOAT : { PushNumber (CMPLX(*( FLOAT32*)lpWrd->lpData)); break; }// - Single precision floating point
case T_DOUBLE : { PushNumber (CMPLX(*( FLOAT64*)lpWrd->lpData)); break; }// - Double precision floating point
case T_COMPLEX : { PushNumber ( *(COMPLEX64*)lpWrd->lpData); break; }// - Double precision complex floating point
case T_INSTANCE: { PushInstance(*(CDlpObject**) lpWrd->lpData); break; }// - Instance
case T_TEXT : /* Fall through */ // - Text (deprecated type!)
case T_CSTRING : /* Fall through */ // - Constant string
case T_STRING : { PushString(*(char**) lpWrd->lpData); break; }// - String
default : { // - Other types
if (lpWrd->ex.fld.nType > 0 && lpWrd->ex.fld.nType <= 256) // Character array?
PushString((char*)lpWrd->lpData); // Push value
else // Type unknown!
DLPASSERT(FMSG("Unknown field type")); // Error
} // <<
} // <<
return O_K; // Done.
}
double complex
ccos(double complex z)
{
/* ccos(z) = ccosh(I * z) */
return (ccosh(CMPLX(-cimag(z), creal(z))));
}
/**
* Compute pooled histogram h from histogram.
*
* <p>Remark: In the moment, only for m_hmode = 1, 2 (histogram resampling needed !)</p>
*/
INT16 CGEN_PUBLIC CHistogram::Poole(CHistogram* h)
{
if (h == NULL)
return (NOT_EXEC);
if (CheckHisto() != O_K)
return (NOT_EXEC);
if (m_hmode > 2)
return IERROR(this,HIS_POOLE, 0,0,0);
CHistogram_minmax_poole(m_minmax, h->m_minmax);
/* MWX 2004-03-10: Replaced by CData_Aggregate -->
data_aggrop (m_hist, h->m_hist, NULL, 0, OP_SUM, 3, T_DOUBLE, 0);
*/
CData_Aggregate_Int(h->m_hist, m_hist, NULL, CMPLX(0), OP_SUM);
/* <-- */
h->m_nhist = 1;
h->m_bins = m_bins;
h->m_hmode = m_hmode;
h->m_hdim = m_hdim;
h->m_calls = m_calls;
h->m_count = 0;
h->m_ssize = m_ssize;
if (m_hmode == 1)
{
m_min = dfetch(m_minmax,0,0);
m_max = dfetch(m_minmax,1,0);
}
return (O_K);
}
double complex clog(double complex z)
{
double r, phi;
r = cabs(z);
phi = carg(z);
return CMPLX(log(r), phi);
}
DLLEXPORT double complex
cproj(double complex z)
{
if (!isinf(creal(z)) && !isinf(cimag(z)))
return (z);
else
return (CMPLX(INFINITY, copysign(0.0, cimag(z))));
}
double complex csqrt(double complex z)
{
double complex result;
double a, b;
double t;
int scale;
a = creal(z);
b = cimag(z);
/* Handle special cases. */
if (z == 0)
return CMPLX(0, b);
if (isinf(b))
return CMPLX(INFINITY, b);
if (isnan(a)) {
t = (b - b) / (b - b); /* raise invalid if b is not a NaN */
return CMPLX(a, t); /* return NaN + NaN i */
}
if (isinf(a)) {
/*
* csqrt(inf + NaN i) = inf + NaN i
* csqrt(inf + y i) = inf + 0 i
* csqrt(-inf + NaN i) = NaN +- inf i
* csqrt(-inf + y i) = 0 + inf i
*/
if (signbit(a))
return CMPLX(fabs(b - b), copysign(a, b));
else
return CMPLX(a, copysign(b - b, b));
}
/*
* The remaining special case (b is NaN) is handled just fine by
* the normal code path below.
*/
/* Scale to avoid overflow. */
if (fabs(a) >= THRESH || fabs(b) >= THRESH) {
a *= 0.25;
b *= 0.25;
scale = 1;
} else {
scale = 0;
}
/* Algorithm 312, CACM vol 10, Oct 1967. */
if (a >= 0) {
t = sqrt((a + hypot(a, b)) * 0.5);
result = CMPLX(t, b / (2 * t));
} else {
t = sqrt((-a + hypot(a, b)) * 0.5);
result = CMPLX(fabs(b) / (2 * t), copysign(t, b));
}
/* Rescale. */
if (scale)
result *= 2;
return result;
}
/*
* Manual page at function.def
*/
INT16 CGEN_PROTECTED CFunction::OnType()
{
FNC_DELEGATE OnType();
const char* lpsTypecode = GetNextToken(TRUE);
INT16 nTypecode = dlp_get_type_code(lpsTypecode);
if (nTypecode<=0)
return IERROR(this,FNC_INVALID,"elementary type name",lpsTypecode,0);
PushNumber(CMPLX(nTypecode));
return O_K;
}
int main(void) {
float complex i = I;
double _Complex another_i = i;
put_complex(i);
put_complex(another_i + 5.);
put_complex(i * another_i);
put_complex(cpow(I, CMPLX(6., 0.)));
put_complex(csqrt(i));
}
/*
* cacosh(z) = I*cacos(z) or -I*cacos(z)
* where the sign is chosen so Re(cacosh(z)) >= 0.
*/
double complex
cacosh(double complex z)
{
double complex w;
double rx, ry;
w = cacos(z);
rx = creal(w);
ry = cimag(w);
/* cacosh(NaN + I*NaN) = NaN + I*NaN */
if (isnan(rx) && isnan(ry))
return (CMPLX(ry, rx));
/* cacosh(NaN + I*+-Inf) = +Inf + I*NaN */
/* cacosh(+-Inf + I*NaN) = +Inf + I*NaN */
if (isnan(rx))
return (CMPLX(fabs(ry), rx));
/* cacosh(0 + I*NaN) = NaN + I*NaN */
if (isnan(ry))
return (CMPLX(ry, ry));
return (CMPLX(fabs(ry), copysign(rx, cimag(z))));
}
COMPLEX64 dlm_get_det_trfC(COMPLEX64* A, INT32 nXA, void* ipiv) {
INT32 iXA = 0;
COMPLEX64 det = CMPLX(1.0);
BOOL neg = FALSE;
integer* p_ipiv = (integer*) ipiv;
for (iXA = 0; iXA < nXA; ++iXA) {
det = CMPLX_MULT(det,A[iXA+iXA*nXA]);
neg = (p_ipiv[iXA] != (iXA + 1)) ? !neg : neg;
}
return neg ? CMPLX_NEG(det) : det;
}
/*
* Optimized version of clog() for |z| finite and larger than ~RECIP_EPSILON.
*/
static double complex
clog_for_large_values(double complex z)
{
double x, y;
double ax, ay, t;
x = creal(z);
y = cimag(z);
ax = fabs(x);
ay = fabs(y);
if (ax < ay) {
t = ax;
ax = ay;
ay = t;
}
/*
* Avoid overflow in hypot() when x and y are both very large.
* Divide x and y by E, and then add 1 to the logarithm. This
* depends on E being larger than sqrt(2), since the return value of
* hypot cannot overflow if neither argument is greater in magnitude
* than 1/sqrt(2) of the maximum value of the return type. Likewise
* this determines the necessary threshold for using this method
* (however, actually use 1/2 instead as it is simpler).
*
* Dividing by E causes an insignificant loss of accuracy; however
* this method is still poor since it is uneccessarily slow.
*/
if (ax > DBL_MAX / 2)
return (CMPLX(log(hypot(x / m_e, y / m_e)) + 1, atan2(y, x)));
/*
* Avoid overflow when x or y is large. Avoid underflow when x or
* y is small.
*/
if (ax > QUARTER_SQRT_MAX || ay < SQRT_MIN)
return (CMPLX(log(hypot(x, y)), atan2(y, x)));
return (CMPLX(log(ax * ax + ay * ay) / 2, atan2(y, x)));
}
double complex
cpow(double complex a, double complex z)
{
double complex w;
double x, y, r, theta, absa, arga;
x = creal (z);
y = cimag (z);
absa = cabs (a);
if (absa == 0.0) {
return (CMPLX(0.0, 0.0));
}
arga = carg (a);
r = pow (absa, x);
theta = x * arga;
if (y != 0.0) {
r = r * exp (-y * arga);
theta = theta + y * log (absa);
}
w = CMPLX(r * cos (theta), r * sin (theta));
return (w);
}
/**
* <p>INTERNAL USE ONLY. This method is called by {@link -pool} to pool the
* statistics blocks contained in <code>idSrc</code> and store the result in
* <code>idPool</code>. The operation is controlled through the pooling mode
* flag <code>nMode</code> as follows:</p>
*
* <ul>
* <li>nMode=0: Pool sum data, <code>idPool</code> will be overwritten</li>
* <li>nMode=1: Pool min data</li>
* <li>nMode=2: Pool max data</li>
* </ul>
*
* <h3>Remarks</h3>
* <ul>
* <li>In order to pool raw statistics data, there are three calls
* (<code>nMode</code>=0,1 and 2) necessary. The first call of these
* <em>must</em> be the one with <code>nMode</code>=0!</li>
* <li>There are NO checks performed</li>
* </ul>
*
* @param idPool
* Pooled raw statistics data block
* @param idSrc
* Raw statistics data blocks to be pooled
* @param nMode
* Pooling mode, see above
*/
void CGEN_SPRIVATE CStatistics_PoolInt(CData* idPool, CData* idSrc, INT32 nMode)
{
CData* idAux = NULL; /* Auxilary data instance #1 */
if (nMode==0) /* Sum aggregation mode */
{ /* >> */
ISETOPTION(idPool,"/block"); /* Switch target to block mode */
CData_Aggregate(idPool,idSrc,NULL,CMPLX(0),"sum"); /* Aggregate (sum up) */
IRESETOPTIONS(idPool); /* Switch target to normal mode */
} /* << */
else if (nMode==1 || nMode==2) /* Extrama aggregation modes */
{ /* >> */
ICREATEEX(CData,idAux,"CStatistics_Pool_int.~idAux",NULL); /* Create auxilary data instance #1*/
ISETOPTION(idAux,"/block"); /* Switch target to block mode */
CData_Aggregate(idAux,idSrc,NULL,CMPLX(0),nMode==1?"min":"max"); /* Aggregate (minimum or maximum) */
dlp_memmove(CData_XAddr(idPool,nMode,0),CData_XAddr(idAux,nMode,0), /* Copy aggregated min. or max. ...*/
CData_GetRecLen(idAux)); /* | ... to target */
IRESETOPTIONS(idAux); /* Switch target to normal mode */
IDESTROY(idAux); /* Destroy auxilary data inst. #1 */
} /* << */
else /* Unknown mode */
DLPASSERT(FMSG("Invalid internal pooling mode")); /* Not so good ... */
}
/*
* casinh(z) = z + O(z^3) as z -> 0
*
* casinh(z) = sign(x)*clog(sign(x)*z) + O(1/z^2) as z -> infinity
* The above formula works for the imaginary part as well, because
* Im(casinh(z)) = sign(x)*atan2(sign(x)*y, fabs(x)) + O(y/z^3)
* as z -> infinity, uniformly in y
*/
double complex
casinh(double complex z)
{
double x, y, ax, ay, rx, ry, B, sqrt_A2my2, new_y;
int B_is_usable;
double complex w;
x = creal(z);
y = cimag(z);
ax = fabs(x);
ay = fabs(y);
if (isnan(x) || isnan(y)) {
/* casinh(+-Inf + I*NaN) = +-Inf + I*NaN */
if (isinf(x))
return (CMPLX(x, y + y));
/* casinh(NaN + I*+-Inf) = opt(+-)Inf + I*NaN */
if (isinf(y))
return (CMPLX(y, x + x));
/* casinh(NaN + I*0) = NaN + I*0 */
if (y == 0)
return (CMPLX(x + x, y));
/*
* All other cases involving NaN return NaN + I*NaN.
* C99 leaves it optional whether to raise invalid if one of
* the arguments is not NaN, so we opt not to raise it.
*/
return (CMPLX(x + 0.0L + (y + 0), x + 0.0L + (y + 0)));
}
if (ax > RECIP_EPSILON || ay > RECIP_EPSILON) {
/* clog...() will raise inexact unless x or y is infinite. */
if (signbit(x) == 0)
w = clog_for_large_values(z) + m_ln2;
else
w = clog_for_large_values(-z) + m_ln2;
return (CMPLX(copysign(creal(w), x), copysign(cimag(w), y)));
}
/* Avoid spuriously raising inexact for z = 0. */
if (x == 0 && y == 0)
return (z);
/* All remaining cases are inexact. */
raise_inexact();
if (ax < SQRT_6_EPSILON / 4 && ay < SQRT_6_EPSILON / 4)
return (z);
do_hard_work(ax, ay, &rx, &B_is_usable, &B, &sqrt_A2my2, &new_y);
if (B_is_usable)
ry = asin(B);
else
ry = atan2(new_y, sqrt_A2my2);
return (CMPLX(copysign(rx, x), copysign(ry, y)));
}
/**
* <p>Same as {@link dlm_invert_gel} but for complex input</p>
*
*/
INT16 dlm_invert_gelC(COMPLEX64* A, INT32 nXA, COMPLEX64* lpnDet) {
integer n = (integer) nXA;
integer c__1 = 1;
integer c_n1 = -1;
integer info = 0;
integer* ipiv = dlp_calloc(n, sizeof(integer));
void* work = NULL;
char opts[1] = { ' ' };
extern integer ilaenv_(integer*,char*,char*,integer*,integer*,integer*,integer*,ftnlen,ftnlen);
#ifdef __MAX_TYPE_32BIT
extern int cgetrf_(integer*,integer*,complex*,integer*,integer*,integer*);
extern int cgetri_(integer*,complex*,integer*,integer*,complex*,integer*,integer*);
char name[8] = { 'C', 'G', 'E', 'T', 'R', 'I' };
integer lwork = n * ilaenv_(&c__1, name, opts, &n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
work = dlp_calloc(lwork, sizeof(complex));
if(!ipiv || !work) return ERR_MEM;
cgetrf_(&n,&n,(complex*)A,&n,ipiv,&info);
if(lpnDet != NULL) *lpnDet = (info > 0) ? CMPLX(0.0) : dlm_get_det_trfC(A, nXA, ipiv);
cgetri_(&n,(complex*)A,&n,ipiv,work,&lwork,&info);
#else
extern int zgetrf_(integer*,integer*,doublecomplex*,integer*,integer*,integer*);
extern int zgetri_(integer*,doublecomplex*,integer*,integer*,doublecomplex*,integer*,integer*);
char name[8] = { 'Z', 'G', 'E', 'T', 'R', 'I' };
integer lwork = n * ilaenv_(&c__1, name, opts, &n, &c_n1, &c_n1, &c_n1, (ftnlen) 6, (ftnlen) 1);
work = dlp_calloc(lwork, sizeof(doublecomplex));
if (!ipiv || !work) return ERR_MEM;
zgetrf_(&n, &n, (doublecomplex*) A, &n, ipiv, &info);
if (lpnDet != NULL) *lpnDet = (info > 0) ? CMPLX(0.0) : dlm_get_det_trfC(A, nXA, ipiv);
zgetri_(&n, (doublecomplex*) A, &n, ipiv, work, &lwork, &info);
#endif
dlp_free(work);
dlp_free(ipiv);
return (info == 0) ? O_K : NOT_EXEC;
}
double complex
cexp(double complex z)
{
double x, y, exp_x;
uint32_t hx, hy, lx, ly;
x = creal(z);
y = cimag(z);
EXTRACT_WORDS(hy, ly, y);
hy &= 0x7fffffff;
/* cexp(x + I 0) = exp(x) + I 0 */
if ((hy | ly) == 0)
return (CMPLX(exp(x), y));
EXTRACT_WORDS(hx, lx, x);
/* cexp(0 + I y) = cos(y) + I sin(y) */
if (((hx & 0x7fffffff) | lx) == 0)
return (CMPLX(cos(y), sin(y)));
if (hy >= 0x7ff00000) {
if (lx != 0 || (hx & 0x7fffffff) != 0x7ff00000) {
/* cexp(finite|NaN +- I Inf|NaN) = NaN + I NaN */
return (CMPLX(y - y, y - y));
} else if (hx & 0x80000000) {
/* cexp(-Inf +- I Inf|NaN) = 0 + I 0 */
return (CMPLX(0.0, 0.0));
} else {
/* cexp(+Inf +- I Inf|NaN) = Inf + I NaN */
return (CMPLX(x, y - y));
}
}
if (hx >= exp_ovfl && hx <= cexp_ovfl) {
/*
* x is between 709.7 and 1454.3, so we must scale to avoid
* overflow in exp(x).
*/
return (__ldexp_cexp(z, 0));
} else {
/*
* Cases covered here:
* - x < exp_ovfl and exp(x) won't overflow (common case)
* - x > cexp_ovfl, so exp(x) * s overflows for all s > 0
* - x = +-Inf (generated by exp())
* - x = NaN (spurious inexact exception from y)
*/
exp_x = exp(x);
return (CMPLX(exp_x * cos(y), exp_x * sin(y)));
}
}
double complex catan(double complex z)
{
double complex w;
double a, t, x, x2, y;
x = creal(z);
y = cimag(z);
x2 = x * x;
a = 1.0 - x2 - (y * y);
t = 0.5 * atan2(2.0 * x, a);
w = _redupi(t);
t = y - 1.0;
a = x2 + (t * t);
t = y + 1.0;
a = (x2 + t * t)/a;
w = CMPLX(w, 0.25 * log(a));
return w;
}
INT32 CGEN_PRIVATE CProcess::DoJobFork(CFunction *iCaller, CFunction *iFnc)
{
CData* idSign = NULL; // Signature table in iDto
CDlpObject* iArg = NULL; // Argument Object
INT32 nArg = -1; // Argument loop counter
char sArg[L_NAMES]; // Current argument name
char lpsCmd[256]; // String buffer
// Initialize // ------------------------------------
idSign = (CData*)CDlpObject_OfKind("data", // Get signature table
CDlpObject_FindInstance(m_iDto,PRC_S_IDSIGN)); // |
// Push arguments on Stack // ------------------------------------
for (nArg=CData_GetNRecs(idSign)-1; nArg>0; nArg--) // Loop over signature table
{ // >>
dlp_strcpy(sArg,CData_Sfetch(idSign,nArg,0)); // Get argument name
iArg = CDlpObject_FindInstance(m_iDto,sArg); // Find argument in iDto
if (CDlpObject_OfKind("var",iArg)) switch(AS(CVar,iArg)->m_nType){ // Primitve data types >>
case T_BOOL : iCaller->PushLogic (AS(CVar,iArg)->m_bBVal); break; // Push bool
case T_COMPLEX: iCaller->PushNumber(AS(CVar,iArg)->m_nNVal); break; // Push number
case T_STRING : iCaller->PushString(AS(CVar,iArg)->m_lpsSVal); break; // Push string
default: iCaller->PushNumber(CMPLX(0.)); break; // Default: push something
}else iCaller->PushInstance(iArg); // Push instances
} // <<
// Post commands in queue // ------------------------------------
iCaller->PostCommand(CData_Sfetch(idSign,0,0),NULL,-1,FALSE); // Put in queue: run the function
snprintf(lpsCmd,255,"%s.dto %s -marshal_retval;", // Put in queue: save return value
this->m_lpInstanceName,this->m_lpInstanceName); // |
iCaller->PostCommand(lpsCmd,NULL,-1,FALSE); // |
snprintf(lpsCmd,255,"\"%s.xml\" %s.dto /xml /zip -save;", // Put in queue: save data transfer object
m_psTmpFile,this->m_lpInstanceName); // |
iCaller->PostCommand(lpsCmd,NULL,-1,FALSE); // |
iCaller->PostCommand("quit;",NULL,-1,FALSE); // Put in queue: Quit the client process
return O_K; // Ok, run the queue
}
/**
* Implementation of the class function. Leaves the value of the variable on
* the stack.
*/
void CGEN_PROTECTED CVar_Exec(CVar *_this)
{
switch (_this->m_nType)
{
case T_BOOL:
CDlpObject_MicPutB(BASEINST(_this),_this->m_bBVal);
break;
case T_DOUBLE:
case T_COMPLEX:
CDlpObject_MicPutN(BASEINST(_this),_this->m_nNVal);
break;
case T_STRING:
CDlpObject_MicPutS(BASEINST(_this),_this->m_lpsSVal);
break;
case T_INSTANCE:
CDlpObject_MicPutI(BASEINST(_this),BASEINST(_this)->m_iAliasInst);
break;
case T_RDOUBLE: {
_this->m_nInd = (INT32)(rand()/_this->m_nNorm);
_this->m_nNVal = CMPLX(_this->m_nLow+_this->m_nInd*_this->m_nDelta);
CDlpObject_MicPutN(BASEINST(_this),_this->m_nNVal);
break; }
case T_RDDATA:
_this->m_nInd = (INT32)(rand()/_this->m_nNorm);
_this->m_nNVal = CData_Cfetch(AS(CData,_this->m_idRndSet),_this->m_nInd, _this->m_nIcomp);
CDlpObject_MicPutN(BASEINST(_this),_this->m_nNVal);
break;
case T_RSDATA:
_this->m_nInd = (INT32)(rand()/_this->m_nNorm);
CVar_Sset(_this,(char*)CData_XAddr(AS(CData,_this->m_idRndSet),_this->m_nInd,_this->m_nIcomp));
_this->m_nType = T_RSDATA;
CDlpObject_MicPutS(BASEINST(_this),_this->m_lpsSVal);
break;
default: DLPASSERT(FMSG("Unknown variable type"));
}
}
double complex ccos(double complex z)
{
return ccosh(CMPLX(-cimag(z), creal(z)));
}
int
main (int argc, const char *const argv[])
{
if (1) {
/* The input matrix A. Number of rows M=3, number of columns
N=2. */
double complex A[3][2] = {
{ CMPLX(1.1,0.1), CMPLX(1.2,0.1) },
{ CMPLX(2.1,0.1), CMPLX(2.2,0.1) },
{ CMPLX(3.1,0.1), CMPLX(3.2,0.1) }
};
/* NOTE In truth: the following values are not "expected", they are
copied from the log of this very program; so they are the result
of a run of this program on my system. (Marco Maggi; Tue Jun 17,
2014) */
/* Vector of expected singular values. Dimension equal to N. */
double expected_S[2][1] = {
{ +5.639868 },
{ +0.043432 }
};
#if 0
/* Expected square matrix U. Dimensions: Unrows = Uncols =
Anrows. */
double complex expected_U[3][3] = {
{ CMPLX(-0.288536, -0.025360), CMPLX(-0.865183, +0.029919), CMPLX(+0.408004, 0.014111) },
{ CMPLX(-0.539238, -0.025601), CMPLX(-0.204697, -0.000189), CMPLX(-0.816009, -0.028221) },
{ CMPLX(-0.789939, -0.025843), CMPLX(+0.455790, -0.030297), CMPLX(+0.408004, +0.014111) },
};
#endif
/* Expected matrix of left singular vectors. Number of rows is M,
number of columns is MIN(M,N). */
double complex expected_LSV[3][2] = {
{ CMPLX(-0.288536, -0.025360), CMPLX(-0.865183, +0.029919) },
{ CMPLX(-0.539238, -0.025601), CMPLX(-0.204697, -0.000189) },
{ CMPLX(-0.789939, -0.025843), CMPLX(+0.455790, -0.030297) },
};
/* Expected square matrix V conjugate-transposed. Dimensions:
Vnrows = Vncols = Ancols. */
double complex expected_VH[2][2] = {
{ CMPLX(-0.692619, +0.000000), CMPLX(-0.721302, +0.001362) },
{ CMPLX(+0.721304, +0.000000), CMPLX(-0.692618, +0.001308) }
};
doit_in_row_major("small matrix", 3, 2, MIN(3,2),
A, expected_S, expected_LSV, expected_VH);
}
/* ------------------------------------------------------------------ */
if (1) { /* col-major */
/* The input matrix A. Number of rows M=3, number of columns
N=2. */
double complex A[2][3] = {
{ CMPLX(1.1,0.1), CMPLX(2.1,0.1), CMPLX(3.1,0.1) },
{ CMPLX(1.2,0.1), CMPLX(2.2,0.1), CMPLX(3.2,0.1) }
};
/* NOTE In truth: the following values are not "expected", they are
copied from the log of this very program; so they are the result
of a run of this program on my system. (Marco Maggi; Tue Jun 17,
2014) */
/* Vector of expected singular values. Dimension equal to N. */
double expected_S[1][2] = {
{ +5.639868, +0.043432 }
};
/* Expected matrix of left singular vectors. Number of rows is M,
number of columns is MIN(M,N). */
double complex expected_LSV[2][3] = {
{ CMPLX(-0.288536, -0.025360), CMPLX(-0.539238, -0.025601), CMPLX(-0.789939, -0.025843) },
{ CMPLX(-0.865183, +0.029919), CMPLX(-0.204697, -0.000189), CMPLX(+0.455790, -0.030297) }
};
/* Expected square matrix V conjugate-transposed. Dimensions:
Vnrows = Vncols = Ancols. */
double complex expected_VH[2][2] = {
{ CMPLX(-0.692619, +0.000000), CMPLX(+0.721304, +0.000000) },
{ CMPLX(-0.721302, +0.001362), CMPLX(-0.692618, +0.001308) }
};
doit_in_col_major("small matrix", 3, 2, MIN(3,2),
A, expected_S, expected_LSV, expected_VH);
}
/* ------------------------------------------------------------------ */
if (1) {
/* The input matrix A. Number of rows M=6, number of columns
N=4. */
double complex A[6][4] = {
{ CMPLX( 0.96,-0.81), CMPLX(-0.03, 0.96), CMPLX(-0.91, 2.06), CMPLX(-0.05, 0.41) },
{ CMPLX(-0.98, 1.98), CMPLX(-1.20, 0.19), CMPLX(-0.66, 0.42), CMPLX(-0.81, 0.56) },
{ CMPLX( 0.62,-0.46), CMPLX( 1.01, 0.02), CMPLX( 0.63,-0.17), CMPLX(-1.11, 0.60) },
{ CMPLX(-0.37, 0.38), CMPLX( 0.19,-0.54), CMPLX(-0.98,-0.36), CMPLX( 0.22,-0.20) },
{ CMPLX( 0.83, 0.51), CMPLX( 0.20, 0.01), CMPLX(-0.17,-0.46), CMPLX( 1.47, 1.59) },
{ CMPLX( 1.08,-0.28), CMPLX( 0.20,-0.12), CMPLX(-0.07, 1.23), CMPLX( 0.26, 0.26) }
};
/* Vector of expected singular values. Dimension equal to N. */
double expected_S[4][1] = {
{ 3.9994 },
{ 3.0003 },
{ 1.9944 },
{ 0.9995 }
};
/* Expected matrix of left singular vectors. Number of rows is M,
number of columns is MIN(M,N). */
double complex netlib_expected_LSV[6][4] = {
{ CMPLX(-0.5634,+0.0016), CMPLX(+0.2687,+0.2749), CMPLX(+0.2451,+0.4657), CMPLX(+0.3787,+0.2987) },
{ CMPLX(+0.1205,-0.6108), CMPLX(+0.2909,-0.1085), CMPLX(+0.4329,-0.1758), CMPLX(-0.0182,-0.0437) },
{ CMPLX(-0.0816,+0.1613), CMPLX(+0.1660,-0.3885), CMPLX(-0.4667,+0.3821), CMPLX(-0.0800,-0.2276) },
{ CMPLX(+0.1441,-0.1532), CMPLX(-0.1984,+0.1737), CMPLX(-0.0034,+0.1555), CMPLX(+0.2608,-0.5382) },
{ CMPLX(-0.2487,-0.0926), CMPLX(-0.6253,-0.3304), CMPLX(+0.2643,-0.0194), CMPLX(+0.1002,+0.0140) },
{ CMPLX(-0.3758,+0.0793), CMPLX(+0.0307,+0.0816), CMPLX(+0.1266,+0.1747), CMPLX(-0.4175,-0.4058) }
};
/* Expected square matrix V conjugate-transposed. Dimensions:
Vnrows = Vncols = Ancols. */
double complex netlib_expected_VH[4][4] = {
{ CMPLX(-0.6971,-0.0000), CMPLX(-0.0867,-0.3548), CMPLX(+0.0560,-0.5400), CMPLX(-0.1878,-0.2253) },
{ CMPLX(-0.2403,-0.0000), CMPLX(-0.0725,+0.2336), CMPLX(+0.2477,+0.5291), CMPLX(-0.7026,-0.2177) },
{ CMPLX(-0.5123,-0.0000), CMPLX(-0.3030,-0.1735), CMPLX(+0.0678,+0.5162), CMPLX(+0.4418,+0.3864) },
{ CMPLX(-0.4403,-0.0000), CMPLX(+0.5294,+0.6361), CMPLX(-0.3027,-0.0346), CMPLX(+0.1667,+0.0258) }
};
double complex expected_LSV[6][4];
double complex expected_VH[4][4];
/* NOTE For some reason that escapes my comprehension: the expected
data from the Netlib site has different signs from the ones I get
here. Reconstructing the input matrix from the data I get here
works fine, so I trust my results rather than the data at Netlib.
(Marco Maggi; Sat Jun 21, 2014) */
for (int i=0; i<6; ++i) {
for (int j=0; j<2; ++j) {
expected_LSV[i][j] = netlib_expected_LSV[i][j];
}
}
for (int i=0; i<6; ++i) {
for (int j=2; j<4; ++j) {
expected_LSV[i][j] = - netlib_expected_LSV[i][j];
}
}
for (int i=0; i<2; ++i) {
for (int j=0; j<4; ++j) {
expected_VH[i][j] = netlib_expected_VH[i][j];
}
}
for (int i=2; i<4; ++i) {
for (int j=0; j<4; ++j) {
expected_VH[i][j] = - netlib_expected_VH[i][j];
}
}
doit_in_row_major("Netlib values", 6, 4, MIN(6,4),
A, expected_S, expected_LSV, expected_VH);
}
exit(exit_code);
}
double complex cproj(double complex z)
{
if (isinf(creal(z)) || isinf(cimag(z)))
return CMPLX(INFINITY, copysign(0.0, creal(z)));
return z;
}
double complex csinh(double complex z)
{
double x, y, h;
int32_t hx, hy, ix, iy, lx, ly;
x = creal(z);
y = cimag(z);
EXTRACT_WORDS(hx, lx, x);
EXTRACT_WORDS(hy, ly, y);
ix = 0x7fffffff & hx;
iy = 0x7fffffff & hy;
/* Handle the nearly-non-exceptional cases where x and y are finite. */
if (ix < 0x7ff00000 && iy < 0x7ff00000) {
if ((iy | ly) == 0)
return CMPLX(sinh(x), y);
if (ix < 0x40360000) /* small x: normal case */
return CMPLX(sinh(x) * cos(y), cosh(x) * sin(y));
/* |x| >= 22, so cosh(x) ~= exp(|x|) */
if (ix < 0x40862e42) {
/* x < 710: exp(|x|) won't overflow */
h = exp(fabs(x)) * 0.5;
return CMPLX(copysign(h, x) * cos(y), h * sin(y));
} else if (ix < 0x4096bbaa) {
/* x < 1455: scale to avoid overflow */
z = __ldexp_cexp(CMPLX(fabs(x), y), -1);
return CMPLX(creal(z) * copysign(1, x), cimag(z));
} else {
/* x >= 1455: the result always overflows */
h = huge * x;
return CMPLX(h * cos(y), h * h * sin(y));
}
}
/*
* sinh(+-0 +- I Inf) = sign(d(+-0, dNaN))0 + I dNaN.
* The sign of 0 in the result is unspecified. Choice = normally
* the same as dNaN. Raise the invalid floating-point exception.
*
* sinh(+-0 +- I NaN) = sign(d(+-0, NaN))0 + I d(NaN).
* The sign of 0 in the result is unspecified. Choice = normally
* the same as d(NaN).
*/
if ((ix | lx) == 0 && iy >= 0x7ff00000)
return CMPLX(copysign(0, x * (y - y)), y - y);
/*
* sinh(+-Inf +- I 0) = +-Inf + I +-0.
*
* sinh(NaN +- I 0) = d(NaN) + I +-0.
*/
if ((iy | ly) == 0 && ix >= 0x7ff00000) {
if (((hx & 0xfffff) | lx) == 0)
return CMPLX(x, y);
return CMPLX(x, copysign(0, y));
}
/*
* sinh(x +- I Inf) = dNaN + I dNaN.
* Raise the invalid floating-point exception for finite nonzero x.
*
* sinh(x + I NaN) = d(NaN) + I d(NaN).
* Optionally raises the invalid floating-point exception for finite
* nonzero x. Choice = don't raise (except for signaling NaNs).
*/
if (ix < 0x7ff00000 && iy >= 0x7ff00000)
return CMPLX(y - y, x * (y - y));
/*
* sinh(+-Inf + I NaN) = +-Inf + I d(NaN).
* The sign of Inf in the result is unspecified. Choice = normally
* the same as d(NaN).
*
* sinh(+-Inf +- I Inf) = +Inf + I dNaN.
* The sign of Inf in the result is unspecified. Choice = always +.
* Raise the invalid floating-point exception.
*
* sinh(+-Inf + I y) = +-Inf cos(y) + I Inf sin(y)
*/
if (ix >= 0x7ff00000 && ((hx & 0xfffff) | lx) == 0) {
if (iy >= 0x7ff00000)
return CMPLX(x * x, x * (y - y));
return CMPLX(x * cos(y), INFINITY * sin(y));
}
/*
* sinh(NaN + I NaN) = d(NaN) + I d(NaN).
*
* sinh(NaN +- I Inf) = d(NaN) + I d(NaN).
* Optionally raises the invalid floating-point exception.
* Choice = raise.
*
* sinh(NaN + I y) = d(NaN) + I d(NaN).
* Optionally raises the invalid floating-point exception for finite
* nonzero y. Choice = don't raise (except for signaling NaNs).
*/
return CMPLX((x * x) * (y - y), (x + x) * (y - y));
}
double complex casinh(double complex z) {
z = casin(CMPLX(-cimag(z), creal(z)));
return CMPLX(cimag(z), -creal(z));
}
int main( int argc , char * argv[] )
{
int iarg , pos = 0 ;
float thresh=0.0 ;
MRI_IMAGE * maskim=NULL , *imin , *imout ;
float * maskar ;
int nxim , nyim , ii , npix ;
if( argc < 3 || strncmp(argv[1],"-help",4) == 0 ){
printf("Usage: immask [-thresh #] [-mask mask_image] [-pos] input_image output_image\n"
"* Masks the input_image and produces the output_image;\n"
"* Use of -thresh # means all pixels with absolute value below # in\n"
" input_image will be set to zero in the output_image\n"
"* Use of -mask mask_image means that only locations that are nonzero\n"
" in the mask_image will be nonzero in the output_image\n"
"* Use of -pos means only positive pixels from input_image will be used\n"
"* At least one of -thresh, -mask, -pos must be used; more than one is OK.\n"
) ;
exit(0) ;
}
machdep() ;
iarg = 1 ;
while( iarg < argc && argv[iarg][0] == '-' ){
/*** -pos ***/
if( strncmp(argv[iarg],"-pos",4) == 0 ){
pos = 1 ;
iarg++ ; continue ;
}
/*** -thresh # ***/
if( strncmp(argv[iarg],"-thresh",5) == 0 ){
thresh = strtod( argv[++iarg] , NULL ) ;
if( iarg >= argc || thresh <= 0.0 ){
fprintf(stderr,"Illegal -thresh!\a\n") ; exit(1) ;
}
iarg++ ; continue ;
}
if( strncmp(argv[iarg],"-mask",5) == 0 ){
maskim = mri_read_just_one( argv[++iarg] ) ;
if( maskim == NULL || iarg >= argc || ! MRI_IS_2D(maskim) ){
fprintf(stderr,"Illegal -mask!\a\n") ; exit(1) ;
}
if( maskim->kind != MRI_float ){
imin = mri_to_float( maskim ) ;
mri_free( maskim ) ;
maskim = imin ;
}
iarg++ ; continue ;
}
fprintf(stderr,"** Illegal option: %s\a\n",argv[iarg]) ;
exit(1) ;
}
if( thresh <= 0.0 && maskim == NULL && pos == 0 ){
fprintf(stderr,"No -thresh, -mask, -pos ==> can't go on!\a\n") ; exit(1) ;
}
if( iarg+1 >= argc ){
fprintf(stderr,"Must have input_image and output_image on command line!\a\n") ;
exit(1) ;
}
imin = mri_read_just_one( argv[iarg++] ) ;
if( imin == NULL ) exit(1) ;
if( ! MRI_IS_2D(imin) ){
fprintf(stderr,"can only process 2D images!\a\n") ;
exit(1) ;
}
nxim = imin->nx ;
nyim = imin->ny ;
npix = nxim * nyim ;
if( maskim == NULL ){
maskim = mri_new( nxim , nyim , MRI_float ) ;
maskar = MRI_FLOAT_PTR(maskim) ;
for( ii=0 ; ii < npix ; ii++ ) maskar[ii] = 1.0 ;
} else if( maskim->nx != nxim || maskim->ny != nyim ){
fprintf(stderr,"Mask and input image not same size!\a\n") ;
exit(1) ;
} else {
maskar = MRI_FLOAT_PTR(maskim) ;
}
imout = mri_new( nxim , nyim , imin->kind ) ;
switch( imin->kind ){
default:
fprintf(stderr,"Unrecognized input image type!\a\n") ;
exit(1) ;
case MRI_byte:{
byte * arin , * arout , val ;
arin = mri_data_pointer(imin) ;
arout = mri_data_pointer(imout) ;
for( ii=0 ; ii < npix ; ii++ ){
val = arin[ii] ;
if( maskar[ii] != 0.0 && ABS(val) >= thresh ) arout[ii] = val ;
else arout[ii] = 0 ;
}
} break ;
case MRI_short:{
short * arin , * arout , val ;
arin = mri_data_pointer(imin) ;
arout = mri_data_pointer(imout) ;
for( ii=0 ; ii < npix ; ii++ ){
val = arin[ii] ;
if( maskar[ii] != 0.0 && ABS(val) >= thresh ) arout[ii] = val ;
else arout[ii] = 0 ;
}
if( pos ) for( ii=0 ; ii < npix ; ii++ ) if( arout[ii] < 0 ) arout[ii] = 0 ;
} break ;
case MRI_float:{
float * arin , * arout , val ;
arin = mri_data_pointer(imin) ;
arout = mri_data_pointer(imout) ;
for( ii=0 ; ii < npix ; ii++ ){
val = arin[ii] ;
if( maskar[ii] != 0.0 && ABS(val) >= thresh ) arout[ii] = val ;
else arout[ii] = 0 ;
}
if( pos ) for( ii=0 ; ii < npix ; ii++ ) if( arout[ii] < 0 ) arout[ii] = 0 ;
} break ;
case MRI_int:{
int * arin , * arout , val ;
arin = mri_data_pointer(imin) ;
arout = mri_data_pointer(imout) ;
for( ii=0 ; ii < npix ; ii++ ){
val = arin[ii] ;
if( maskar[ii] != 0.0 && ABS(val) >= thresh ) arout[ii] = val ;
else arout[ii] = 0 ;
}
if( pos ) for( ii=0 ; ii < npix ; ii++ ) if( arout[ii] < 0 ) arout[ii] = 0 ;
} break ;
case MRI_double:{
double * arin , * arout , val ;
arin = mri_data_pointer(imin) ;
arout = mri_data_pointer(imout) ;
for( ii=0 ; ii < npix ; ii++ ){
val = arin[ii] ;
if( maskar[ii] != 0.0 && ABS(val) >= thresh ) arout[ii] = val ;
else arout[ii] = 0 ;
}
if( pos ) for( ii=0 ; ii < npix ; ii++ ) if( arout[ii] < 0 ) arout[ii] = 0 ;
} break ;
case MRI_complex:{
complex * arin , * arout , val ;
arin = mri_data_pointer(imin) ;
arout = mri_data_pointer(imout) ;
for( ii=0 ; ii < npix ; ii++ ){
val = arin[ii] ;
if( maskar[ii] != 0.0 && CABS(val) >= thresh ) arout[ii] = val ;
else arout[ii] = CMPLX(0,0) ;
}
} break ;
}
mri_write( argv[iarg] , imout ) ;
exit(0) ;
}
