void dp_jacobi(QSP_ARG_DECL Data_Obj *v_dp, Data_Obj *d_dp, Data_Obj *a_dp, int *nrotp)
{
void *a_rowlist[MAX_DIM], *v_rowlist[MAX_DIM];
int n;
if( OBJ_COLS(a_dp) != OBJ_ROWS(a_dp) ){
sprintf(DEFAULT_ERROR_STRING,"dp_jacobi: matrix %s must be square for jacobi",OBJ_NAME(a_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( OBJ_COLS(v_dp) != OBJ_ROWS(v_dp) ){
sprintf(DEFAULT_ERROR_STRING,"dp_jacobi: matrix %s must be square for jacobi",OBJ_NAME(v_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( OBJ_COLS(v_dp) != OBJ_COLS(a_dp) ){
sprintf(DEFAULT_ERROR_STRING,"dp_jacobi: size of eigenvector matrix %s must match input matrix %s for jacobi",
OBJ_NAME(v_dp),OBJ_NAME(a_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( OBJ_COLS(d_dp) != OBJ_COLS(a_dp) ){
sprintf(DEFAULT_ERROR_STRING,"dp_jacobi: size of eigenvalue vector %s must match input matrix %s for jacobi",
OBJ_NAME(d_dp),OBJ_NAME(a_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( ! IS_CONTIGUOUS(a_dp) ){
sprintf(DEFAULT_ERROR_STRING,"dp_jacobi: Object %s must be contiguous for jacobi",OBJ_NAME(a_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( ! IS_CONTIGUOUS(d_dp) ){
sprintf(DEFAULT_ERROR_STRING,"dp_jacobi: Object %s must be contiguous for jacobi",OBJ_NAME(d_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( ! IS_CONTIGUOUS(v_dp) ){
sprintf(DEFAULT_ERROR_STRING,"dp_jacobi: Object %s must be contiguous for jacobi",OBJ_NAME(v_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
n = OBJ_COLS(a_dp);
/* BUG make sure types match */
if( OBJ_MACH_PREC(a_dp) == PREC_SP ){
float_init_rowlist((float **)(void *)a_rowlist,a_dp);
float_init_rowlist((float **)(void *)v_rowlist,v_dp);
float_jacobi(((float **)(void *)a_rowlist)-1,n,((float *)(OBJ_DATA_PTR(d_dp)))-1,((float **)(void *)v_rowlist)-1,nrotp);
} else if( OBJ_MACH_PREC(a_dp) == PREC_DP ){
double_init_rowlist((double **)(void *)a_rowlist,a_dp);
double_init_rowlist((double **)(void *)v_rowlist,v_dp);
double_jacobi(((double **)(void *)a_rowlist)-1,n,((double *)(OBJ_DATA_PTR(d_dp)))-1,((double **)(void *)v_rowlist)-1,nrotp);
} else {
NWARN("bad precision in dp_jacobi");
}
}
void dp_zroots(Data_Obj *r_dp, Data_Obj *a_dp, int polish )
{
int m,n;
n=OBJ_COLS(a_dp); /* polynomial degree + 1 */
m=OBJ_COLS(r_dp);
if( m != n-1 ){
sprintf(DEFAULT_ERROR_STRING,
"dp_zroots: len of root vector %s (%d) inconsistent with coefficients vector %s (%d)",
OBJ_NAME(r_dp),OBJ_COLS(r_dp),OBJ_NAME(a_dp),OBJ_COLS(a_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
/* BUG make sure are row vectors */
if(OBJ_ROWS(a_dp) != 1 ){
sprintf(DEFAULT_ERROR_STRING,"dp_zroots: coefficient vector %s should be a row vector, (rows = %d)!?",
OBJ_NAME(a_dp),OBJ_ROWS(a_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( OBJ_ROWS(r_dp) != 1 ){
sprintf(DEFAULT_ERROR_STRING,"dp_zroots: root vector %s should be a row vector, (rows = %d)!?",
OBJ_NAME(r_dp),OBJ_ROWS(r_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
/* BUG make sure all vectors have same precision */
if( OBJ_MACH_PREC(a_dp) == PREC_SP ){
/* Why do we subtract 1 from the address of the roots, but not
* the coefficients!?
*/
float_zroots(
((fcomplex *)OBJ_DATA_PTR(a_dp))/*-1*/,
m,
((fcomplex *)OBJ_DATA_PTR(r_dp))-1,
polish);
} else if( OBJ_MACH_PREC(a_dp) == PREC_DP ){
double_zroots( ((dcomplex *)OBJ_DATA_PTR(a_dp))-1,m,((dcomplex *)OBJ_DATA_PTR(r_dp))-1,polish);
}
else {
NWARN("bad machine precision in dp_zroots");
}
}
int real_row_fft_ok(QSP_ARG_DECL Data_Obj *real_dp,Data_Obj *cpx_dp,const char *funcname)
{
if( ! good_xform_size( real_dp, cpx_dp, 1, funcname ) ) return FALSE;
if( OBJ_ROWS(cpx_dp) != OBJ_ROWS(real_dp) ){
sprintf(ERROR_STRING,
"%s: row count mismatch, %s (%d) and %s (%d)",
funcname,OBJ_NAME(cpx_dp),OBJ_ROWS(cpx_dp),
OBJ_NAME(real_dp),OBJ_ROWS(real_dp));
WARN(ERROR_STRING);
return FALSE;
}
if( ! real_cpx_objs_ok( real_dp, cpx_dp, funcname ) ) return FALSE;
if( ! fft_row_size_ok(real_dp, funcname ) ) return FALSE;
return TRUE;
}
void dobj_iterate(Data_Obj *dp,void (*func)(Data_Obj *,index_t))
{
dimension_t comp,col,row,frm,seq;
/* offsets for sequence, frame, row, pixel, component */
dimension_t s_os, f_os, r_os, p_os, c_os;
s_os=0;
for(seq=0;seq<OBJ_SEQS(dp);seq++){
f_os = s_os;
for(frm=0;frm<OBJ_FRAMES(dp);frm++){
r_os = f_os;
for(row=0;row<OBJ_ROWS(dp);row++){
p_os = r_os;
for(col=0;col<OBJ_COLS(dp);col++){
c_os = p_os;
for(comp=0;comp<OBJ_COMPS(dp);comp++){
(*func)(dp,c_os);
c_os += OBJ_COMP_INC(dp);
}
p_os += OBJ_PXL_INC(dp);
}
r_os += OBJ_ROW_INC(dp);
}
f_os += OBJ_FRM_INC(dp);
}
s_os += OBJ_SEQ_INC(dp);
}
}
static void fb_save(QSP_ARG_DECL Data_Obj *dp,int x, int y)
{
#ifdef HAVE_FB_DEV
dimension_t i,j,k;
char *p,*q;
/* BUG assume dp is the right kind of object */
if( ! IS_CONTIGUOUS(dp) ){
sprintf(ERROR_STRING,"fb_save: object %s must be contiguous",
OBJ_NAME(dp));
WARN(ERROR_STRING);
return;
}
INSURE_FB("fb_save");
p=(char *)OBJ_DATA_PTR(dp);
q=(char *)OBJ_DATA_PTR(curr_fbip->fbi_dp);
/* BUG this byte-at-a-time copy is horribly inefficient */
for(i=0;i<OBJ_ROWS(dp);i++)
for(j=0;j<OBJ_COLS(dp);j++)
for(k=0;k<OBJ_COMPS(dp);k++)
*p++ = *q++;
#endif /* HAVE_FB_DEV */
}
void _make_dragg(QSP_ARG_DECL const char *name,Data_Obj *bm,Data_Obj *dp)
{
Draggable *dgp;
if( !dp_same_size(bm,dp,"make_dragg") ){
warn("image/bitmap size mismatch");
return;
}
if( OBJ_PREC(bm) != PREC_BIT ){
sprintf(ERROR_STRING,"Object %s has precision %s, should be %s",
OBJ_NAME(bm),PREC_NAME(OBJ_PREC_PTR(bm)),
PREC_NAME(PREC_FOR_CODE(PREC_BIT)));
warn(ERROR_STRING);
return;
}
if( OBJ_PREC(dp) != PREC_BY && OBJ_PREC(dp) != PREC_UBY ){
sprintf(ERROR_STRING,"Image %s (for draggable object) has %s precision, should be %s or %s",
OBJ_NAME(dp),PREC_NAME(OBJ_PREC_PTR(dp)),
PREC_NAME(PREC_FOR_CODE(PREC_BY)),
PREC_NAME(PREC_FOR_CODE(PREC_UBY)) );
warn(ERROR_STRING);
return;
}
dgp = new_dragg(name);
if( dgp == NULL ) return;
dgp->dg_width = (int) OBJ_COLS(dp);
dgp->dg_height = (int) OBJ_ROWS(dp);
dgp->dg_bitmap = bm;
dgp->dg_image = dp;
dgp->dg_np = mk_node(dgp);
}
void _convolve(QSP_ARG_DECL Data_Obj *dpto,Data_Obj *dpfr,Data_Obj *dpfilt)
{
dimension_t i,j;
float val, *frptr;
dimension_t yos, offset;
// where is the other error checking done???
INSIST_RAM_OBJ(dpto,convolve)
INSIST_RAM_OBJ(dpfr,convolve)
INSIST_RAM_OBJ(dpfilt,convolve)
img_clear(dpto);
frptr = (float *) OBJ_DATA_PTR(dpfr);
j=OBJ_ROWS(dpto);
while(j--){
yos = j * OBJ_ROW_INC(dpfr);
i=OBJ_COLS(dpfr);
while(i--){
offset = yos+i*OBJ_PXL_INC(dpfr);
val = *(frptr+offset);
add_impulse(val,dpto,dpfilt,i,j);
}
}
}
static void fb_load(QSP_ARG_DECL Data_Obj *dp,int x, int y)
{
#ifdef HAVE_FB_DEV
dimension_t i,j;
/* char *p,*q; */ /* BUG probably a lot faster if we cast to long! */
long *p,*q;
u_long bytes_per_row, words_per_row;
/* BUG assume dp is the right kind of object */
if( ! IS_CONTIGUOUS(dp) ){
sprintf(ERROR_STRING,"fb_load: object %s must be contiguous",
OBJ_NAME(dp));
WARN(ERROR_STRING);
return;
}
INSURE_FB("fb_load");
p=(long *)OBJ_DATA_PTR(dp);
q=(long *)OBJ_DATA_PTR(curr_fbip->fbi_dp);
bytes_per_row = OBJ_COLS(dp) * OBJ_COMPS(dp);
words_per_row = bytes_per_row / sizeof(long);
for(i=0;i<OBJ_ROWS(dp);i++){
/* BUG we need to correct the row ptr if dp is narrower than the display */
for(j=0;j<words_per_row;j++)
*q++ = *p++;
}
#endif /* HAVE_FB_DEV */
}
void float_init_rowlist(float **list, Data_Obj *dp)
{
unsigned i;
float *fbase;
fbase = ((float *)OBJ_DATA_PTR(dp));
fbase --; /* for numrec fortran indices */
if( OBJ_ROWS(dp) > MAX_DIM ){
sprintf(DEFAULT_ERROR_STRING,"Sorry, object %s has %d rows but MAX_DIM is %d",
OBJ_NAME(dp),OBJ_ROWS(dp),MAX_DIM);
NERROR1(DEFAULT_ERROR_STRING);
}
for(i=0;i<OBJ_ROWS(dp);i++)
*list++ = fbase + i*OBJ_ROW_INC(dp); /* ??? *dp->dt_pinc; */
}
static void _update_pf_viewer(QSP_ARG_DECL Platform_Viewer *pvp, Data_Obj *dp)
{
#ifdef HAVE_OPENGL
int t;
//cudaError_t e;
// unmap buffer before using w/ GL
if( BUF_IS_MAPPED(dp) ){
if( (*PF_UNMAPBUF_FN(PFDEV_PLATFORM(OBJ_PFDEV(dp))))
(QSP_ARG dp) < 0 ) {
warn("update_pf_viewer: buffer unmap error!?");
}
CLEAR_OBJ_FLAG_BITS(dp, DT_BUF_MAPPED);
// propagate change to children and parents
propagate_flag(dp,DT_BUF_MAPPED);
}
glClear(GL_COLOR_BUFFER_BIT);
glBindTexture(GL_TEXTURE_2D, OBJ_TEX_ID(dp));
// is glBindBuffer REALLY part of libGLEW???
//#ifdef HAVE_LIBGLEW
glBindBuffer(GL_PIXEL_UNPACK_BUFFER, OBJ_BUF_ID(dp));
//#endif // HAVE_LIBGLEW
t=gl_pixel_type(dp);
glTexSubImage2D(GL_TEXTURE_2D, 0, // target, level
0, 0, // x0, y0
OBJ_COLS(dp), OBJ_ROWS(dp), // dx, dy
t,
GL_UNSIGNED_BYTE, // type
OFFSET(0)); // offset into PIXEL_UNPACK_BUFFER
//#ifdef HAVE_LIBGLEW
glBindBuffer(GL_PIXEL_UNPACK_BUFFER, 0);
//#endif // HAVE_LIBGLEW
glBegin(GL_QUADS);
glTexCoord2f(0, 1); glVertex2f(-1.0, -1.0);
glTexCoord2f(0, 0); glVertex2f(-1.0, 1.0);
glTexCoord2f(1, 0); glVertex2f(1.0, 1.0);
glTexCoord2f(1, 1); glVertex2f(1.0, -1.0);
glEnd();
glBindTexture(GL_TEXTURE_2D, 0);
if( (*PF_MAPBUF_FN(PFDEV_PLATFORM(OBJ_PFDEV(dp))))(QSP_ARG dp) < 0 ){
warn("update_pf_viewer: Error mapping buffer!?");
}
SET_OBJ_FLAG_BITS(dp, DT_BUF_MAPPED);
// propagate change to children and parents
propagate_flag(dp,DT_BUF_MAPPED);
#else // ! HAVE_OPENGL
NO_OGL_MSG
#endif // ! HAVE_OPENGL
}
void double_init_rowlist(double **list, Data_Obj *dp)
{
unsigned i;
double *fbase;
fbase = ((double *)OBJ_DATA_PTR(dp));
fbase --; /* for numrec fortran indices */
for(i=0;i<OBJ_ROWS(dp);i++)
*list++ = fbase + i*OBJ_ROW_INC(dp); /* ??? *dp->dt_pinc; */
}
static void get_data_params(Data_Obj *dp, u_long *np, long *incp)
{
if( OBJ_COLS(dp)==1 ) { /* maybe this is a column vector? */
*np=OBJ_ROWS(dp);
*incp = OBJ_ROW_INC(dp);
} else {
*np=OBJ_COLS(dp);
*incp = OBJ_PXL_INC(dp);
}
}
static void prepare_image_for_mapping(Data_Obj *dp)
{
#ifdef HAVE_OPENGL
int t;
cudaError_t e;
// unmap buffer before using w/ GL
if( BUF_IS_MAPPED(dp) ){
e = cudaGLUnmapBufferObject( OBJ_BUF_ID(dp) );
if( e != cudaSuccess ){
describe_cuda_driver_error2("update_cuda_viewer",
"cudaGLUnmapBufferObject",e);
NERROR1("failed to unmap buffer object");
}
CLEAR_OBJ_FLAG_BITS(dp, DT_BUF_MAPPED);
// propagate change to children and parents
propagate_flag(dp,DT_BUF_MAPPED);
}
//
//bind_texture(OBJ_DATA_PTR(dp));
glClear(GL_COLOR_BUFFER_BIT);
/*
sprintf(ERROR_STRING,"update_cuda_viewer: tex_id = %d, buf_id = %d",
OBJ_TEX_ID(dp),OBJ_BUF_ID(dp));
advise(ERROR_STRING);
*/
glBindTexture(GL_TEXTURE_2D, OBJ_TEX_ID(dp));
#ifdef HAVE_LIBGLEW
glBindBuffer(GL_PIXEL_UNPACK_BUFFER, OBJ_BUF_ID(dp));
#endif // HAVE_LIBGLEW
#ifdef FOOBAR
switch(OBJ_COMPS(dp)){
/* what used to be here??? */
}
#endif /* FOOBAR */
t=gl_pixel_type(dp);
glTexSubImage2D(GL_TEXTURE_2D, 0, // target, level
0, 0, // x0, y0
OBJ_COLS(dp), OBJ_ROWS(dp), // dx, dy
t,
GL_UNSIGNED_BYTE, // type
OFFSET(0)); // offset into PIXEL_UNPACK_BUFFER
#ifdef HAVE_LIBGLEW
glBindBuffer(GL_PIXEL_UNPACK_BUFFER, 0);
#endif // HAVE_LIBGLEW
}
double get_sos(Data_Obj *edp,Data_Obj *fdp) /* get the total sq'd error */
{
incr_t i,j;
double sos, rowsos,err;
sos = 0.0;
for(j=0;j<(incr_t)OBJ_ROWS(edp);j++){
rowsos=0.0;
for(i=0;i<(incr_t)OBJ_COLS(edp);i++){
err = get_ferror(edp,fdp,i,j);
rowsos += err * err;
}
sos += rowsos;
}
/* normalize by number of pixels */
/* why rowinc and not ncols??? */
sos /= OBJ_ROWS(edp)*OBJ_ROW_INC(edp);
return(sos);
}
double _add_to_sos(QSP_ARG_DECL dimension_t x,dimension_t y,Data_Obj *edp,Data_Obj *fdp,int factor)
{
dimension_t i,j;
double err,adj;
incr_t xx,yy;
/*
if( the_sos == NO_VALUE )
the_sos = get_sos(edp,fdp);
*/
adj =0.0;
for(j=0;j<OBJ_ROWS(fdp);j++){
yy = (incr_t)(y + j) - (incr_t)OBJ_ROWS(fdp)/2;
#ifdef NOWRAP
if( yy >= 0 && yy < OBJ_ROWS(edp) ){
for(i=0;i<OBJ_COLS(fdp);i++){
xx = (incr_t)(x + i) - (incr_t)(OBJ_COLS(fdp)/2);
if( xx >= 0 && xx < OBJ_COLS(edp) ){
err = get_ferror(edp,fdp,xx,yy);
adj += err*err;
}
}
}
#else
while( yy < 0 ) yy += OBJ_ROWS(edp);
while( yy >= (incr_t)OBJ_ROWS(edp) ) yy -= OBJ_ROWS(edp);
for(i=0;i<OBJ_COLS(fdp);i++){
xx = x + i - OBJ_COLS(fdp)/2;
while( xx < 0 ) xx += OBJ_COLS(edp);
while( xx >= (incr_t)OBJ_COLS(edp) ) xx -= OBJ_COLS(edp);
err = get_ferror(edp,fdp,xx,yy);
adj += err*err;
}
#endif /* NOWRAP */
}
/* normalize by number of pixels */
if( factor == 1 )
adj /= (OBJ_COLS(edp) * OBJ_ROWS(edp));
else if( factor == -1 )
adj /= - (OBJ_COLS(edp) * OBJ_ROWS(edp));
#ifdef CAUTIOUS
else {
sprintf(ERROR_STRING,"CAUTIOUS: add_to_sos: factor (%d) is not 1 or -1 !?",factor);
warn(ERROR_STRING);
return(0.0);
}
#endif /* CAUTIOUS */
/* the_sos += adj; */
return(adj);
}
int prodimg(QSP_ARG_DECL Data_Obj *dpto,Data_Obj *rowobj,Data_Obj *colobj) /** make the product image */
{
Vec_Obj_Args oa1, *oap=&oa1;
if( OBJ_COLS(rowobj) != OBJ_COLS(dpto) ){
sprintf(DEFAULT_ERROR_STRING,
"prodimg: row size mismatch, target %s (%d) and row %s (%d)",
OBJ_NAME(dpto),OBJ_COLS(dpto),OBJ_NAME(rowobj),
OBJ_COLS(rowobj));
NWARN(DEFAULT_ERROR_STRING);
return(-1);
} else if( OBJ_ROWS(colobj) != OBJ_ROWS(dpto) ){
sprintf(DEFAULT_ERROR_STRING,
"prodimg: column size mismatch, target %s (%d) and column %s (%d)",
OBJ_NAME(dpto),OBJ_ROWS(dpto),OBJ_NAME(colobj),
OBJ_ROWS(colobj));
NWARN(DEFAULT_ERROR_STRING);
return(-1);
} else if( !same_pixel_type(QSP_ARG dpto,rowobj) ){
NWARN("type/precision mismatch");
return(-1);
} else if( !same_pixel_type(QSP_ARG dpto,colobj) ){
NWARN("type precision mismatch");
return(-1);
}
#ifdef FOOBAR
else if( ! FLOATING_OBJ(dpto) ){
NWARN("sorry, only float and double supported for prodimg");
return(-1);
} else if( IS_COMPLEX(dpto) || IS_COMPLEX(colobj)
|| IS_COMPLEX(rowobj) ){
NWARN("Sorry, complex not supported");
return(-1);
}
#endif /* FOOBAR */
setvarg3(oap,dpto,rowobj,colobj);
vmul(QSP_ARG oap);
return(0);
}
int real_fft_type(QSP_ARG_DECL Data_Obj *real_dp,Data_Obj *cpx_dp,const char *funcname)
{
// First make sure the objects match in precision and are of the correct type
if( ! real_cpx_objs_ok( real_dp, cpx_dp, funcname ) ) return -1;
if( OBJ_ROWS(real_dp) == OBJ_ROWS(cpx_dp) ){
if( ! good_xform_size( real_dp, cpx_dp, 1, funcname ) ) return -1;
if( ! dim_is_power_of_two(real_dp, 2, funcname ) ) return -1;
return 1;
} else if( OBJ_COLS(real_dp) == OBJ_COLS(cpx_dp) ){
if( ! good_xform_size( real_dp, cpx_dp, 2, funcname ) ) return -1;
if( ! dim_is_power_of_two(real_dp, 1, funcname ) ) return -1;
return 2;
} else {
sprintf(ERROR_STRING,
"%s: real data %s (%d x %d) and transform %s (%d x %d) must have one matching dimension!?",
funcname,OBJ_NAME(real_dp),OBJ_ROWS(real_dp),OBJ_COLS(real_dp),
OBJ_NAME(cpx_dp),OBJ_ROWS(cpx_dp),OBJ_COLS(cpx_dp));
WARN(ERROR_STRING);
return -1;
}
}
void img_clear(Data_Obj *dp)
{
dimension_t i,j;
float *ptr;
incr_t xos, yos;
ptr=(float *)OBJ_DATA_PTR(dp);
for(j=0;j<OBJ_ROWS(dp);j++){
yos = j * OBJ_ROW_INC(dp);
for(i=0;i<OBJ_COLS(dp);i++){
xos = i * OBJ_PXL_INC(dp);
*(ptr + yos + xos ) = 0.0;
}
}
}
static void x_play_movie(QSP_ARG_DECL Movie *mvip)
{
Data_Obj *dp;
Viewer *vp;
dp = (Data_Obj *)mvip->mvi_data;
/* longlist(dp); */
vp = vwr_of(QSP_ARG MOVIE_VIEWER_NAME);
mk_win:
if( vp == NO_VIEWER ){
vp = viewer_init(QSP_ARG MOVIE_VIEWER_NAME,OBJ_COLS(dp),OBJ_ROWS(dp),0);
if( vp == NO_VIEWER ){
WARN("couldn't create viewer");
return;
}
default_cmap(QSP_ARG VW_DPYABLE(vp) );
show_viewer(QSP_ARG vp); /* default state is to be shown */
select_viewer(QSP_ARG vp);
} else {
if( vp->vw_width != OBJ_COLS(dp) ||
vp->vw_height != OBJ_ROWS(dp) ){
sprintf(ERROR_STRING,
"Resizing movie viewer for movie %s",
OBJ_NAME(dp));
advise(ERROR_STRING);
delete_viewer(QSP_ARG vp);
vp=NO_VIEWER;
goto mk_win;
}
}
/* load_viewer got rewritten, no longer show all frames!? */
old_load_viewer(QSP_ARG vp,dp);
}
void compute_histo(QSP_ARG_DECL Data_Obj *histo_dp,Data_Obj *data_dp,double bin_width,double min_limit)
{
dimension_t i,j,k;
float num;
float *histbuf;
incr_t index;
dimension_t n_bins;
int n_under=0, n_over=0;
INSIST_RAM_OBJ(histo_dp,compute_histo);
INSIST_RAM_OBJ(data_dp,compute_histo);
if( OBJ_PREC(histo_dp) != PREC_SP ){
WARN("histogram precision must be float");
return;
}
if( OBJ_COMPS(histo_dp) != 1 ){
WARN("histogram data must be real");
return;
}
if( OBJ_ROWS(histo_dp) > 1 || OBJ_FRAMES(histo_dp) > 1 ){
WARN("only using first row of histogram image");
}
if( OBJ_COMPS(data_dp) != 1 ){
WARN("input data must be real");
return;
}
switch( OBJ_PREC(data_dp) ){
case PREC_SP: HISTOGRAM(float) break;
case PREC_DP: HISTOGRAM(double) break;
case PREC_UBY: HISTOGRAM(u_char) break;
case PREC_BY: HISTOGRAM(char) break;
case PREC_UIN: HISTOGRAM(u_short) break;
case PREC_IN: HISTOGRAM(short) break;
case PREC_UDI: HISTOGRAM(u_long) break;
case PREC_DI: HISTOGRAM(long) break;
default:
NWARN("unhandled source precision in histogram");
return;
}
if( (n_under > 0) || (n_over > 0) ){
sprintf(ERROR_STRING,
"Histogram for %s had %d underflows and %d overflows",
OBJ_NAME(data_dp),n_under,n_over);
advise(ERROR_STRING);
}
}
//int _wav_to_dp(QSP_ARG_DECL Data_Obj *dp,Wav_Header *hd_p)
FIO_FT_TO_DP_FUNC(wav,Wav_Header)
{
Precision * prec_p;
dimension_t total_samples, samples_per_channel;
switch( hd_p->wh_bits_per_sample ){
case 8: prec_p=PREC_FOR_CODE(PREC_UBY); break;
case 16: prec_p=PREC_FOR_CODE(PREC_IN); break;
default:
sprintf(ERROR_STRING,
"wav_to_dp: unexpected # of bits per sample %d",
hd_p->wh_bits_per_sample);
warn(ERROR_STRING);
return(-1);
}
SET_OBJ_PREC_PTR(dp, prec_p);
SET_OBJ_COMPS(dp, hd_p->wh_n_channels );
total_samples = (dimension_t) (hd_p->wh_datasize / PREC_SIZE( prec_p ));
samples_per_channel = total_samples / OBJ_COMPS(dp);
SET_OBJ_COLS(dp, samples_per_channel);
SET_OBJ_ROWS(dp, 1);
SET_OBJ_FRAMES(dp, 1);
SET_OBJ_SEQS(dp, 1);
SET_OBJ_COMP_INC(dp, 1);
SET_OBJ_PXL_INC(dp, 1);
SET_OBJ_ROW_INC(dp, 1);
SET_OBJ_FRM_INC(dp, 1);
SET_OBJ_SEQ_INC(dp, 1);
SET_OBJ_PARENT(dp, NULL);
SET_OBJ_CHILDREN(dp, NULL);
SET_OBJ_AREA(dp, ram_area_p); /* the default */
/* dp->dt_data = hd_p->image; */ /* where do we allocate data??? */
SET_OBJ_N_TYPE_ELTS(dp, OBJ_COMPS(dp) * OBJ_COLS(dp) * OBJ_ROWS(dp)
* OBJ_FRAMES(dp) * OBJ_SEQS(dp) );
auto_shape_flags(OBJ_SHAPE(dp));
return 0;
}
void dp_choldc(Data_Obj *a_dp, Data_Obj *p_dp)
{
unsigned m, n;
void *a_rowlist[MAX_DIM];
/*
n=OBJ_ROWS(a_dp);
if( n > MAX_DIM ){
NWARN("Sorry, MAX dimension exceeded in dp_choldc");
sprintf(DEFAULT_ERROR_STRING,"dp_choldc: MAX_DIM = %d, n = %d", MAX_DIM,n);
NADVISE(DEFAULT_ERROR_STRING);
return;
}
*/
n=OBJ_COLS(a_dp);
m=OBJ_ROWS(a_dp);
if( n > MAX_DIM || m > MAX_DIM ){
NWARN("Sorry, MAX dimension exceeded in dp_choldc");
sprintf(DEFAULT_ERROR_STRING,"dp_choldc: MAX_DIM = %d, n = %d, m = %d",
MAX_DIM,n,m);
NADVISE(DEFAULT_ERROR_STRING);
return;
}
printf("nrmenu:numrec.c data %f\n", *((float *)OBJ_DATA_PTR(a_dp)));
if( OBJ_MACH_PREC(a_dp) == PREC_SP ){
float_init_rowlist((float **)(void *)a_rowlist,a_dp);
float_choldc(((float **)(void *)a_rowlist)-1,n,((float *)OBJ_DATA_PTR(p_dp))-1);
} else if( OBJ_MACH_PREC(a_dp) == PREC_DP ){
double_init_rowlist((double **)(void *)a_rowlist,a_dp);
double_choldc(((double **)(void *)a_rowlist)-1,n,((double *)OBJ_DATA_PTR(p_dp))-1);
}
else {
NWARN("bad machine precision in dp_choldc");
}
}
void set_texture_image(QSP_ARG_DECL Data_Obj *dp)
{
int code,prec;
/*glDepthFunc(GL_LEQUAL);
glPixelStorei(GL_UNPACK_ALIGNMENT,1);*/
if(OBJ_COMPS(dp)==1) code=GL_LUMINANCE;
else if( OBJ_COMPS(dp) == 3 ) code=GL_RGB;
else {
sprintf(ERROR_STRING,
"set_texture_image: Object %s has type dimension %d, expected 1 or 3",
OBJ_NAME(dp),OBJ_COMPS(dp));
warn(ERROR_STRING);
return;
}
if( OBJ_PREC(dp) == PREC_SP ) prec=GL_FLOAT;
else if( OBJ_PREC(dp) == PREC_UBY ) prec=GL_UNSIGNED_BYTE;
else {
sprintf(ERROR_STRING,"set_texture_image: Object %s has precision %s, expected %s or %s",
OBJ_NAME(dp),PREC_NAME(OBJ_PREC_PTR(dp)),
NAME_FOR_PREC_CODE(PREC_SP),NAME_FOR_PREC_CODE(PREC_UBY));
warn(ERROR_STRING);
return;
}
if( debug & gl_debug ) advise("glTexImage2D");
glTexImage2D(GL_TEXTURE_2D, 0, OBJ_COMPS(dp), OBJ_COLS(dp),
OBJ_ROWS(dp), 0, code, prec, OBJ_DATA_PTR(dp));
if( debug & gl_debug ) advise("glTexParameterf (4)");
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
if( debug & gl_debug ) advise("glTexEnv");
glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE);
/*glEnable(GL_TEXTURE_2D);
glShadeModel(GL_FLAT);*/
}
void _dpair_iterate(QSP_ARG_DECL Data_Obj *dp1,Data_Obj *dp2,void (*func)(QSP_ARG_DECL Data_Obj *,index_t,Data_Obj *,index_t))
{
dimension_t comp,col,row,frm,seq;
/* offsets for sequence, frame, row, pixel, component */
dimension_t s_os1, f_os1, r_os1, p_os1, c_os1;
dimension_t s_os2, f_os2, r_os2, p_os2, c_os2;
s_os1=0;
s_os2=0;
for(seq=0;seq<OBJ_SEQS(dp1);seq++){
f_os1 = s_os1;
f_os2 = s_os2;
for(frm=0;frm<OBJ_FRAMES(dp1);frm++){
r_os1 = f_os1;
r_os2 = f_os2;
for(row=0;row<OBJ_ROWS(dp1);row++){
p_os1 = r_os1;
p_os2 = r_os2;
for(col=0;col<OBJ_COLS(dp1);col++){
c_os1 = p_os1;
c_os2 = p_os2;
for(comp=0;comp<OBJ_COMPS(dp1);comp++){
(*func)(QSP_ARG dp1,c_os1,dp2,c_os2);
c_os1 += OBJ_COMP_INC(dp1);
c_os2 += OBJ_COMP_INC(dp2);
}
p_os1 += OBJ_PXL_INC(dp1);
p_os2 += OBJ_PXL_INC(dp2);
}
r_os1 += OBJ_ROW_INC(dp1);
r_os2 += OBJ_ROW_INC(dp2);
}
f_os1 += OBJ_FRM_INC(dp1);
f_os2 += OBJ_FRM_INC(dp2);
}
s_os1 += OBJ_SEQ_INC(dp1);
s_os2 += OBJ_SEQ_INC(dp2);
}
}
void wrap(QSP_ARG_DECL Data_Obj *dst_dp,Data_Obj *src_dp)
{
int status;
Vector_Function *vfp;
vfp=FIND_VEC_FUNC(FVMOV);
if( (status=old_cksiz(QSP_ARG VF_FLAGS(vfp),dst_dp,src_dp))==(-1)) return;
#ifdef CAUTIOUS
if( status!=0){
sprintf(ERROR_STRING,"CAUTIOUS: wrap: old_cksiz() error...");
WARN(ERROR_STRING);
}
#endif /* CAUTIOUS */
if( dp_same_prec(dst_dp,src_dp,"wrap") == 0 ) return;
#ifdef FOOBAR
if( cktype(dst_dp,src_dp)==(-1)) return;
#endif /* FOOBAR */
dp_scroll(QSP_ARG dst_dp,src_dp,(incr_t)(OBJ_COLS(dst_dp)/2),(incr_t)(OBJ_ROWS(dst_dp)/2));
}
void add_impulse(double amp,Data_Obj *image_dp,Data_Obj *ir_dp,posn_t x,posn_t y)
{
float *image_ptr, *irptr;
incr_t i,j;
incr_t yos,xos,offset; /* offsets into image */
incr_t iryos,iros; /* offsets into impulse response */
incr_t pinc, ir_pinc;
pinc = OBJ_PXL_INC(image_dp);
ir_pinc = OBJ_PXL_INC(ir_dp);
image_ptr = (float *) OBJ_DATA_PTR(image_dp);
irptr = (float *) OBJ_DATA_PTR(ir_dp);
j=OBJ_ROWS(ir_dp);
while( j-- ){ /* foreach impulse row */
yos = ((y+j)-OBJ_ROWS(ir_dp)/2);
#ifdef NOWRAP
if( yos < 0 || yos >= (incr_t) OBJ_ROWS(image_dp) ) continue;
#else
if( yos < 0 ) yos+=OBJ_ROWS(image_dp);
else if( yos >= OBJ_ROWS(image_dp) ) yos-=OBJ_ROWS(image_dp);
#endif /* NOWRAP */
yos *= OBJ_ROW_INC(image_dp);
iryos = j * OBJ_ROW_INC(ir_dp);
i=OBJ_COLS(ir_dp);
while(i--){
xos = ((x+i)-OBJ_COLS(ir_dp)/2);
#ifdef NOWRAP
if( xos < 0 || xos >= (incr_t) OBJ_COLS(image_dp) ) continue;
#else
if( xos < 0 ) xos+=OBJ_COLS(image_dp);
else if( xos >= OBJ_COLS(image_dp) ) xos-=OBJ_COLS(image_dp);
#endif /* NOWRAP */
offset = (yos + xos*pinc);
iros = (iryos + i*ir_pinc);
*(image_ptr+offset) += *(irptr+iros) * amp;
}
}
}
static void _ocl_offset_data(QSP_ARG_DECL Data_Obj *dp, index_t offset)
{
#ifndef USE_OPENCL_SUBREGION
/* The original code used subBuffers, but overlapping subregions
* don't work...
* So instead we use a common memory buffer, but keep track
* of the starting offset (in elements). This offset has
* to be passed to the kernels.
*/
//fprintf(stderr,"ocl_offset_data: obj %s, offset = %d\n",OBJ_NAME(dp),offset);
//fprintf(stderr,"\tparent obj %s, parent offset = %d\n",OBJ_NAME(OBJ_PARENT(dp)),
//OBJ_OFFSET(OBJ_PARENT(dp)));
if( IS_COMPLEX(dp) ){
assert( (offset & 1) == 0 );
offset /= 2;
//fprintf(stderr,"Adjusted offset (%d) for complex object %s\n",offset,OBJ_NAME(dp));
} else if( IS_QUAT(dp) ){
assert( (offset & 3) == 0 );
offset /= 4;
}
SET_OBJ_DATA_PTR(dp,OBJ_DATA_PTR(OBJ_PARENT(dp)));
SET_OBJ_OFFSET( dp, OBJ_OFFSET(OBJ_PARENT(dp)) + offset );
#else // USE_OPENCL_SUBREGION
cl_mem buf;
cl_mem parent_buf;
cl_buffer_region reg;
cl_int status;
int extra_offset;
parent_buf = find_parent_buf(OBJ_PARENT(dp),&extra_offset);
assert( parent_buf != NULL );
reg.origin = (offset+extra_offset) * ELEMENT_SIZE(dp);
// No - the region has to be big enough for all of the elements.
// The safest thing is to include everything from the start
// of the subregion to the end of the parent. Note that this
// cannot handle negative increments!?
// reg.size = OBJ_N_MACH_ELTS(dp) * ELEMENT_SIZE(dp);
// p p p p p p p
// p p c c c p p
// p p p p p p p
// p p c c c p p
reg.size = OBJ_SEQ_INC(dp)*(OBJ_SEQS(dp)-1)
+ OBJ_FRM_INC(dp)*(OBJ_FRAMES(dp)-1)
+ OBJ_ROW_INC(dp)*(OBJ_ROWS(dp)-1)
+ OBJ_PXL_INC(dp)*(OBJ_COLS(dp)-1)
+ OBJ_COMP_INC(dp)*(OBJ_COMPS(dp)-1)
+ 1;
reg.size *= ELEMENT_SIZE(dp);
//fprintf(stderr,"requesting subregion of %ld bytes at offset %ld\n",
//reg.size,reg.origin);
buf = clCreateSubBuffer ( parent_buf,
CL_MEM_READ_WRITE,
CL_BUFFER_CREATE_TYPE_REGION,
®,
&status);
if( status != CL_SUCCESS ){
report_ocl_error(status, "clCreateSubBuffer");
SET_OBJ_DATA_PTR(dp,OBJ_DATA_PTR(OBJ_PARENT(dp)));
} else {
SET_OBJ_DATA_PTR(dp,buf);
}
// BUG - Because this object doesn't "own" the data, the sub-buffer
// won't be released when the object is destroyed, a possible memory
// leak...
// We need to add a special case, or make data releasing a
// platform-specific function...
#endif // USE_OPENCL_SUBREGION
}
// This is the normal display path
static void update_pf_viewer(QSP_ARG_DECL Platform_Viewer *pvp, Data_Obj *dp)
{
#ifdef HAVE_OPENGL
int t;
//cudaError_t e;
// unmap buffer before using w/ GL
if( BUF_IS_MAPPED(dp) ){
if( (*PF_UNMAPBUF_FN(PFDEV_PLATFORM(OBJ_PFDEV(dp))))
(QSP_ARG dp) < 0 ) {
WARN("update_pf_viewer: buffer unmap error!?");
}
#ifdef FOOBAR
e = cudaGLUnmapBufferObject( OBJ_BUF_ID(dp) );
if( e != cudaSuccess ){
describe_cuda_driver_error2("update_pf_viewer",
"cudaGLUnmapBufferObject",e);
NERROR1("failed to unmap buffer object");
}
#endif // FOOBAR
CLEAR_OBJ_FLAG_BITS(dp, DT_BUF_MAPPED);
// propagate change to children and parents
propagate_flag(dp,DT_BUF_MAPPED);
}
//
//bind_texture(OBJ_DATA_PTR(dp));
glClear(GL_COLOR_BUFFER_BIT);
/*
sprintf(ERROR_STRING,"update_pf_viewer: tex_id = %d, buf_id = %d",
OBJ_TEX_ID(dp),OBJ_BUF_ID(dp));
advise(ERROR_STRING);
*/
glBindTexture(GL_TEXTURE_2D, OBJ_TEX_ID(dp));
// is glBindBuffer REALLY part of libGLEW???
//#ifdef HAVE_LIBGLEW
glBindBuffer(GL_PIXEL_UNPACK_BUFFER, OBJ_BUF_ID(dp));
//#endif // HAVE_LIBGLEW
#ifdef FOOBAR
switch(OBJ_COMPS(dp)){
/* what used to be here??? */
}
#endif /* FOOBAR */
t=gl_pixel_type(dp);
glTexSubImage2D(GL_TEXTURE_2D, 0, // target, level
0, 0, // x0, y0
OBJ_COLS(dp), OBJ_ROWS(dp), // dx, dy
t,
GL_UNSIGNED_BYTE, // type
OFFSET(0)); // offset into PIXEL_UNPACK_BUFFER
//#ifdef HAVE_LIBGLEW
glBindBuffer(GL_PIXEL_UNPACK_BUFFER, 0);
//#endif // HAVE_LIBGLEW
glBegin(GL_QUADS);
glTexCoord2f(0, 1); glVertex2f(-1.0, -1.0);
glTexCoord2f(0, 0); glVertex2f(-1.0, 1.0);
glTexCoord2f(1, 0); glVertex2f(1.0, 1.0);
glTexCoord2f(1, 1); glVertex2f(1.0, -1.0);
glEnd();
glBindTexture(GL_TEXTURE_2D, 0);
#ifdef FOOBAR
e = cudaGLMapBufferObject( &OBJ_DATA_PTR(dp), OBJ_BUF_ID(dp) );
if( e != cudaSuccess ){
WARN("Error mapping buffer object!?");
// should we return now, with possibly other cleanup???
}
#endif // FOOBAR
if( (*PF_MAPBUF_FN(PFDEV_PLATFORM(OBJ_PFDEV(dp))))(QSP_ARG dp) < 0 ){
WARN("update_pf_viewer: Error mapping buffer!?");
}
SET_OBJ_FLAG_BITS(dp, DT_BUF_MAPPED);
// propagate change to children and parents
propagate_flag(dp,DT_BUF_MAPPED);
#else // ! HAVE_OPENGL
NO_OGL_MSG
#endif // ! HAVE_OPENGL
}
void dp_svbksb(Data_Obj *x_dp, Data_Obj *u_dp, Data_Obj *w_dp, Data_Obj *v_dp, Data_Obj *b_dp)
{
unsigned m,n;
void *u_rowlist[MAX_DIM], *v_rowlist[MAX_DIM];
n=OBJ_COLS(u_dp);
m=OBJ_ROWS(u_dp);
if( m < n ){
sprintf(DEFAULT_ERROR_STRING,"dp_svbksb: matrix %s (%d x %d) cannot be wider than tall",
OBJ_NAME(u_dp),m,n);
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( OBJ_COLS(w_dp) != n ){
sprintf(DEFAULT_ERROR_STRING,
"dimension of eigenvalue vector %s (%d) must be match # of columns of matrix %s (%d)",
OBJ_NAME(w_dp),OBJ_COLS(w_dp),OBJ_NAME(u_dp),n);
NWARN(DEFAULT_ERROR_STRING);
return;
}
if(OBJ_ROWS(w_dp) != 1){
sprintf(DEFAULT_ERROR_STRING,"dp_svbksb: eigenvalue vector %s (%d rows) should be a row vector!?",
OBJ_NAME(w_dp),OBJ_ROWS(w_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if(OBJ_ROWS(b_dp) != 1){
sprintf(DEFAULT_ERROR_STRING,"dp_svbksb: data vector %s (%d rows) should be a row vector!?",
OBJ_NAME(b_dp),OBJ_ROWS(b_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( OBJ_ROWS(x_dp) != 1 ){
sprintf(DEFAULT_ERROR_STRING,"dp_svbksb: weight vector %s (%d rows) should be a row vector!?",
OBJ_NAME(x_dp),OBJ_ROWS(x_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( OBJ_COLS(v_dp) != n || OBJ_ROWS(v_dp) != n ){
sprintf(DEFAULT_ERROR_STRING,"dp_svbksb: V matrix %s (%d x %d) should be square with dimension %d",
OBJ_NAME(v_dp),OBJ_ROWS(v_dp),OBJ_COLS(v_dp),n);
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( OBJ_ROWS(u_dp) > MAX_DIM ){
sprintf(DEFAULT_ERROR_STRING,"dp_svbksb: matrix %s has %d rows, max is %d",
OBJ_NAME(u_dp),OBJ_ROWS(u_dp),MAX_DIM);
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( OBJ_ROWS(v_dp) > MAX_DIM ){
sprintf(DEFAULT_ERROR_STRING,"dp_svbksb: matrix %s has %d rows, max is %d",
OBJ_NAME(v_dp),OBJ_ROWS(u_dp),MAX_DIM);
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( OBJ_COLS(b_dp) != OBJ_ROWS(u_dp) ){
sprintf(DEFAULT_ERROR_STRING,"dp_svbksb: Number of elements of data vector %s (%ld) should match number of rows of U matrix %s (%ld)",
OBJ_NAME(b_dp),(long)OBJ_COLS(b_dp),OBJ_NAME(u_dp),(long)OBJ_ROWS(u_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
/* BUG make sure precisions match */
if( OBJ_MACH_PREC(u_dp) == PREC_SP ){
float_init_rowlist((float **)(void *)u_rowlist,u_dp);
float_init_rowlist((float **)(void *)v_rowlist,v_dp);
//advise("calling float_svbksb...");
float_svbksb(((float **)(void *)u_rowlist)-1,((float *)OBJ_DATA_PTR(w_dp))-1,((float **)(void *)v_rowlist)-1,
m,n,(((float *)OBJ_DATA_PTR(b_dp))-1),(((float *)OBJ_DATA_PTR(x_dp))-1));
//advise("back from float_svbksb...");
} else if( OBJ_MACH_PREC(u_dp) == PREC_DP ){
double_init_rowlist((double **)(void *)u_rowlist,u_dp);
double_init_rowlist((double **)(void *)v_rowlist,v_dp);
double_svbksb(((double **)(void *)u_rowlist)-1,((double *)OBJ_DATA_PTR(w_dp))-1,((double **)(void *)v_rowlist)-1,
m,n,(((double *)OBJ_DATA_PTR(b_dp))-1),(((double *)OBJ_DATA_PTR(x_dp))-1));
} else {
NWARN("bad precision in dp_svbksb");
}
}
void dp_svd(Data_Obj *a_dp, Data_Obj *w_dp, Data_Obj *v_dp)
{
unsigned m,n;
void *a_rowlist[MAX_DIM], *v_rowlist[MAX_DIM];
n=OBJ_COLS(a_dp);
m=OBJ_ROWS(a_dp);
if( n > MAX_DIM || m > MAX_DIM ){
NWARN("Sorry, MAX dimension exceeded in dp_svd");
sprintf(DEFAULT_ERROR_STRING,"dp_svdcmp: MAX_DIM = %d, n = %d, m = %d",
MAX_DIM,n,m);
NADVISE(DEFAULT_ERROR_STRING);
return;
}
/*
if( m < n ){
sprintf(DEFAULT_ERROR_STRING,"dp_svdcmp: input matrix %s (%d x %d) cannot be wider than tall!?",
OBJ_NAME(a_dp),m,n);
NWARN(DEFAULT_ERROR_STRING);
return;
}
*/
if( OBJ_COLS(w_dp) != n ){
sprintf(DEFAULT_ERROR_STRING,"dp_svdcmp: weight vector %s should have %d columns, to match input matrix %s!?",
OBJ_NAME(w_dp),n,OBJ_NAME(a_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if(OBJ_ROWS(w_dp) != 1 ){
sprintf(DEFAULT_ERROR_STRING,"dp_svdcmp: weight vector %s should be a vector, (rows = %d)!?",
OBJ_NAME(w_dp),OBJ_ROWS(w_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
if( OBJ_COLS(v_dp) != n || OBJ_ROWS(v_dp) != n ){
sprintf(DEFAULT_ERROR_STRING,
"V matrix %s should be square with dimension %d, to match # columns of input %s",
OBJ_NAME(v_dp),n,OBJ_NAME(a_dp));
NWARN(DEFAULT_ERROR_STRING);
return;
}
/* BUG make sure all vectors have same precision */
if( OBJ_MACH_PREC(a_dp) == PREC_SP ){
float_init_rowlist((float **)(void *)a_rowlist,a_dp);
float_init_rowlist((float **)(void *)v_rowlist,v_dp);
//advise("calling float_svdcmp");
float_svdcmp(((float **)(void *)a_rowlist)-1,m,n,((float *)OBJ_DATA_PTR(w_dp))-1,((float **)(void *)v_rowlist)-1);
//advise("back from float_svdcmp");
/* The eigenvectors aren't sorted by numerical recipes... */
//float_sort_svd_eigenvectors(a_dp,w_dp,v_dp);
} else if( OBJ_MACH_PREC(a_dp) == PREC_DP ){
double_init_rowlist((double **)(void *)a_rowlist,a_dp);
double_init_rowlist((double **)(void *)v_rowlist,v_dp);
//advise("calling double_svdcmp");
double_svdcmp(((double **)(void *)a_rowlist)-1,m,n,((double *)OBJ_DATA_PTR(w_dp))-1,((double **)(void *)v_rowlist)-1);
//advise("back from double_svdcmp");
/* The eigenvectors aren't sorted by numerical recipes... */
//double_sort_svd_eigenvectors(a_dp,w_dp,v_dp);
}
else {
NWARN("bad machine precision in dp_svd");
}
}