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
|
#include "rb_lapack.h"
extern VOID slarft_(char* direct, char* storev, integer* n, integer* k, real* v, integer* ldv, real* tau, real* t, integer* ldt);
static VALUE
rblapack_slarft(int argc, VALUE *argv, VALUE self){
VALUE rblapack_direct;
char direct;
VALUE rblapack_storev;
char storev;
VALUE rblapack_n;
integer n;
VALUE rblapack_v;
real *v;
VALUE rblapack_tau;
real *tau;
VALUE rblapack_t;
real *t;
VALUE rblapack_v_out__;
real *v_out__;
integer ldv;
integer k;
integer ldt;
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 t, v = NumRu::Lapack.slarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* SLARFT forms the triangular factor T of a real block reflector H\n* of order n, which is defined as a product of k elementary reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) REAL array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) REAL array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n* ( v1 1 ) ( 1 v2 v2 v2 )\n* ( v1 v2 1 ) ( 1 v3 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n* ( v1 v2 v3 ) ( v2 v2 v2 1 )\n* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n* ( 1 v3 )\n* ( 1 )\n*\n* =====================================================================\n*\n\n");
return Qnil;
}
if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.slarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n");
return Qnil;
}
} else
rblapack_options = Qnil;
if (argc != 5 && argc != 5)
rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
rblapack_direct = argv[0];
rblapack_storev = argv[1];
rblapack_n = argv[2];
rblapack_v = argv[3];
rblapack_tau = argv[4];
if (argc == 5) {
} else if (rblapack_options != Qnil) {
} else {
}
direct = StringValueCStr(rblapack_direct)[0];
n = NUM2INT(rblapack_n);
if (!NA_IsNArray(rblapack_tau))
rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
if (NA_RANK(rblapack_tau) != 1)
rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
k = NA_SHAPE0(rblapack_tau);
if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
tau = NA_PTR_TYPE(rblapack_tau, real*);
storev = StringValueCStr(rblapack_storev)[0];
ldt = k;
if (!NA_IsNArray(rblapack_v))
rb_raise(rb_eArgError, "v (4th argument) must be NArray");
if (NA_RANK(rblapack_v) != 2)
rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
ldv = NA_SHAPE0(rblapack_v);
if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
if (NA_TYPE(rblapack_v) != NA_SFLOAT)
rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
v = NA_PTR_TYPE(rblapack_v, real*);
{
na_shape_t shape[2];
shape[0] = ldt;
shape[1] = k;
rblapack_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
}
t = NA_PTR_TYPE(rblapack_t, real*);
{
na_shape_t shape[2];
shape[0] = ldv;
shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
rblapack_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
}
v_out__ = NA_PTR_TYPE(rblapack_v_out__, real*);
MEMCPY(v_out__, v, real, NA_TOTAL(rblapack_v));
rblapack_v = rblapack_v_out__;
v = v_out__;
slarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
return rb_ary_new3(2, rblapack_t, rblapack_v);
}
void
init_lapack_slarft(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
sHelp = sH;
sUsage = sU;
rblapack_ZERO = zero;
rb_define_module_function(mLapack, "slarft", rblapack_slarft, -1);
}
|
