proteus
1.9.0
C/C++/Fortran libraries
Toggle main menu visibility
Loading...
Searching...
No Matches
work
cekees
proteus
proteus
fenton
Dsvdcmp.cpp
Go to the documentation of this file.
1
#include <math.h>
2
#include "
Allocation.h
"
3
4
static
double
dmaxarg1,dmaxarg2;
5
#define DMAX(a,b) (dmaxarg1=(a),dmaxarg2=(b),(dmaxarg1) > (dmaxarg2) ?\
6
(dmaxarg1) : (dmaxarg2))
7
static
int
iminarg1,iminarg2;
8
#define IMIN(a,b) (iminarg1=(a),iminarg2=(b),(iminarg1) < (iminarg2) ?\
9
(iminarg1) : (iminarg2))
10
11
#define SIGN(a,b) ((b) >= 0.0 ? fabs(a) : -fabs(a))
12
13
#include <stdio.h>
14
15
void
dsvdcmp
(
double
**a,
int
m,
int
n
,
double
w
[],
double
**
v
)
16
{
17
double
dpythag
(
double
a,
double
b);
18
int
flag,i,its,j,jj,k,l,nm;
19
double
anorm,
c
,
f
,g,h,
s
,scale,x,y,
z
,*rv1;
20
21
rv1=
dvector
(1,
n
);
22
g=scale=anorm=0.0;
23
for
(i=1;i<=
n
;i++) {
24
l=i+1;
25
rv1[i]=scale*g;
26
g=
s
=scale=0.0;
27
if
(i <= m) {
28
for
(k=i;k<=m;k++) scale += fabs(a[k][i]);
29
if
(scale) {
30
for
(k=i;k<=m;k++) {
31
a[k][i] /= scale;
32
s
+= a[k][i]*a[k][i];
33
}
34
f
=a[i][i];
35
g = -
SIGN
(sqrt(
s
),
f
);
36
h=
f
*g-
s
;
37
a[i][i]=
f
-g;
38
for
(j=l;j<=
n
;j++) {
39
for
(
s
=0.0,k=i;k<=m;k++)
s
+= a[k][i]*a[k][j];
40
f
=
s
/h;
41
for
(k=i;k<=m;k++) a[k][j] +=
f
*a[k][i];
42
}
43
for
(k=i;k<=m;k++) a[k][i] *= scale;
44
}
45
}
46
w
[i]=scale *g;
47
g=
s
=scale=0.0;
48
if
(i <= m && i !=
n
) {
49
for
(k=l;k<=
n
;k++) scale += fabs(a[i][k]);
50
if
(scale) {
51
for
(k=l;k<=
n
;k++) {
52
a[i][k] /= scale;
53
s
+= a[i][k]*a[i][k];
54
}
55
f
=a[i][l];
56
g = -
SIGN
(sqrt(
s
),
f
);
57
h=
f
*g-
s
;
58
a[i][l]=
f
-g;
59
for
(k=l;k<=
n
;k++) rv1[k]=a[i][k]/h;
60
for
(j=l;j<=m;j++) {
61
for
(
s
=0.0,k=l;k<=
n
;k++)
s
+= a[j][k]*a[i][k];
62
for
(k=l;k<=
n
;k++) a[j][k] +=
s
*rv1[k];
63
}
64
for
(k=l;k<=
n
;k++) a[i][k] *= scale;
65
}
66
}
67
anorm=
DMAX
(anorm,(fabs(
w
[i])+fabs(rv1[i])));
68
}
69
for
(i=
n
;i>=1;i--) {
70
if
(i <
n
) {
71
if
(g) {
72
for
(j=l;j<=
n
;j++)
v
[j][i]=(a[i][j]/a[i][l])/g;
73
for
(j=l;j<=
n
;j++) {
74
for
(
s
=0.0,k=l;k<=
n
;k++)
s
+= a[i][k]*
v
[k][j];
75
for
(k=l;k<=
n
;k++)
v
[k][j] +=
s
*
v
[k][i];
76
}
77
}
78
for
(j=l;j<=
n
;j++)
v
[i][j]=
v
[j][i]=0.0;
79
}
80
v
[i][i]=1.0;
81
g=rv1[i];
82
l=i;
83
}
84
for
(i=
IMIN
(m,
n
);i>=1;i--) {
85
l=i+1;
86
g=
w
[i];
87
for
(j=l;j<=
n
;j++) a[i][j]=0.0;
88
if
(g) {
89
g=1.0/g;
90
for
(j=l;j<=
n
;j++) {
91
for
(
s
=0.0,k=l;k<=m;k++)
s
+= a[k][i]*a[k][j];
92
f
=(
s
/a[i][i])*g;
93
for
(k=i;k<=m;k++) a[k][j] +=
f
*a[k][i];
94
}
95
for
(j=i;j<=m;j++) a[j][i] *= g;
96
}
else
for
(j=i;j<=m;j++) a[j][i]=0.0;
97
++a[i][i];
98
}
99
for
(k=
n
;k>=1;k--) {
100
for
(its=1;its<=30;its++) {
101
flag=1;
102
for
(l=k;l>=1;l--) {
103
nm=l-1;
104
if
((
double
)(fabs(rv1[l])+anorm) == anorm) {
105
flag=0;
106
break
;
107
}
108
if
((
double
)(fabs(
w
[nm])+anorm) == anorm)
break
;
109
}
110
if
(flag) {
111
c
=0.0;
112
s
=1.0;
113
for
(i=l;i<=k;i++) {
114
f
=
s
*rv1[i];
115
rv1[i]=
c
*rv1[i];
116
if
((
double
)(fabs(
f
)+anorm) == anorm)
break
;
117
g=
w
[i];
118
h=
dpythag
(
f
,g);
119
w
[i]=h;
120
h=1.0/h;
121
c
=g*h;
122
s
= -
f
*h;
123
for
(j=1;j<=m;j++) {
124
y=a[j][nm];
125
z
=a[j][i];
126
a[j][nm]=y*
c
+
z
*
s
;
127
a[j][i]=
z
*
c
-y*
s
;
128
}
129
}
130
}
131
z
=
w
[k];
132
if
(l == k) {
133
if
(
z
< 0.0) {
134
w
[k] = -
z
;
135
for
(j=1;j<=
n
;j++)
v
[j][k] = -
v
[j][k];
136
}
137
break
;
138
}
139
if
(its == 50) {fprintf(stderr,
"no convergence in 30 dsvdcmp iterations"
);}
140
x=
w
[l];
141
nm=k-1;
142
y=
w
[nm];
143
g=rv1[nm];
144
h=rv1[k];
145
f
=((y-
z
)*(y+
z
)+(g-h)*(g+h))/(2.0*h*y);
146
g=
dpythag
(
f
,1.0);
147
f
=((x-
z
)*(x+
z
)+h*((y/(
f
+
SIGN
(g,
f
)))-h))/x;
148
c
=
s
=1.0;
149
for
(j=l;j<=nm;j++) {
150
i=j+1;
151
g=rv1[i];
152
y=
w
[i];
153
h=
s
*g;
154
g=
c
*g;
155
z
=
dpythag
(
f
,h);
156
rv1[j]=
z
;
157
c
=
f
/
z
;
158
s
=h/
z
;
159
f
=x*
c
+g*
s
;
160
g = g*
c
-x*
s
;
161
h=y*
s
;
162
y *=
c
;
163
for
(jj=1;jj<=
n
;jj++) {
164
x=
v
[jj][j];
165
z
=
v
[jj][i];
166
v
[jj][j]=x*
c
+
z
*
s
;
167
v
[jj][i]=
z
*
c
-x*
s
;
168
}
169
z
=
dpythag
(
f
,h);
170
w
[j]=
z
;
171
if
(
z
) {
172
z
=1.0/
z
;
173
c
=
f
*
z
;
174
s
=h*
z
;
175
}
176
f
=
c
*g+
s
*y;
177
x=
c
*y-
s
*g;
178
for
(jj=1;jj<=m;jj++) {
179
y=a[jj][j];
180
z
=a[jj][i];
181
a[jj][j]=y*
c
+
z
*
s
;
182
a[jj][i]=
z
*
c
-y*
s
;
183
}
184
}
185
rv1[l]=0.0;
186
rv1[k]=
f
;
187
w
[k]=x;
188
}
189
}
190
free_dvector
(rv1,1,
n
);
191
}
192
Allocation.h
free_dvector
void free_dvector(double *v, long nl, long nh)
Definition
Util.cpp:38
dvector
double * dvector(long nl, long nh)
Definition
Util.cpp:7
dpythag
double dpythag(double a, double b)
Definition
Dpythag.cpp:5
IMIN
#define IMIN(a, b)
Definition
Dsvdcmp.cpp:8
DMAX
#define DMAX(a, b)
Definition
Dsvdcmp.cpp:5
dsvdcmp
void dsvdcmp(double **a, int m, int n, double w[], double **v)
Definition
Dsvdcmp.cpp:15
SIGN
#define SIGN(a, b)
Definition
Dsvdcmp.cpp:11
n
Int n
Definition
Headers.h:28
f
Double f
Definition
Headers.h:64
s
Double s
Definition
Headers.h:84
z
Double * z
Definition
Headers.h:49
v
Double v
Definition
Headers.h:95
c
#define c(i)
Definition
jf.h:21
w
#define w(x)
Definition
jf.h:22
Generated on
for proteus by
1.18.0