#include typedef double complex TCD; typedef float complex TCF; #undef complex #include "lapack-aux.h" #define V(x) x##n,x##p #include #include #include #include #include #define MACRO(B) do {B} while (0) #define ERROR(CODE) MACRO(return CODE;) #define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);}) #define OK return 0; #define MIN(A,B) ((A)<(B)?(A):(B)) #define MAX(A,B) ((A)>(B)?(A):(B)) #ifdef DBG #define DEBUGMSG(M) printf("*** calling aux C function: %s\n",M); #else #define DEBUGMSG(M) #endif #define CHECK(RES,CODE) MACRO(if(RES) return CODE;) #define BAD_SIZE 2000 #define BAD_CODE 2001 #define MEM 2002 #define BAD_FILE 2003 int sumF(KFVEC(x),FVEC(r)) { DEBUGMSG("sumF"); REQUIRES(rn==1,BAD_SIZE); int i; float res = 0; for (i = 0; i < xn; i++) res += xp[i]; rp[0] = res; OK } int sumR(KDVEC(x),DVEC(r)) { DEBUGMSG("sumR"); REQUIRES(rn==1,BAD_SIZE); int i; double res = 0; for (i = 0; i < xn; i++) res += xp[i]; rp[0] = res; OK } int sumI(KIVEC(x),IVEC(r)) { REQUIRES(rn==1,BAD_SIZE); int i; int res = 0; for (i = 0; i < xn; i++) res += xp[i]; rp[0] = res; OK } int sumQ(KQVEC(x),QVEC(r)) { DEBUGMSG("sumQ"); REQUIRES(rn==1,BAD_SIZE); int i; complex res; res.r = 0; res.i = 0; for (i = 0; i < xn; i++) { res.r += xp[i].r; res.i += xp[i].i; } rp[0] = res; OK } int sumC(KCVEC(x),CVEC(r)) { DEBUGMSG("sumC"); REQUIRES(rn==1,BAD_SIZE); int i; doublecomplex res; res.r = 0; res.i = 0; for (i = 0; i < xn; i++) { res.r += xp[i].r; res.i += xp[i].i; } rp[0] = res; OK } int prodF(KFVEC(x),FVEC(r)) { DEBUGMSG("prodF"); REQUIRES(rn==1,BAD_SIZE); int i; float res = 1; for (i = 0; i < xn; i++) res *= xp[i]; rp[0] = res; OK } int prodR(KDVEC(x),DVEC(r)) { DEBUGMSG("prodR"); REQUIRES(rn==1,BAD_SIZE); int i; double res = 1; for (i = 0; i < xn; i++) res *= xp[i]; rp[0] = res; OK } int prodI(KIVEC(x),IVEC(r)) { REQUIRES(rn==1,BAD_SIZE); int i; int res = 1; for (i = 0; i < xn; i++) res *= xp[i]; rp[0] = res; OK } int prodQ(KQVEC(x),QVEC(r)) { DEBUGMSG("prodQ"); REQUIRES(rn==1,BAD_SIZE); int i; complex res; float temp; res.r = 1; res.i = 0; for (i = 0; i < xn; i++) { temp = res.r * xp[i].r - res.i * xp[i].i; res.i = res.r * xp[i].i + res.i * xp[i].r; res.r = temp; } rp[0] = res; OK } int prodC(KCVEC(x),CVEC(r)) { DEBUGMSG("prodC"); REQUIRES(rn==1,BAD_SIZE); int i; doublecomplex res; double temp; res.r = 1; res.i = 0; for (i = 0; i < xn; i++) { temp = res.r * xp[i].r - res.i * xp[i].i; res.i = res.r * xp[i].i + res.i * xp[i].r; res.r = temp; } rp[0] = res; OK } double dnrm2_(integer*, const double*, integer*); double dasum_(integer*, const double*, integer*); double vector_max(KDVEC(x)) { double r = xp[0]; int k; for (k = 1; kr) { r = xp[k]; } } return r; } double vector_min(KDVEC(x)) { double r = xp[0]; int k; for (k = 1; kxp[r]) { r = k; } } return r; } double vector_min_index(KDVEC(x)) { int k, r = 0; for (k = 1; kr) { r = xp[k]; } } return r; } float vector_min_f(KFVEC(x)) { float r = xp[0]; int k; for (k = 1; kxp[r]) { r = k; } } return r; } float vector_min_index_f(KFVEC(x)) { int k, r = 0; for (k = 1; kr) { r = xp[k]; } } return r; } int vector_min_i(KIVEC(x)) { float r = xp[0]; int k; for (k = 1; kxp[r]) { r = k; } } return r; } int vector_min_index_i(KIVEC(x)) { int k, r = 0; for (k = 1; k0) { return +1.0; } else if (x<0) { return -1.0; } else { return 0.0; } } inline float float_sign(float x) { if(x>0) { return +1.0; } else if (x<0) { return -1.0; } else { return 0.0; } } #define OP(C,F) case C: { for(k=0;k0) { return m >=0 ? m : m+b; } else { return m <=0 ? m : m+b; } } int mapValI(int code, int* pval, KIVEC(x), IVEC(r)) { int k; int val = *pval; REQUIRES(xn == rn,BAD_SIZE); DEBUGMSG("mapValI"); switch (code) { OPV(0,val*xp[k]) OPV(1,val/xp[k]) OPV(2,val+xp[k]) OPV(3,val-xp[k]) OPV(6,mod(val,xp[k])) OPV(7,mod(xp[k],val)) default: ERROR(BAD_CODE); } } inline doublecomplex complex_add(doublecomplex a, doublecomplex b) { doublecomplex r; r.r = a.r+b.r; r.i = a.i+b.i; return r; } #define OPVb(C,E) case C: { for(k=0;k= 1 || S == 0); X = V1 * sqrt(-2 * log(S) / S); } else X = V2 * sqrt(-2 * log(S) / S); *phase = 1 - *phase; *pV1=V1; *pV2=V2; *pS=S; return X; } int random_vector(unsigned int seed, int code, DVEC(r)) { int phase = 0; double V1,V2,S; srandom(seed); int k; switch (code) { case 0: { // uniform for (k=0; k= 1 || S == 0); X = V1 * sqrt(-2 * log(S) / S); } else X = V2 * sqrt(-2 * log(S) / S); *phase = 1 - *phase; *pV1=V1; *pV2=V2; *pS=S; return X; } int random_vector(unsigned int seed, int code, DVEC(r)) { struct random_data buffer; char random_state[128]; memset(&buffer, 0, sizeof(struct random_data)); memset(random_state, 0, sizeof(random_state)); initstate_r(seed,random_state,sizeof(random_state),&buffer); // setstate_r(random_state,&buffer); // srandom_r(seed,&buffer); int phase = 0; double V1,V2,S; int k; switch (code) { case 0: { // uniform for (k=0; k *(double*)b; } int sort_valuesD(KDVEC(v),DVEC(r)) { memcpy(rp,vp,vn*sizeof(double)); qsort(rp,rn,sizeof(double),compare_doubles); OK } int compare_floats (const void *a, const void *b) { return *(float*)a > *(float*)b; } int sort_valuesF(KFVEC(v),FVEC(r)) { memcpy(rp,vp,vn*sizeof(float)); qsort(rp,rn,sizeof(float),compare_floats); OK } int compare_ints(const void *a, const void *b) { return *(int*)a > *(int*)b; } int sort_valuesI(KIVEC(v),IVEC(r)) { memcpy(rp,vp,vn*sizeof(int)); qsort(rp,rn,sizeof(int),compare_ints); OK } //////////////////////////////////////// #define SORTIDX_IMP(T,C) \ T* x = (T*)malloc(sizeof(T)*vn); \ int k; \ for (k=0;kval > ((DI*)b)->val; } int sort_indexD(KDVEC(v),IVEC(r)) { SORTIDX_IMP(DI,compare_doubles_i) } typedef struct FI { int pos; float val;} FI; int compare_floats_i (const void *a, const void *b) { return ((FI*)a)->val > ((FI*)b)->val; } int sort_indexF(KFVEC(v),IVEC(r)) { SORTIDX_IMP(FI,compare_floats_i) } typedef struct II { int pos; int val;} II; int compare_ints_i (const void *a, const void *b) { return ((II*)a)->val > ((II*)b)->val; } int sort_indexI(KIVEC(v),IVEC(r)) { SORTIDX_IMP(II,compare_ints_i) } //////////////////////////////////////////////////////////////////////////////// int round_vector(KDVEC(v),DVEC(r)) { int k; for(k=0; k