1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
#include "rb_lapack.h"
extern VOID dlarrf_(integer* n, doublereal* d, doublereal* l, doublereal* ld, integer* clstrt, integer* clend, doublereal* w, doublereal* wgap, doublereal* werr, doublereal* spdiam, doublereal* clgapl, doublereal* clgapr, doublereal* pivmin, doublereal* sigma, doublereal* dplus, doublereal* lplus, doublereal* work, integer* info);
static VALUE
rblapack_dlarrf(int argc, VALUE *argv, VALUE self){
VALUE rblapack_d;
doublereal *d;
VALUE rblapack_l;
doublereal *l;
VALUE rblapack_ld;
doublereal *ld;
VALUE rblapack_clstrt;
integer clstrt;
VALUE rblapack_clend;
integer clend;
VALUE rblapack_w;
doublereal *w;
VALUE rblapack_wgap;
doublereal *wgap;
VALUE rblapack_werr;
doublereal *werr;
VALUE rblapack_spdiam;
doublereal spdiam;
VALUE rblapack_clgapl;
doublereal clgapl;
VALUE rblapack_clgapr;
doublereal clgapr;
VALUE rblapack_pivmin;
doublereal pivmin;
VALUE rblapack_sigma;
doublereal sigma;
VALUE rblapack_dplus;
doublereal *dplus;
VALUE rblapack_lplus;
doublereal *lplus;
VALUE rblapack_info;
integer info;
VALUE rblapack_wgap_out__;
doublereal *wgap_out__;
doublereal *work;
integer n;
VALUE rblapack_options;
if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
argc--;
rblapack_options = argv[argc];
if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
printf("%s\n", "USAGE:\n sigma, dplus, lplus, info, wgap = NumRu::Lapack.dlarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO )\n\n* Purpose\n* =======\n*\n* Given the initial representation L D L^T and its cluster of close\n* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...\n* W( CLEND ), DLARRF finds a new relatively robust representation\n* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the\n* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix (subblock, if the matrix split).\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* L (input) DOUBLE PRECISION array, dimension (N-1)\n* The (N-1) subdiagonal elements of the unit bidiagonal\n* matrix L.\n*\n* LD (input) DOUBLE PRECISION array, dimension (N-1)\n* The (N-1) elements L(i)*D(i).\n*\n* CLSTRT (input) INTEGER\n* The index of the first eigenvalue in the cluster.\n*\n* CLEND (input) INTEGER\n* The index of the last eigenvalue in the cluster.\n*\n* W (input) DOUBLE PRECISION array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.\n* W( CLSTRT ) through W( CLEND ) form the cluster of relatively\n* close eigenalues.\n*\n* WGAP (input/output) DOUBLE PRECISION array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* The separation from the right neighbor eigenvalue in W.\n*\n* WERR (input) DOUBLE PRECISION array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* WERR contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue APPROXIMATION in W\n*\n* SPDIAM (input) DOUBLE PRECISION\n* estimate of the spectral diameter obtained from the\n* Gerschgorin intervals\n*\n* CLGAPL (input) DOUBLE PRECISION\n*\n* CLGAPR (input) DOUBLE PRECISION\n* absolute gap on each end of the cluster.\n* Set by the calling routine to protect against shifts too close\n* to eigenvalues outside the cluster.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence.\n*\n* SIGMA (output) DOUBLE PRECISION\n* The shift used to form L(+) D(+) L(+)^T.\n*\n* DPLUS (output) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the diagonal matrix D(+).\n*\n* LPLUS (output) DOUBLE PRECISION array, dimension (N-1)\n* The first (N-1) elements of LPLUS contain the subdiagonal\n* elements of the unit bidiagonal matrix L(+).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Workspace.\n*\n* INFO (output) INTEGER\n* Signals processing OK (=0) or failure (=1)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Beresford Parlett, University of California, Berkeley, USA\n* Jim Demmel, University of California, Berkeley, USA\n* Inderjit Dhillon, University of Texas, Austin, USA\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, University of California, Berkeley, USA\n*\n* =====================================================================\n*\n\n");
return Qnil;
}
if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
printf("%s\n", "USAGE:\n sigma, dplus, lplus, info, wgap = NumRu::Lapack.dlarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, [:usage => usage, :help => help])\n");
return Qnil;
}
} else
rblapack_options = Qnil;
if (argc != 12 && argc != 12)
rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
rblapack_d = argv[0];
rblapack_l = argv[1];
rblapack_ld = argv[2];
rblapack_clstrt = argv[3];
rblapack_clend = argv[4];
rblapack_w = argv[5];
rblapack_wgap = argv[6];
rblapack_werr = argv[7];
rblapack_spdiam = argv[8];
rblapack_clgapl = argv[9];
rblapack_clgapr = argv[10];
rblapack_pivmin = argv[11];
if (argc == 12) {
} else if (rblapack_options != Qnil) {
} else {
}
if (!NA_IsNArray(rblapack_d))
rb_raise(rb_eArgError, "d (1th argument) must be NArray");
if (NA_RANK(rblapack_d) != 1)
rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
n = NA_SHAPE0(rblapack_d);
if (NA_TYPE(rblapack_d) != NA_DFLOAT)
rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
d = NA_PTR_TYPE(rblapack_d, doublereal*);
if (!NA_IsNArray(rblapack_ld))
rb_raise(rb_eArgError, "ld (3th argument) must be NArray");
if (NA_RANK(rblapack_ld) != 1)
rb_raise(rb_eArgError, "rank of ld (3th argument) must be %d", 1);
if (NA_SHAPE0(rblapack_ld) != (n-1))
rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
if (NA_TYPE(rblapack_ld) != NA_DFLOAT)
rblapack_ld = na_change_type(rblapack_ld, NA_DFLOAT);
ld = NA_PTR_TYPE(rblapack_ld, doublereal*);
clend = NUM2INT(rblapack_clend);
spdiam = NUM2DBL(rblapack_spdiam);
clgapr = NUM2DBL(rblapack_clgapr);
if (!NA_IsNArray(rblapack_l))
rb_raise(rb_eArgError, "l (2th argument) must be NArray");
if (NA_RANK(rblapack_l) != 1)
rb_raise(rb_eArgError, "rank of l (2th argument) must be %d", 1);
if (NA_SHAPE0(rblapack_l) != (n-1))
rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
if (NA_TYPE(rblapack_l) != NA_DFLOAT)
rblapack_l = na_change_type(rblapack_l, NA_DFLOAT);
l = NA_PTR_TYPE(rblapack_l, doublereal*);
clgapl = NUM2DBL(rblapack_clgapl);
clstrt = NUM2INT(rblapack_clstrt);
if (!NA_IsNArray(rblapack_wgap))
rb_raise(rb_eArgError, "wgap (7th argument) must be NArray");
if (NA_RANK(rblapack_wgap) != 1)
rb_raise(rb_eArgError, "rank of wgap (7th argument) must be %d", 1);
if (NA_SHAPE0(rblapack_wgap) != (clend-clstrt+1))
rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", clend-clstrt+1);
if (NA_TYPE(rblapack_wgap) != NA_DFLOAT)
rblapack_wgap = na_change_type(rblapack_wgap, NA_DFLOAT);
wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*);
pivmin = NUM2DBL(rblapack_pivmin);
if (!NA_IsNArray(rblapack_w))
rb_raise(rb_eArgError, "w (6th argument) must be NArray");
if (NA_RANK(rblapack_w) != 1)
rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
if (NA_SHAPE0(rblapack_w) != (clend-clstrt+1))
rb_raise(rb_eRuntimeError, "shape 0 of w must be %d", clend-clstrt+1);
if (NA_TYPE(rblapack_w) != NA_DFLOAT)
rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
w = NA_PTR_TYPE(rblapack_w, doublereal*);
if (!NA_IsNArray(rblapack_werr))
rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
if (NA_RANK(rblapack_werr) != 1)
rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
if (NA_SHAPE0(rblapack_werr) != (clend-clstrt+1))
rb_raise(rb_eRuntimeError, "shape 0 of werr must be %d", clend-clstrt+1);
if (NA_TYPE(rblapack_werr) != NA_DFLOAT)
rblapack_werr = na_change_type(rblapack_werr, NA_DFLOAT);
werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
{
na_shape_t shape[1];
shape[0] = n;
rblapack_dplus = na_make_object(NA_DFLOAT, 1, shape, cNArray);
}
dplus = NA_PTR_TYPE(rblapack_dplus, doublereal*);
{
na_shape_t shape[1];
shape[0] = n-1;
rblapack_lplus = na_make_object(NA_DFLOAT, 1, shape, cNArray);
}
lplus = NA_PTR_TYPE(rblapack_lplus, doublereal*);
{
na_shape_t shape[1];
shape[0] = clend-clstrt+1;
rblapack_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
}
wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, doublereal*);
MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rblapack_wgap));
rblapack_wgap = rblapack_wgap_out__;
wgap = wgap_out__;
work = ALLOC_N(doublereal, (2*n));
dlarrf_(&n, d, l, ld, &clstrt, &clend, w, wgap, werr, &spdiam, &clgapl, &clgapr, &pivmin, &sigma, dplus, lplus, work, &info);
free(work);
rblapack_sigma = rb_float_new((double)sigma);
rblapack_info = INT2NUM(info);
return rb_ary_new3(5, rblapack_sigma, rblapack_dplus, rblapack_lplus, rblapack_info, rblapack_wgap);
}
void
init_lapack_dlarrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
sHelp = sH;
sUsage = sU;
rblapack_ZERO = zero;
rb_define_module_function(mLapack, "dlarrf", rblapack_dlarrf, -1);
}
|
