main() {
double ans, a, b, c;
a = 2.0;
b = -5.0;
c = 7.0;
printf( "\n\n Test of utility routines." );
printf( "\n\n" );
ans = dsqr( a );
printf( "\n a = %lf ans = dsqr( a ) = %lf", a, ans );
ans = dcub( a );
printf( "\n a = %lf ans = dcub( a ) = %lf", a, ans );
ans = dpow4( a );
printf( "\n a = %lf ans = dpow4( a ) = %lf", a, ans );
ans = dpow5( a );
printf( "\n a = %lf ans = dpow5( a ) = %lf", a, ans );
ans = dsgn( a );
printf( "\n a = %lf ans = dsgn( a ) = %lf", a, ans );
ans = dsgn( b );
printf( "\n b = %lf ans = dsgn( b ) = %lf", b, ans );
ans = dsign( a, b );
printf( "\n a = %lf, b = %lf, ans = sign( a, b ) = %lf", a, b, ans );
ans = dpythag( a, b );
printf( "\n a = %lf, b = %lf, ans = pythag( a, b ) = %lf", a, b, ans );
ans = dmin( a, b );
printf( "\n a = %lf, b = %lf, ans = dmin( a, b ) = %lf", a, b, ans );
ans = dmax( a, b );
printf( "\n a = %lf, b = %lf, ans = dmax( a, b ) = %lf", a, b, ans );
ans = dmin3( a, b, c );
printf( "\n a = %lf, b = %lf, c = %lf, ans = dmin3( a, b, c ) = %lf", a, b, c, ans );
ans = dmax3( a, b, c );
printf( "\n a = %lf, b = %lf, c = %lf, ans = dmax3( a, b, c ) = %lf", a, b, c, ans );
printf( "\n\n" );
}
/*
Given a matrix a[1..m][1..n], this routine computes its singular value decomposition,
A = U.W.transpose(V). The matrix U replaces a on output. The diagonal matrix of singular values
W is output as a vector w[1..n]. The matrix V (not its transpose) is output as v[1..n][1..n].
The matrix a must exist prior to calling this function (obviously), and so too must w and v.
*/
void dsvdcmp(double **a, int m, int n, double w[], double **v)
{
int flag,i,its,j,jj,k,l=0,nm=0;
double anorm,c,f,g,h,s,scale,x,y,z,*rv1;
rv1=dvector(1,n);
g=scale=anorm=0.0;
for (i=1;i<=n;i++) {
l=i+1;
rv1[i]=scale*g;
g=s=scale=0.0;
if (i <= m) {
for (k=i;k<=m;k++) scale += fabs(a[k][i]);
if (scale) {
for (k=i;k<=m;k++) {
a[k][i] /= scale;
s += a[k][i]*a[k][i];
}
f=a[i][i];
g = -SIGN(sqrt(s),f);
h=f*g-s;
a[i][i]=f-g;
for (j=l;j<=n;j++) {
for (s=0.0,k=i;k<=m;k++) s += a[k][i]*a[k][j];
f=s/h;
for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
}
for (k=i;k<=m;k++) a[k][i] *= scale;
}
}
w[i]=scale *g;
g=s=scale=0.0;
if (i <= m && i != n) {
for (k=l;k<=n;k++) scale += fabs(a[i][k]);
if (scale) {
for (k=l;k<=n;k++) {
a[i][k] /= scale;
s += a[i][k]*a[i][k];
}
f=a[i][l];
g = -SIGN(sqrt(s),f);
h=f*g-s;
a[i][l]=f-g;
for (k=l;k<=n;k++) rv1[k]=a[i][k]/h;
for (j=l;j<=m;j++) {
for (s=0.0,k=l;k<=n;k++) s += a[j][k]*a[i][k];
for (k=l;k<=n;k++) a[j][k] += s*rv1[k];
}
for (k=l;k<=n;k++) a[i][k] *= scale;
}
}
anorm=MAX(anorm,(fabs(w[i])+fabs(rv1[i])));
}
for (i=n;i>=1;i--) {
if (i < n) {
if (g) {
for (j=l;j<=n;j++) v[j][i]=(a[i][j]/a[i][l])/g;
for (j=l;j<=n;j++) {
for (s=0.0,k=l;k<=n;k++) s += a[i][k]*v[k][j];
for (k=l;k<=n;k++) v[k][j] += s*v[k][i];
}
}
for (j=l;j<=n;j++) v[i][j]=v[j][i]=0.0;
}
v[i][i]=1.0;
g=rv1[i];
l=i;
}
for (i=MIN(m,n);i>=1;i--) {
l=i+1;
g=w[i];
for (j=l;j<=n;j++) a[i][j]=0.0;
if (g) {
g=1.0/g;
for (j=l;j<=n;j++) {
for (s=0.0,k=l;k<=m;k++) s += a[k][i]*a[k][j];
f=(s/a[i][i])*g;
for (k=i;k<=m;k++) a[k][j] += f*a[k][i];
}
for (j=i;j<=m;j++) a[j][i] *= g;
} else for (j=i;j<=m;j++) a[j][i]=0.0;
++a[i][i];
}
for (k=n;k>=1;k--) {
for (its=1;its<=30;its++) {
flag=1;
for (l=k;l>=1;l--) {
nm=l-1;
if ((double)(fabs(rv1[l])+anorm) == anorm) {
flag=0;
break;
}
if ((double)(fabs(w[nm])+anorm) == anorm) break;
}
if (flag) {
c=0.0;
s=1.0;
for (i=l;i<=k;i++) {
f=s*rv1[i];
rv1[i]=c*rv1[i];
if ((double)(fabs(f)+anorm) == anorm) break;
g=w[i];
h=dpythag(f,g);
w[i]=h;
h=1.0/h;
c=g*h;
s = -f*h;
for (j=1;j<=m;j++) {
y=a[j][nm];
z=a[j][i];
a[j][nm]=y*c+z*s;
a[j][i]=z*c-y*s;
}
}
}
z=w[k];
if (l == k) {
if (z < 0.0) {
w[k] = -z;
for (j=1;j<=n;j++) v[j][k] = -v[j][k];
}
break;
}
if (its == 30) quit_error((char*)"no convergence in 30 dsvdcmp iterations");
x=w[l];
nm=k-1;
y=w[nm];
g=rv1[nm];
h=rv1[k];
f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y);
g=dpythag(f,1.0);
f=((x-z)*(x+z)+h*((y/(f+SIGN(g,f)))-h))/x;
c=s=1.0;
for (j=l;j<=nm;j++) {
i=j+1;
g=rv1[i];
y=w[i];
h=s*g;
g=c*g;
z=dpythag(f,h);
rv1[j]=z;
c=f/z;
s=h/z;
f=x*c+g*s;
g = g*c-x*s;
h=y*s;
y *= c;
for (jj=1;jj<=n;jj++) {
x=v[jj][j];
z=v[jj][i];
v[jj][j]=x*c+z*s;
v[jj][i]=z*c-x*s;
}
z=dpythag(f,h);
w[j]=z;
if (z) {
z=1.0/z;
c=f*z;
s=h*z;
}
f=c*g+s*y;
x=c*y-s*g;
for (jj=1;jj<=m;jj++) {
y=a[jj][j];
z=a[jj][i];
a[jj][j]=y*c+z*s;
a[jj][i]=z*c-y*s;
}
}
rv1[l]=0.0;
rv1[k]=f;
w[k]=x;
}
}
free_dvector(rv1,1,n);
return;
}
/**************************************************************************
Does singular value decomposition on m x n matrix a,
returning m x n matrix u in a, n x n matrices v, and in w the
n diagonal elements of an n x n diagonal matrix wm, such that
a = u . wm . vT -and- uT.u = 1 -and- vT.v = 1
*/
static int svdcmp(double **a, int m, int n) {
double *rv1 ;
double anorm,c,f,g,h,s,scale,x,y,z ;
int flag,i,its,j,jj,k,l,nm;
const char *me = "svdcmp" ;
if (!(rv1 = (double *)malloc(n*sizeof(double))))
return(punt(__LINE__,me,"can\'t allocate buffer.")) ;
g=scale=anorm=0.0;
for(i=0;i<n;i++) {
l=i+1;
rv1[i]=scale*g;
g=s=scale=0.0;
if (i<m) {
for (k=0;k<m;k++) scale += fabs(a[k][i]);
if (scale) {
for (k=i;k<m;k++) {
a[k][i] /= scale;
s += a[k][i]*a[k][i];
}
f=a[i][i];
g = -SIGN(sqrt(s),f);
h=f*g-s;
a[i][i]=f-g;
for (j=l;j<n;j++) {
for (s=0.0,k=i;k<m;k++) s += a[k][i]*a[k][j];
f=s/h;
for (k=i;k<m;k++) a[k][j] += f*a[k][i];
}
for (k=i;k<m;k++) a[k][i] *= scale;
}
}
w[i]=scale*g;
g=s=scale=0.0;
if (i < m && i < n) {
for (k=l;k<n;k++) scale += fabs(a[i][k]);
if (scale) {
for (k=l;k<n;k++) {
a[i][k] /= scale;
s += a[i][k]*a[i][k];
}
f=a[i][l];
g = -SIGN(sqrt(s),f);
h=f*g-s;
/* hmm */
a[i][l]=f-g;
for (k=l;k<n;k++) rv1[k]=a[i][k]/h;
for (j=l;j<m;j++) {
for (s=0.0,k=l;k<n;k++) s += a[j][k]*a[i][k];
for (k=l;k<n;k++) a[j][k] += s*rv1[k];
}
for (k=l;k<n;k++) a[i][k] *= scale;
}
}
anorm=MAX(anorm,(fabs(w[i])+fabs(rv1[i])));
}
for (i=n-1;i>=0;i--) {
if (i < n-1) {
if (g) {
for (j=l;j<n;j++) v[j][i]=(a[i][j]/a[i][l])/g;
for (j=l;j<n;j++) {
for (s=0.0,k=l;k<n;k++) s += a[i][k]*v[k][j];
for (k=l;k<n;k++) v[k][j] += s*v[k][i];
}
}
for (j=l;j<n;j++) v[i][j]=v[j][i]=0.0;
}
v[i][i]=1.0;
g=rv1[i];
l=i;
}
for (i=MIN(m,n)-1;i>=0;i--) {
l=i+1;
g=w[i];
for (j=l;j<n;j++) a[i][j]=0.0;
if (g) {
g=1.0/g;
for (j=l;j<n;j++) {
for (s=0.0,k=l;k<m;k++) s += a[k][i]*a[k][j];
f=(s/a[i][i])*g;
for (k=i;k<m;k++) a[k][j] += f*a[k][i];
}
for (j=i;j<m;j++) a[j][i] *= g;
} else for (j=i;j<m;j++) a[j][i]=0.0;
++a[i][i];
}
for (k=n-1;k>=0;k--) {
for (its=0;its<30;its++) {
flag=1;
for (l=k;l>=0;l--) {
nm=l-1;
if ((double)(fabs(rv1[l])+anorm) == anorm) {
flag=0;
break;
}
if ((double)(fabs(w[nm])+anorm) == anorm) break;
}
if (flag) {
c=0.0;
s=1.0;
for (i=l;i<=k;i++) {
f=s*rv1[i];
rv1[i]=c*rv1[i];
if ((double)(fabs(f)+anorm) == anorm) break;
g=w[i];
h=dpythag(f,g);
w[i]=h;
h=1.0/h;
c=g*h;
s = -f*h;
for (j=0;j<m;j++) {
y=a[j][nm];
z=a[j][i];
a[j][nm]=y*c+z*s;
a[j][i]=z*c-y*s;
}
}
}
z=w[k];
if (l == k) {
if (z < 0.0) {
w[k] = -z;
for (j=0;j<n;j++) v[j][k] = -v[j][k];
}
break;
}
if (its == 29)
return(punt(__LINE__,me,"no convergence in 30 iterations")) ;
x=w[l];
nm=k-1;
y=w[nm];
g=rv1[nm];
h=rv1[k];
f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y);
g=dpythag(f,1.0);
f=((x-z)*(x+z)+h*((y/(f+SIGN(g,f)))-h))/x;
c=s=1.0;
for (j=l;j<=nm;j++) {
i=j+1;
g=rv1[i];
y=w[i];
h=s*g;
g=c*g;
z=dpythag(f,h);
rv1[j]=z;
c=f/z;
s=h/z;
f=x*c+g*s;
g = g*c-x*s;
h=y*s;
y *= c;
for (jj=0;jj<n;jj++) {
x=v[jj][j];
z=v[jj][i];
v[jj][j]=x*c+z*s;
v[jj][i]=z*c-x*s;
}
z=dpythag(f,h);
w[j]=z;
if (z) {
z=1.0/z;
c=f*z;
s=h*z;
}
f=c*g+s*y;
x=c*y-s*g;
for (jj=0;jj<m;jj++) {
y=a[jj][j];
z=a[jj][i];
a[jj][j]=y*c+z*s;
a[jj][i]=z*c-y*s;
}
}
rv1[l]=0.0;
rv1[k]=f;
w[k]=x;
}
}
free(rv1) ;
return(OK) ;
}
