1 /*
2 * gretl -- Gnu Regression, Econometrics and Time-series Library
3 * Copyright (C) 2001 Allin Cottrell and Riccardo "Jack" Lucchetti
4 *
5 * This program is free software: you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation, either version 3 of the License, or
8 * (at your option) any later version.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this program. If not, see <http://www.gnu.org/licenses/>.
17 *
18 */
19
20 #include "libgretl.h"
21 #include "libset.h"
22 #include "gretl_mt.h"
23 #include "gretl_matrix.h"
24 #include "gretl_cmatrix.h"
25
26 #include <errno.h>
27 #include <assert.h>
28 #include <complex.h>
29
30 #include "gretl_f2c.h"
31 #include "clapack_double.h"
32 #include "clapack_complex.h"
33 #include "../../cephes/libprob.h"
34
35 #ifdef HAVE_FENV_H
36 # include <fenv.h>
37 #endif
38
39 #if defined(_OPENMP)
40 # include <omp.h>
41 #endif
42
43 #if defined(USE_AVX)
44 # define USE_SIMD 1
45 # if defined(HAVE_IMMINTRIN_H)
46 # include <immintrin.h>
47 # else
48 # include <mmintrin.h>
49 # include <xmmintrin.h>
50 # include <emmintrin.h>
51 # endif
52 #endif
53
54 /**
55 * SECTION:gretl_matrix
56 * @short_description: construct and manipulate matrices
57 * @title: Matrices
58 * @include: libgretl.h
59 *
60 * Libgretl implements most of the matrix functionality that is
61 * likely to be required in econometric calculation. For basics
62 * such as decomposition and inversion we use LAPACK as the
63 * underlying engine.
64 *
65 * To get yourself a gretl matrix, use gretl_matrix_alloc() or
66 * one of the more specialized constructors; to free such a
67 * matrix use gretl_matrix_free().
68 */
69
70 struct gretl_matrix_block_ {
71 int n;
72 double *val;
73 gretl_matrix **matrix;
74 };
75
76 #define gretl_is_vector(v) (v->rows == 1 || v->cols == 1)
77 #define matrix_is_scalar(m) (m->rows == 1 && m->cols == 1)
78
79 #define mdx(a,i,j) ((j)*a->rows+(i))
80
81 #define matrix_transp_get(m,i,j) (m->val[(i)*m->rows+(j)])
82 #define matrix_transp_set(m,i,j,x) (m->val[(i)*m->rows+(j)]=x)
83
84 #define cmatrix_transp_get(m,i,j) (m->z[(i)*m->rows+(j)])
85 #define cmatrix_transp_set(m,i,j,x) (m->z[(i)*m->rows+(j)]=x)
86
87 #define INFO_INVALID 0xdeadbeef
88 #define is_block_matrix(m) (m->info == (matrix_info *) INFO_INVALID)
89
90 #define is_one_by_one(m) (m->rows == 1 && m->cols == 1)
91
92 #define no_metadata(m) (m->info == NULL || is_block_matrix(m))
93
94 static int real_invert_symmetric_matrix (gretl_matrix *a,
95 int checked,
96 int verbose);
97
mval_malloc(size_t sz)98 static inline void *mval_malloc (size_t sz)
99 {
100 #if 0 /* ifdef USE_SIMD */
101 void *mem = NULL;
102 int err;
103
104 err = posix_memalign(&mem, 32, sz);
105 if (err) {
106 fprintf(stderr, "posix_memalign: failed\n");
107 }
108 return mem;
109 #else
110 /* forestall "invalid reads" by OpenBLAS */
111 return malloc(sz % 16 ? sz + 8 : sz);
112 #endif
113 }
114
mval_realloc(void * ptr,size_t sz)115 static inline void *mval_realloc (void *ptr, size_t sz)
116 {
117 /* comment as for mval_malloc() */
118 return realloc(ptr, sz % 16 ? sz + 8 : sz);
119 }
120
121 #define mval_free(m) free(m)
122
123 #ifdef USE_SIMD
124 # include "matrix_simd.c"
125 #endif
126
127 /* Below: setting of the maximal value of K = the shared inner
128 dimension in matrix multiplication for use of SIMD. Also
129 setting of the minimum value of M x N for doing matrix
130 addition and subtraction via SIMD. If these variables are
131 set to -1 that disables SIMD by default (though the user
132 can change that via the "set" command).
133 */
134
135 static int simd_k_max = 8; /* 2014-03-07: was -1 */
136 static int simd_mn_min = 16; /* 2014-03-07: was -1 */
137
set_simd_k_max(int k)138 void set_simd_k_max (int k)
139 {
140 simd_k_max = k;
141 }
142
get_simd_k_max(void)143 int get_simd_k_max (void)
144 {
145 return simd_k_max;
146 }
147
set_simd_mn_min(int mn)148 void set_simd_mn_min (int mn)
149 {
150 simd_mn_min = mn;
151 }
152
get_simd_mn_min(void)153 int get_simd_mn_min (void)
154 {
155 return simd_mn_min;
156 }
157
158 #define simd_add_sub(mn) (simd_mn_min > 0 && mn >= simd_mn_min)
159
160 #define SVD_SMIN 1.0e-9
161
162 /* maybe experiment with these? */
163 #define QR_RCOND_MIN 1.0e-14
164 #define QR_RCOND_WARN 1.0e-07
165
166 static int add_scalar_to_matrix (gretl_matrix *targ, double x);
167 static int gretl_matrix_copy_info (gretl_matrix *targ,
168 const gretl_matrix *src);
169
170 /* matrix metadata struct, not allocated by default */
171
172 struct matrix_info_ {
173 int t1;
174 int t2;
175 char **colnames;
176 char **rownames;
177 };
178
179 typedef enum {
180 COLNAMES = 1 << 0,
181 ROWNAMES = 1 << 1,
182 REVERSED = 1 << 2
183 } NameFlags;
184
185 /* Central accounting for error in matrix allocation */
186
187 static int gretl_matrix_err;
188
189 /* get, and clear, the matrix error code */
190
get_gretl_matrix_err(void)191 int get_gretl_matrix_err (void)
192 {
193 int ret = gretl_matrix_err;
194 gretl_matrix_err = 0;
195 return ret;
196 }
197
clear_gretl_matrix_err(void)198 void clear_gretl_matrix_err (void)
199 {
200 gretl_matrix_err = 0;
201 }
202
set_gretl_matrix_err(int err)203 static void set_gretl_matrix_err (int err)
204 {
205 if (gretl_matrix_err == 0) {
206 gretl_matrix_err = err;
207 }
208 }
209
wspace_fail(integer info,double w0)210 static int wspace_fail (integer info, double w0)
211 {
212 int iinfo = (int) info;
213
214 fprintf(stderr, "gretl_matrix: workspace query failed: info = %d, "
215 "work[0] = %g\n", iinfo, w0);
216 return E_DATA;
217 }
218
219 /* An efficient means of allocating temporary storage for lapack
220 operations: this should be used _only_ for temporary allocations
221 that would ordinarily be freed before returning from the function
222 in question. In this mode we keep the chunk around for future use,
223 expanding it as needed.
224 */
225
226 static void *lapack_mem_chunk;
227 static size_t lapack_mem_sz;
228
229 /* Note: we haven't yet figured out how to support TLS on OS X.
230 That means that we have to be careful _not_ to call any
231 functions that make use of lapack_malloc() in a threaded
232 context, on OS X.
233 */
234
235 #if defined(_OPENMP) && !defined(OS_OSX)
236 #pragma omp threadprivate(lapack_mem_chunk, lapack_mem_sz)
237 #endif
238
lapack_malloc(size_t sz)239 static void *lapack_malloc (size_t sz)
240 {
241 void *mem = NULL;
242
243 if (sz > lapack_mem_sz) {
244 void *chunk = realloc(lapack_mem_chunk, sz);
245
246 if (chunk != NULL) {
247 lapack_mem_chunk = mem = chunk;
248 lapack_mem_sz = sz;
249 }
250 } else {
251 mem = lapack_mem_chunk;
252 }
253
254 return mem;
255 }
256
lapack_realloc(void * p,size_t sz)257 static void *lapack_realloc (void *p, size_t sz)
258 {
259 return lapack_malloc(sz);
260 }
261
262 /**
263 * lapack_mem_free:
264 *
265 * Cleanup function, called by libgretl_cleanup(). Frees
266 * any memory that has been allocated internally as
267 * temporary workspace for LAPACK functions.
268 */
269
lapack_mem_free(void)270 void lapack_mem_free (void)
271 {
272 free(lapack_mem_chunk);
273 lapack_mem_chunk = NULL;
274 lapack_mem_sz = 0;
275 }
276
lapack_free(void * p)277 static void lapack_free (void *p)
278 {
279 return;
280 }
281
math_err_init(void)282 static void math_err_init (void)
283 {
284 errno = 0;
285 #ifdef HAVE_FENV_H
286 feclearexcept(FE_ALL_EXCEPT);
287 #endif
288 }
289
290 /* the following is called after math operations only
291 if @errno is found to be non-zero */
292
math_err_check(const char * msg,int errnum)293 static int math_err_check (const char *msg, int errnum)
294 {
295 #ifdef HAVE_FENV_H
296 int err = E_DATA;
297
298 if (!fetestexcept(FE_INVALID | FE_DIVBYZERO | FE_OVERFLOW)) {
299 /* we'll let "pure" underflow pass */
300 fprintf(stderr, "warning: calculation underflow\n");
301 err = 0;
302 } else {
303 gretl_errmsg_set_from_errno(msg, errnum);
304 }
305 feclearexcept(FE_ALL_EXCEPT);
306 errno = 0;
307 return err;
308 #else
309 gretl_errmsg_set_from_errno(msg, errnum);
310 errno = 0;
311 return E_DATA;
312 #endif
313 }
314
matrix_block_error(const char * f)315 static int matrix_block_error (const char *f)
316 {
317 fprintf(stderr, "CODING ERROR: illegal call to %s on "
318 "member of matrix block\n", f);
319 return E_DATA;
320 }
321
322 /**
323 * gretl_matrix_alloc:
324 * @rows: desired number of rows in matrix.
325 * @cols: desired number of columns.
326 *
327 * Returns: pointer to a newly allocated gretl_matrix, or NULL
328 * on failure. Note that the actual data storage is not
329 * initialized.
330 */
331
gretl_matrix_alloc(int rows,int cols)332 gretl_matrix *gretl_matrix_alloc (int rows, int cols)
333 {
334 gretl_matrix *m;
335 int n;
336
337 if (rows < 0 || cols < 0) {
338 fprintf(stderr, "gretl error: gretl_matrix_alloc: rows=%d, cols=%d\n",
339 rows, cols);
340 return NULL;
341 }
342
343 m = malloc(sizeof *m);
344 if (m == NULL) {
345 set_gretl_matrix_err(E_ALLOC);
346 return NULL;
347 }
348
349 n = rows * cols;
350
351 if (n == 0) {
352 m->val = NULL;
353 } else {
354 m->val = mval_malloc(n * sizeof *m->val);
355 if (m->val == NULL) {
356 set_gretl_matrix_err(E_ALLOC);
357 free(m);
358 return NULL;
359 }
360 }
361
362 m->rows = rows;
363 m->cols = cols;
364 m->is_complex = 0;
365 m->z = NULL;
366 m->info = NULL;
367
368 return m;
369 }
370
gretl_cmatrix_new(int r,int c)371 gretl_matrix *gretl_cmatrix_new (int r, int c)
372 {
373 gretl_matrix *m = gretl_matrix_alloc(2*r, c);
374
375 if (m != NULL) {
376 m->is_complex = 1;
377 m->z = (double complex *) m->val;
378 m->rows = r;
379 }
380 return m;
381 }
382
gretl_cmatrix_new0(int r,int c)383 gretl_matrix *gretl_cmatrix_new0 (int r, int c)
384 {
385 gretl_matrix *m = gretl_zero_matrix_new(2*r, c);
386
387 if (m != NULL) {
388 m->is_complex = 1;
389 m->z = (double complex *) m->val;
390 m->rows = r;
391 }
392 return m;
393 }
394
gretl_matching_matrix_new(int r,int c,const gretl_matrix * m)395 gretl_matrix *gretl_matching_matrix_new (int r, int c,
396 const gretl_matrix *m)
397 {
398 if (m->is_complex) {
399 return gretl_cmatrix_new(r, c);
400 } else {
401 return gretl_matrix_alloc(r, c);
402 }
403 }
404
matrix_set_complex(gretl_matrix * m,int c,int full)405 static int matrix_set_complex (gretl_matrix *m, int c, int full)
406 {
407 if (m == NULL) {
408 return E_INVARG;
409 } else if (c && !m->is_complex) {
410 if (full && m->rows % 2 != 0) {
411 return E_INVARG;
412 } else {
413 m->is_complex = 1;
414 m->z = (double complex *) m->val;
415 if (full) {
416 m->rows /= 2;
417 }
418 }
419 } else if (!c && m->is_complex) {
420 m->is_complex = 0;
421 m->z = NULL;
422 if (full) {
423 m->rows *= 2;
424 }
425 }
426
427 return 0;
428 }
429
gretl_matrix_set_complex(gretl_matrix * m,int c)430 int gretl_matrix_set_complex (gretl_matrix *m, int c)
431 {
432 return matrix_set_complex(m, c, 0);
433 }
434
gretl_matrix_set_complex_full(gretl_matrix * m,int c)435 int gretl_matrix_set_complex_full (gretl_matrix *m, int c)
436 {
437 return matrix_set_complex(m, c, 1);
438 }
439
gretl_matrix_block_destroy(gretl_matrix_block * B)440 void gretl_matrix_block_destroy (gretl_matrix_block *B)
441 {
442 int i;
443
444 if (B == NULL) {
445 return;
446 }
447
448 if (B->matrix != NULL) {
449 for (i=0; i<B->n; i++) {
450 free(B->matrix[i]);
451 }
452 free(B->matrix);
453 }
454
455 free(B->val);
456 free(B);
457 }
458
gretl_matrix_block_zero(gretl_matrix_block * B)459 void gretl_matrix_block_zero (gretl_matrix_block *B)
460 {
461 if (B != NULL && B->matrix != NULL) {
462 int i;
463
464 for (i=0; i<B->n; i++) {
465 gretl_matrix_zero(B->matrix[i]);
466 }
467 }
468 }
469
470 /* Create an array of n matrices. The "..." should be filled with (at
471 minimum) the number of rows and columns for the first matrix to
472 create, which will be written to the location given by @pm.
473 Following this there can be any number of triples of type
474 (gretl_matrix **, int, int), representing the location of a matrix
475 to be filled out and the desired number of rows and columns,
476 respectively. The argument list must be terminated by NULL.
477
478 This is supposed to economize on calls to alloc() and free(), since
479 we allocate a combined data block for all the matrices in the
480 array.
481
482 Matrices in this array should be destroyed by calling
483 gretl_matrix_block_destroy() on the block -- do NOT call
484 gretl_matrix_free on individual member-matrices.
485 */
486
gretl_matrix_block_new(gretl_matrix ** pm,...)487 gretl_matrix_block *gretl_matrix_block_new (gretl_matrix **pm, ...)
488 {
489 va_list ap;
490 gretl_matrix_block *B;
491 gretl_matrix **targ;
492 gretl_matrix *m;
493 size_t vsize = 0;
494 int i, err = 0;
495
496 B = malloc(sizeof *B);
497 if (B == NULL) {
498 return NULL;
499 }
500
501 /* first pass: determine the number of
502 (pointer, int, int) triples */
503 va_start(ap, pm);
504 for (i=1; ; i++) {
505 va_arg(ap, int);
506 va_arg(ap, int);
507 targ = va_arg(ap, gretl_matrix **);
508 if (targ == NULL) {
509 break;
510 }
511 }
512 va_end(ap);
513
514 /* initialize B */
515 B->n = i;
516 B->matrix = malloc(B->n * sizeof *B->matrix);
517 if (B->matrix == NULL) {
518 free(B);
519 return NULL;
520 }
521
522 /* NULL everything in case we fail */
523 B->val = NULL;
524 for (i=0; i<B->n; i++) {
525 B->matrix[i] = NULL;
526 }
527
528 /* now allocate and initialize the matrices */
529 for (i=0; i<B->n; i++) {
530 B->matrix[i] = malloc(sizeof **B->matrix);
531 if (B->matrix[i] == NULL) {
532 gretl_matrix_block_destroy(B);
533 return NULL;
534 }
535 B->matrix[i]->info = (matrix_info *) INFO_INVALID;
536 B->matrix[i]->val = NULL;
537 B->matrix[i]->z = NULL;
538 B->matrix[i]->is_complex = 0;
539 }
540
541 /* second pass through arg list */
542
543 va_start(ap, pm);
544
545 for (i=0; i<B->n; i++) {
546 m = B->matrix[i];
547 if (i == 0) {
548 *pm = m;
549 } else {
550 targ = va_arg(ap, gretl_matrix **);
551 *targ = m;
552 }
553 m->rows = va_arg(ap, int);
554 m->cols = va_arg(ap, int);
555 if (m->rows < 0 || m->cols < 0) {
556 err = 1;
557 break;
558 }
559 vsize += m->rows * m->cols;
560 }
561
562 va_end(ap);
563
564 if (!err && vsize > 0) {
565 /* allocate combined data block */
566 B->val = malloc(vsize * sizeof *B->val);
567 if (B->val == NULL) {
568 err = 1;
569 }
570 }
571
572 if (err) {
573 gretl_matrix_block_destroy(B);
574 B = NULL;
575 } else {
576 /* set the val pointers */
577 double *val = B->val;
578 int n;
579
580 for (i=0; i<B->n; i++) {
581 m = B->matrix[i];
582 n = m->rows * m->cols;
583 if (n > 0) {
584 m->val = val;
585 val += n;
586 }
587 }
588 }
589
590 return B;
591 }
592
gretl_matrix_block_n_matrices(gretl_matrix_block * B)593 int gretl_matrix_block_n_matrices (gretl_matrix_block *B)
594 {
595 return B == NULL ? 0 : B->n;
596 }
597
gretl_matrix_block_get_matrix(gretl_matrix_block * B,int i)598 gretl_matrix *gretl_matrix_block_get_matrix (gretl_matrix_block *B,
599 int i)
600 {
601 if (B == NULL || i < 0 || i >= B->n) {
602 return NULL;
603 } else {
604 return B->matrix[i];
605 }
606 }
607
gretl_matrix_na_check(const gretl_matrix * m)608 int gretl_matrix_na_check (const gretl_matrix *m)
609 {
610 if (m != NULL) {
611 int i, n = m->rows * m->cols;
612
613 for (i=0; i<n; i++) {
614 if (na(m->val[i])) {
615 return E_NAN;
616 }
617 }
618 }
619
620 return 0;
621 }
622
gretl_matrix_get_structure(const gretl_matrix * m)623 int gretl_matrix_get_structure (const gretl_matrix *m)
624 {
625 int ret = 0;
626
627 if (gretl_is_null_matrix(m)) {
628 return 0;
629 }
630
631 if (m != NULL) {
632 if (m->rows == m->cols) {
633 ret = GRETL_MATRIX_SQUARE;
634 if (m->rows == 1) {
635 ret = GRETL_MATRIX_SCALAR;
636 }
637 }
638 }
639
640 if (ret == GRETL_MATRIX_SQUARE) {
641 double x;
642 int uzero = 1;
643 int lzero = 1;
644 int symm = 1;
645 int udiag = 1;
646 int i, j;
647
648 for (i=0; i<m->rows; i++) {
649 for (j=0; j<m->cols; j++) {
650 x = gretl_matrix_get(m,i,j);
651 if (j > i) {
652 if (x != 0.0) {
653 uzero = 0;
654 }
655 } else if (i > j) {
656 if (x != 0.0) {
657 lzero = 0;
658 }
659 } else if (i == j) {
660 if (x != 1.0) {
661 udiag = 0;
662 }
663 }
664 if (j != i && x != gretl_matrix_get(m,j,i)) {
665 symm = 0;
666 }
667 if (!uzero && !lzero && !symm) {
668 break;
669 }
670 }
671 if (!uzero && !lzero && !symm) {
672 break;
673 }
674 }
675
676 if (udiag && uzero && lzero) {
677 ret = GRETL_MATRIX_IDENTITY;
678 } else if (uzero && lzero) {
679 ret = GRETL_MATRIX_DIAGONAL;
680 } else if (uzero) {
681 ret = GRETL_MATRIX_LOWER_TRIANGULAR;
682 } else if (lzero) {
683 ret = GRETL_MATRIX_UPPER_TRIANGULAR;
684 } else if (symm) {
685 ret = GRETL_MATRIX_SYMMETRIC;
686 }
687 }
688
689 return ret;
690 }
691
692 /**
693 * gretl_matrix_reuse:
694 * @m: matrix to reuse.
695 * @rows: desired number of rows in "new" matrix, or -1
696 * to leave the current value unchanged.
697 * @cols: desired number of columns in "new" matrix, or -1
698 * to leave the current value unchanged.
699 *
700 * An "experts only" memory-conservation trick. If @m is an
701 * already-allocated gretl matrix, you can "resize" it by
702 * specifying a new number of rows and columns. This works
703 * only if the product of @rows and @cols is less than or equal
704 * to the product of the number of rows and columns in the
705 * matrix as originally allocated; no actual reallocation of memory
706 * is performed. If you "reuse" with an excessive number of rows
707 * or columns you will surely crash your program or smash the
708 * stack. Note also that the matrix-pointer returned is not really
709 * new, and when the matrix is to be freed, gretl_matrix_free()
710 * should be applied only once.
711 *
712 * Returns: pointer to the "resized" gretl_matrix.
713 */
714
gretl_matrix_reuse(gretl_matrix * m,int rows,int cols)715 gretl_matrix *gretl_matrix_reuse (gretl_matrix *m, int rows, int cols)
716 {
717 int r = rows > 0 ? rows : m->rows;
718 int c = cols > 0 ? cols : m->cols;
719
720 m->rows = r;
721 m->cols = c;
722
723 return m;
724 }
725
726 /**
727 * gretl_matrix_realloc:
728 * @m: matrix to reallocate.
729 * @rows: desired number of rows in "new" matrix.
730 * @cols: desired number of columns in "new" matrix.
731 *
732 * Reallocates the storage in @m to the specified dimensions.
733 *
734 * Returns: 0 on success, %E_ALLOC on failure.
735 */
736
gretl_matrix_realloc(gretl_matrix * m,int rows,int cols)737 int gretl_matrix_realloc (gretl_matrix *m, int rows, int cols)
738 {
739 int n = rows * cols;
740 int oldrows, oldcols;
741 double *x = NULL;
742
743 if (m == NULL) {
744 return E_DATA;
745 }
746
747 if (rows == m->rows && cols == m->cols) {
748 /* no-op */
749 return 0;
750 }
751
752 if (m->rows * m->cols == n) {
753 /* no need to reallocate storage */
754 m->rows = rows;
755 m->cols = cols;
756 gretl_matrix_destroy_info(m);
757 return 0;
758 }
759
760 if (is_block_matrix(m)) {
761 matrix_block_error("gretl_matrix_realloc");
762 return E_DATA;
763 }
764
765 if (n == 0) {
766 mval_free(m->val);
767 } else {
768 if (m->is_complex) {
769 x = mval_realloc(m->val, 2 * n * sizeof *m->val);
770 } else {
771 x = mval_realloc(m->val, n * sizeof *m->val);
772 }
773 if (x == NULL) {
774 return E_ALLOC;
775 }
776 }
777
778 oldrows = m->rows;
779 oldcols = m->cols;
780
781 m->val = x;
782 m->rows = rows;
783 m->cols = cols;
784 if (m->is_complex) {
785 m->z = (double complex *) m->val;
786 }
787
788 if (m->info != NULL) {
789 if (m->rows != oldrows && m->cols != oldcols) {
790 gretl_matrix_destroy_info(m);
791 } else if (m->rows != oldrows && m->info->rownames != NULL) {
792 strings_array_free(m->info->rownames, oldrows);
793 m->info->rownames = NULL;
794 } else if (m->cols != oldcols && m->info->colnames != NULL) {
795 strings_array_free(m->info->colnames, oldcols);
796 m->info->colnames = NULL;
797 }
798 }
799
800 return 0;
801 }
802
803 /**
804 * gretl_matrix_init_full:
805 * @m: matrix to be initialized.
806 * @rows: number of rows.
807 * @cols: number of columns.
808 * @val: data array.
809 *
810 * Initializes @m to be @rows by @cols and have data @val. This
811 * intended for use with automatic matrices declared "on
812 * the stack". It is up to the user to ensure that the size of
813 * @val is compatible with the @rows and @cols specification.
814 */
815
gretl_matrix_init_full(gretl_matrix * m,int rows,int cols,double * val)816 gretl_matrix *gretl_matrix_init_full (gretl_matrix *m,
817 int rows, int cols,
818 double *val)
819 {
820 m->rows = rows;
821 m->cols = cols;
822 m->val = val;
823 m->info = NULL;
824 m->is_complex = 0;
825 m->z = NULL;
826 return m;
827 }
828
829 /**
830 * gretl_matrix_init:
831 * @m: matrix to be initialized.
832 *
833 * Initializes @m to be zero by zero with NULL data.
834 */
835
gretl_matrix_init(gretl_matrix * m)836 gretl_matrix *gretl_matrix_init (gretl_matrix *m)
837 {
838 m->rows = m->cols = 0;
839 m->val = NULL;
840 m->info = NULL;
841 m->is_complex = 0;
842 m->z = NULL;
843 return m;
844 }
845
846 /**
847 * gretl_matrix_replace:
848 * @pa: location of matrix to be replaced.
849 * @b: replacement matrix.
850 *
851 * Frees the matrix at location @pa and substitutes @b.
852 *
853 * Returns: the replacement matrix.
854 */
855
gretl_matrix_replace(gretl_matrix ** pa,gretl_matrix * b)856 gretl_matrix *gretl_matrix_replace (gretl_matrix **pa,
857 gretl_matrix *b)
858 {
859 gretl_matrix_free(*pa);
860 *pa = b;
861 return b;
862 }
863
864 /**
865 * gretl_matrix_replace_content:
866 * @targ: matrix to receive new content.
867 * @donor: matrix to donate content.
868 *
869 * Moves the content of @donor into @targ; @donor becomes
870 * a null matrix in consequence.
871 *
872 * Returns: 0 on success, non-zero on error.
873 */
874
gretl_matrix_replace_content(gretl_matrix * targ,gretl_matrix * donor)875 int gretl_matrix_replace_content (gretl_matrix *targ,
876 gretl_matrix *donor)
877 {
878 if (is_block_matrix(targ) || is_block_matrix(donor)) {
879 matrix_block_error("gretl_matrix_replace_content");
880 return E_DATA;
881 } else {
882 gretl_matrix_destroy_info(targ);
883 free(targ->val);
884 targ->rows = donor->rows;
885 targ->cols = donor->cols;
886 targ->val = donor->val;
887 donor->val = NULL;
888 gretl_matrix_set_complex(targ, donor->is_complex);
889 return 0;
890 }
891 }
892
893 /**
894 * gretl_identity_matrix_new:
895 * @n: desired number of rows and columns in the matrix.
896 *
897 * Returns: pointer to a newly allocated identity matrix, or NULL
898 * on failure.
899 */
900
gretl_identity_matrix_new(int n)901 gretl_matrix *gretl_identity_matrix_new (int n)
902 {
903 gretl_matrix *m;
904 int i, k;
905
906 if (n < 0) {
907 return NULL;
908 } else if (n == 0) {
909 return gretl_null_matrix_new();
910 }
911
912 m = gretl_matrix_alloc(n, n);
913
914 if (m != NULL) {
915 k = n * n;
916 n++;
917 for (i=0; i<k; i++) {
918 m->val[i] = (i % n)? 0.0 : 1.0;
919 }
920 }
921
922 return m;
923 }
924
925 /**
926 * gretl_DW_matrix_new:
927 * @n: desired number of rows and columns in the matrix.
928 *
929 * Returns: pointer to a newly allocated Durbin-Watson matrix, or NULL
930 * on failure. This is a tridiagonal matrix with 2 on the leading
931 * diagonal (apart from 1 at the ends) and -1 on the supra- and
932 * infra-diagonals.
933 */
934
gretl_DW_matrix_new(int n)935 gretl_matrix *gretl_DW_matrix_new (int n)
936 {
937 gretl_matrix *m = gretl_zero_matrix_new(n, n);
938 int i, j;
939
940 if (m == NULL) {
941 return NULL;
942 }
943
944 for (i=0; i<n; i++) {
945 for (j=0; j<n; j++) {
946 if (j == i) {
947 if (i == 0 || i == n-1) {
948 gretl_matrix_set(m, i, j, 1.0);
949 } else {
950 gretl_matrix_set(m, i, j, 2.0);
951 }
952 } else if (j == i + 1 || i == j + 1) {
953 gretl_matrix_set(m, i, j, -1.0);
954 }
955 }
956 }
957
958 return m;
959 }
960
gretl_filled_matrix_new(int r,int c,double val)961 static gretl_matrix *gretl_filled_matrix_new (int r, int c,
962 double val)
963 {
964 gretl_matrix *m = NULL;
965
966 if (r < 0 || c < 0) {
967 return NULL;
968 } else if (r == 0 || c == 0) {
969 m = gretl_null_matrix_new();
970 if (m != NULL) {
971 m->rows = r;
972 m->cols = c;
973 }
974 } else {
975 int i, n = r * c;
976
977 m = gretl_matrix_alloc(r, c);
978 if (m != NULL) {
979 if (val == 0.0) {
980 memset(m->val, 0, n * sizeof *m->val);
981 } else {
982 for (i=0; i<n; i++) {
983 m->val[i] = val;
984 }
985 }
986 }
987 }
988
989 return m;
990 }
991
992 /**
993 * gretl_zero_matrix_new:
994 * @r: desired number of rows in the matrix.
995 * @c: desired number of columns in the matrix.
996 *
997 * Returns: pointer to a newly allocated zero matrix, or NULL
998 * on failure.
999 */
1000
gretl_zero_matrix_new(int r,int c)1001 gretl_matrix *gretl_zero_matrix_new (int r, int c)
1002 {
1003 return gretl_filled_matrix_new(r, c, 0.0);
1004 }
1005
1006 /**
1007 * gretl_unit_matrix_new:
1008 * @r: desired number of rows in the matrix.
1009 * @c: desired number of columns in the matrix.
1010 *
1011 * Returns: pointer to a newly allocated matrix, all
1012 * of whose elements equal 1, or NULL on failure.
1013 */
1014
gretl_unit_matrix_new(int r,int c)1015 gretl_matrix *gretl_unit_matrix_new (int r, int c)
1016 {
1017 return gretl_filled_matrix_new(r, c, 1.0);
1018 }
1019
1020 /**
1021 * gretl_null_matrix_new:
1022 *
1023 * Returns: pointer to a newly allocated null matrix, or
1024 * NULL on failure.
1025 */
1026
gretl_null_matrix_new(void)1027 gretl_matrix *gretl_null_matrix_new (void)
1028 {
1029 gretl_matrix *m = malloc(sizeof *m);
1030
1031 if (m == NULL) {
1032 set_gretl_matrix_err(E_ALLOC);
1033 return NULL;
1034 }
1035
1036 gretl_matrix_init(m);
1037
1038 return m;
1039 }
1040
1041 /**
1042 * gretl_matrix_seq:
1043 * @start: first element.
1044 * @end: last element.
1045 * @step: positive step.
1046 * @err: location to recieve error code.
1047 *
1048 * Returns: pointer to a row vector, containing values from
1049 * @start to @end, in decreasing order if @start > @end --
1050 * or NULL on failure.
1051 */
1052
gretl_matrix_seq(double start,double end,double step,int * err)1053 gretl_matrix *gretl_matrix_seq (double start, double end,
1054 double step, int *err)
1055 {
1056 gretl_matrix *v;
1057 int reverse = (start > end);
1058 double k = start;
1059 int i, n = 0;
1060
1061 if (step <= 0) {
1062 *err = E_DATA;
1063 return NULL;
1064 }
1065
1066 if (step == 1.0) {
1067 if(reverse) {
1068 n = start - end + 1;
1069 step = -step;
1070 } else {
1071 n = end - start + 1;
1072 }
1073 } else if (reverse) {
1074 step = -step;
1075 while (k >= end) {
1076 n++;
1077 k += step;
1078 }
1079 } else {
1080 while (k <= end) {
1081 n++;
1082 k += step;
1083 }
1084 }
1085
1086 if (n == 0) {
1087 *err = E_DATA;
1088 return NULL;
1089 }
1090 v = gretl_vector_alloc(n);
1091
1092 if (v == NULL) {
1093 *err = E_ALLOC;
1094 } else {
1095 k = start;
1096 if (step == 1.0) {
1097 for (i=0; i<n; i++) {
1098 v->val[i] = k++;
1099 }
1100 } else if (step == -1.0) {
1101 for (i=0; i<n; i++) {
1102 v->val[i] = k--;
1103 }
1104 } else {
1105 for (i=0; i<n; i++) {
1106 v->val[i] = k;
1107 k += step;
1108 }
1109 }
1110 }
1111
1112 return v;
1113 }
1114
1115 /**
1116 * gretl_matrix_fill:
1117 * @m: matrix to fill.
1118 * @x: value with which to fill.
1119 *
1120 * Sets all entries in @m to the value @x.
1121 */
1122
gretl_matrix_fill(gretl_matrix * m,double x)1123 void gretl_matrix_fill (gretl_matrix *m, double x)
1124 {
1125 if (m != NULL) {
1126 int i, n = m->rows * m->cols;
1127
1128 if (m->is_complex) {
1129 for (i=0; i<n; i++) {
1130 m->z[i] = x;
1131 }
1132 } else {
1133 for (i=0; i<n; i++) {
1134 m->val[i] = x;
1135 }
1136 }
1137 }
1138 }
1139
1140 static gretl_matrix *
gretl_matrix_copy_mod(const gretl_matrix * m,int mod)1141 gretl_matrix_copy_mod (const gretl_matrix *m, int mod)
1142 {
1143 gretl_matrix *c;
1144 int rows, cols;
1145 int i, j;
1146
1147 if (m == NULL) {
1148 return NULL;
1149 }
1150
1151 if (mod == GRETL_MOD_TRANSPOSE) {
1152 rows = m->cols;
1153 cols = m->rows;
1154 } else {
1155 rows = m->rows;
1156 cols = m->cols;
1157 }
1158
1159 c = gretl_matching_matrix_new(rows, cols, m);
1160 if (c == NULL) {
1161 return NULL;
1162 }
1163
1164 if (mod == GRETL_MOD_TRANSPOSE) {
1165 int k = 0;
1166
1167 if (m->is_complex) {
1168 /* we'll do the conjugate transpose */
1169 double complex mij;
1170
1171 for (j=0; j<m->cols; j++) {
1172 for (i=0; i<m->rows; i++) {
1173 mij = m->z[k++];
1174 gretl_cmatrix_set(c, j, i, conj(mij));
1175 }
1176 }
1177 } else {
1178 double mij;
1179
1180 for (j=0; j<m->cols; j++) {
1181 for (i=0; i<m->rows; i++) {
1182 mij = m->val[k++];
1183 gretl_matrix_set(c, j, i, mij);
1184 }
1185 }
1186 }
1187 } else {
1188 /* not transposing */
1189 int n = rows * cols;
1190
1191 if (m->is_complex) {
1192 memcpy(c->z, m->z, n * sizeof *m->z);
1193 } else {
1194 memcpy(c->val, m->val, n * sizeof *m->val);
1195 }
1196 gretl_matrix_copy_info(c, m);
1197 }
1198
1199 return c;
1200 }
1201
matrix_copy_plain(const gretl_matrix * m)1202 static gretl_matrix *matrix_copy_plain (const gretl_matrix *m)
1203 {
1204 gretl_matrix *c;
1205
1206 if (m == NULL) {
1207 return NULL;
1208 }
1209
1210 c = gretl_matching_matrix_new(m->rows, m->cols, m);
1211
1212 if (c != NULL) {
1213 int n = c->rows * c->cols;
1214
1215 if (m->is_complex) n *= 2;
1216 memcpy(c->val, m->val, n * sizeof *m->val);
1217 }
1218
1219 return c;
1220 }
1221
1222 /**
1223 * gretl_matrix_copy:
1224 * @m: source matrix to be copied.
1225 *
1226 * Returns: an allocated copy of matrix @m, or NULL on failure.
1227 */
1228
gretl_matrix_copy(const gretl_matrix * m)1229 gretl_matrix *gretl_matrix_copy (const gretl_matrix *m)
1230 {
1231 return gretl_matrix_copy_mod(m, GRETL_MOD_NONE);
1232 }
1233
1234 /**
1235 * gretl_matrix_copy_transpose:
1236 * @m: source matrix to be copied.
1237 *
1238 * Returns: an allocated copy of the tranpose of @m, or NULL on failure.
1239 */
1240
gretl_matrix_copy_transpose(const gretl_matrix * m)1241 gretl_matrix *gretl_matrix_copy_transpose (const gretl_matrix *m)
1242 {
1243 return gretl_matrix_copy_mod(m, GRETL_MOD_TRANSPOSE);
1244 }
1245
1246 /* Relatively lightweight version of gretl_matrix_copy, for
1247 internal use when we just want a temporary copy of an
1248 original matrix as workspace, and we know that the original
1249 is not a null matrix.
1250 */
1251
gretl_matrix_copy_tmp(const gretl_matrix * a)1252 static gretl_matrix *gretl_matrix_copy_tmp (const gretl_matrix *a)
1253 {
1254 size_t sz = a->rows * a->cols * sizeof(double);
1255 gretl_matrix *b = calloc(1, sizeof *b);
1256
1257 if (a->is_complex) sz *= 2;
1258
1259 if (b != NULL && (b->val = mval_malloc(sz)) != NULL) {
1260 b->rows = a->rows;
1261 b->cols = a->cols;
1262 b->info = NULL;
1263 memcpy(b->val, a->val, sz);
1264 gretl_matrix_set_complex(b, a->is_complex);
1265 }
1266
1267 return b;
1268 }
1269
1270 /**
1271 * gretl_matrix_copy_row:
1272 * @dest: destination matrix.
1273 * @di: row to copy into.
1274 * @src: source matrix.
1275 * @si: row to copy from.
1276 *
1277 * Copies the values from row @si of @src into row @di
1278 * of @dest, provided @src and @dest have the same number
1279 * of columns.
1280 *
1281 * Returns: 0 on success, non-zero on failure.
1282 */
1283
gretl_matrix_copy_row(gretl_matrix * dest,int di,const gretl_matrix * src,int si)1284 int gretl_matrix_copy_row (gretl_matrix *dest, int di,
1285 const gretl_matrix *src, int si)
1286 {
1287 int err = 0;
1288
1289 if (dest == NULL || src == NULL ||
1290 gretl_is_null_matrix(dest) ||
1291 gretl_is_null_matrix(src)) {
1292 err = E_DATA;
1293 } else if (dest->cols != src->cols) {
1294 err = E_NONCONF;
1295 } else {
1296 double x;
1297 int j;
1298
1299 for (j=0; j<src->cols; j++) {
1300 x = gretl_matrix_get(src, si, j);
1301 gretl_matrix_set(dest, di, j, x);
1302 }
1303 }
1304
1305 return err;
1306 }
1307
1308 /* Mechanism for copying row or column names from matrix
1309 @src to matrix @targ. If @sel is non-NULL it must be a
1310 boolean vector indicating that @targ holds a subset of
1311 the columns or rows of @src.
1312 */
1313
maybe_preserve_names(gretl_matrix * targ,const gretl_matrix * src,NameFlags flags,const gretl_matrix * sel)1314 static void maybe_preserve_names (gretl_matrix *targ,
1315 const gretl_matrix *src,
1316 NameFlags flags,
1317 const gretl_matrix *sel)
1318 {
1319 int cols = (flags & COLNAMES);
1320 int reverse = (flags & REVERSED);
1321 char **srcnames, **S;
1322 int ns, nt, err = 0;
1323
1324 if (no_metadata(src)) {
1325 return;
1326 } else if (cols) {
1327 srcnames = src->info->colnames;
1328 ns = src->cols;
1329 nt = targ->cols;
1330 } else {
1331 srcnames = src->info->rownames;
1332 ns = src->rows;
1333 nt = targ->rows;
1334 }
1335
1336 if (srcnames == NULL || nt > ns) {
1337 return;
1338 } else if (nt < ns && sel == NULL) {
1339 return;
1340 }
1341
1342 if (sel != NULL) {
1343 int i, n = gretl_vector_get_length(sel);
1344 int k = 0;
1345
1346 for (i=0; i<n; i++) {
1347 k += (sel->val[i] != 0);
1348 }
1349 S = strings_array_new(k);
1350 if (S != NULL) {
1351 k = 0;
1352 for (i=0; i<n; i++) {
1353 if (sel->val[i] != 0) {
1354 S[k++] = gretl_strdup(srcnames[i]);
1355 }
1356 }
1357 }
1358 } else if (reverse) {
1359 S = strings_array_reverse(srcnames, ns);
1360 } else {
1361 S = strings_array_dup(srcnames, ns);
1362 }
1363
1364 if (S != NULL) {
1365 if (cols) {
1366 err = gretl_matrix_set_colnames(targ, S);
1367 } else {
1368 err = gretl_matrix_set_rownames(targ, S);
1369 }
1370 if (err) {
1371 strings_array_free(S, nt);
1372 }
1373 }
1374 }
1375
maybe_concat_names(gretl_matrix * targ,const gretl_matrix * src1,const gretl_matrix * src2,NameFlags flags)1376 static void maybe_concat_names (gretl_matrix *targ,
1377 const gretl_matrix *src1,
1378 const gretl_matrix *src2,
1379 NameFlags flags)
1380 {
1381 int cols = (flags & COLNAMES);
1382 char **srcnames1 = NULL;
1383 char **srcnames2 = NULL;
1384 char **S = NULL;
1385 int n1, ns, err = 0;
1386
1387 if (no_metadata(src1) || no_metadata(src2)) {
1388 return;
1389 } else if (cols) {
1390 if (targ->cols == src1->cols + src2->cols) {
1391 srcnames1 = src1->info->colnames;
1392 srcnames2 = src2->info->colnames;
1393 }
1394 } else {
1395 if (targ->rows == src1->rows + src2->rows) {
1396 srcnames1 = src1->info->rownames;
1397 srcnames2 = src2->info->rownames;
1398 }
1399 }
1400
1401 if (srcnames1 == NULL || srcnames2 == NULL) {
1402 return;
1403 }
1404
1405 n1 = cols ? src1->cols : src1->rows;
1406 ns = cols ? targ->cols : targ->rows;
1407 S = strings_array_new(ns);
1408
1409 if (S != NULL) {
1410 int i, j = 0, k = 0;
1411
1412 for (i=0; i<ns; i++) {
1413 if (i < n1) {
1414 S[i] = gretl_strdup(srcnames1[j++]);
1415 } else {
1416 S[i] = gretl_strdup(srcnames2[k++]);
1417 }
1418 }
1419 if (cols) {
1420 err = gretl_matrix_set_colnames(targ, S);
1421 } else {
1422 err = gretl_matrix_set_rownames(targ, S);
1423 }
1424 if (err) {
1425 strings_array_free(S, ns);
1426 }
1427 }
1428 }
1429
1430 /**
1431 * gretl_matrix_reverse_rows:
1432 * @m: source matrix whose rows are to be reversed.
1433 * @err: location to receive error code.
1434 *
1435 * Returns: a matrix with the same rows as @m, last to first.
1436 */
1437
gretl_matrix_reverse_rows(const gretl_matrix * m,int * err)1438 gretl_matrix *gretl_matrix_reverse_rows (const gretl_matrix *m,
1439 int *err)
1440 {
1441 gretl_matrix *ret;
1442 int i, j, r, c;
1443
1444 if (m == NULL) {
1445 *err = E_INVARG;
1446 return NULL;
1447 } else if (gretl_is_null_matrix(m)) {
1448 return gretl_null_matrix_new();
1449 }
1450
1451 r = m->rows;
1452 c = m->cols;
1453
1454 ret = gretl_matching_matrix_new(r, c, m);
1455
1456 if (ret == NULL) {
1457 *err = E_ALLOC;
1458 } else {
1459 double complex z;
1460 double x;
1461
1462 for (i=0; i<r; i++) {
1463 for (j=0; j<m->cols; j++) {
1464 if (m->is_complex) {
1465 z = gretl_cmatrix_get(m, r-i-1, j);
1466 gretl_cmatrix_set(ret, i, j, z);
1467 } else {
1468 x = gretl_matrix_get(m, r-i-1, j);
1469 gretl_matrix_set(ret, i, j, x);
1470 }
1471 }
1472 }
1473 maybe_preserve_names(ret, m, ROWNAMES | REVERSED, NULL);
1474 maybe_preserve_names(ret, m, COLNAMES, NULL);
1475 }
1476
1477 return ret;
1478 }
1479
1480 /**
1481 * gretl_matrix_reverse_cols:
1482 * @m: source matrix whose columns are to be reversed.
1483 * @err: location to receive error code.
1484 *
1485 * Returns: a matrix with the same columns as @m, last to first.
1486 */
1487
gretl_matrix_reverse_cols(const gretl_matrix * m,int * err)1488 gretl_matrix *gretl_matrix_reverse_cols (const gretl_matrix *m,
1489 int *err)
1490 {
1491 gretl_matrix *ret;
1492 const double *x;
1493 double *y;
1494 size_t csize;
1495 int i, r, c;
1496
1497 if (m == NULL) {
1498 *err = E_INVARG;
1499 return NULL;
1500 } else if (gretl_is_null_matrix(m)) {
1501 return gretl_null_matrix_new();
1502 }
1503
1504 r = m->rows;
1505 c = m->cols;
1506 ret = gretl_matching_matrix_new(r, c, m);
1507
1508 if (ret == NULL) {
1509 *err = E_ALLOC;
1510 } else {
1511 if (m->is_complex) {
1512 r *= 2;
1513 }
1514 x = m->val;
1515 y = ret->val + r * (c-1);
1516 csize = r * sizeof *x;
1517
1518 for (i=0; i<c; i++) {
1519 memcpy(y, x, csize);
1520 x += r;
1521 y -= r;
1522 }
1523
1524 maybe_preserve_names(ret, m, COLNAMES | REVERSED, NULL);
1525 maybe_preserve_names(ret, m, ROWNAMES, NULL);
1526 }
1527
1528 return ret;
1529 }
1530
gretl_matrix_destroy_info(gretl_matrix * m)1531 void gretl_matrix_destroy_info (gretl_matrix *m)
1532 {
1533 if (m != NULL && m->info != NULL && !is_block_matrix(m)) {
1534 strings_array_free(m->info->colnames, m->cols);
1535 strings_array_free(m->info->rownames, m->rows);
1536 free(m->info);
1537 m->info = NULL;
1538 }
1539 }
1540
1541 /**
1542 * gretl_matrix_free:
1543 * @m: matrix to be freed.
1544 *
1545 * Frees the allocated storage in @m, then @m itself.
1546 */
1547
gretl_matrix_free(gretl_matrix * m)1548 void gretl_matrix_free (gretl_matrix *m)
1549 {
1550 if (m == NULL) return;
1551
1552 if (is_block_matrix(m)) {
1553 matrix_block_error("gretl_matrix_free");
1554 return;
1555 }
1556
1557 if (m->val != NULL) {
1558 mval_free(m->val);
1559 }
1560
1561 if (m->info != NULL) {
1562 gretl_matrix_destroy_info(m);
1563 }
1564
1565 free(m);
1566 }
1567
1568 /**
1569 * gretl_matrix_zero:
1570 * @m: matrix to be set to zero.
1571 *
1572 * Sets all elements of @m to zero.
1573 */
1574
gretl_matrix_zero(gretl_matrix * m)1575 void gretl_matrix_zero (gretl_matrix *m)
1576 {
1577 int i, n = m->rows * m->cols;
1578
1579 for (i=0; i<n; i++) {
1580 m->val[i] = 0.0;
1581 }
1582 }
1583
1584 /**
1585 * gretl_matrix_get_diagonal:
1586 * @m: input matrix.
1587 * @err: location to receive error code.
1588 *
1589 * Returns: a column vector containing the diagonal elements of
1590 * @m, otherwise NULL. A non-zero value is assigned via @err
1591 * on failure.
1592 */
1593
gretl_matrix_get_diagonal(const gretl_matrix * m,int * err)1594 gretl_matrix *gretl_matrix_get_diagonal (const gretl_matrix *m, int *err)
1595 {
1596 gretl_matrix *d = NULL;
1597 int i, n = 0;
1598
1599 *err = 0;
1600
1601 if (gretl_is_null_matrix(m)) {
1602 d = gretl_null_matrix_new();
1603 } else {
1604 n = MIN(m->rows, m->cols);
1605 d = gretl_matching_matrix_new(n, 1, m);
1606 }
1607
1608 if (d == NULL) {
1609 *err = E_ALLOC;
1610 } else {
1611 if (m->is_complex) {
1612 for (i=0; i<n; i++) {
1613 d->z[i] = gretl_cmatrix_get(m, i, i);
1614 }
1615 } else {
1616 for (i=0; i<n; i++) {
1617 d->val[i] = gretl_matrix_get(m, i, i);
1618 }
1619 }
1620 }
1621
1622 return d;
1623 }
1624
1625 /**
1626 * gretl_matrix_set_diagonal:
1627 * @targ: target matrix.
1628 * @src: source vector (or NULL).
1629 * @x: (alternative) source scalar.
1630 *
1631 * Sets the diagonal elements of @targ using the elements of
1632 * @src, if non-NULL, or otherwise the constant value @x.
1633 * If @src is given it must be a vector of length equal to
1634 * that of the diagonal of @targ (that is, the minimum of
1635 * its rows and columns).
1636 *
1637 * Returns: 0 on success, error code on non-conformability.
1638 */
1639
gretl_matrix_set_diagonal(gretl_matrix * targ,const gretl_matrix * src,double x)1640 int gretl_matrix_set_diagonal (gretl_matrix *targ,
1641 const gretl_matrix *src,
1642 double x)
1643 {
1644 int i, n, match = 0;
1645 int err = 0;
1646
1647 if (gretl_is_null_matrix(targ) || targ->is_complex) {
1648 return E_INVARG;
1649 } else if (src != NULL && src->is_complex) {
1650 return E_INVARG;
1651 }
1652
1653 n = MIN(targ->rows, targ->cols);
1654
1655 if (src != NULL) {
1656 if (gretl_vector_get_length(src) == n) {
1657 match = 1;
1658 } else if (gretl_matrix_is_scalar(src)) {
1659 x = src->val[0];
1660 match = 2;
1661 }
1662 } else {
1663 match = 2;
1664 }
1665
1666 if (match == 0) {
1667 err = E_NONCONF;
1668 } else {
1669 for (i=0; i<n; i++) {
1670 if (match == 1) {
1671 gretl_matrix_set(targ, i, i, src->val[i]);
1672 } else {
1673 gretl_matrix_set(targ, i, i, x);
1674 }
1675 }
1676 }
1677
1678 return err;
1679 }
1680
1681 /**
1682 * gretl_matrix_set_triangle:
1683 * @targ: target matrix.
1684 * @src: source vector (or NULL).
1685 * @x: (alternative) source scalar.
1686 * @upper: flag to set the upper part, the default
1687 * being to set the lower.
1688 *
1689 * Sets the lower or upper elements of the matrix
1690 * @targ using the elements of @src, if non-NULL, or
1691 * otherwise the constant value @x.
1692 *
1693 * If @src is given it must be a vector of length equal to
1694 * that of the number of infra- or supra-diagonal elements
1695 * of @targ.
1696 *
1697 * Returns: 0 on success, error code on non-conformability.
1698 */
1699
gretl_matrix_set_triangle(gretl_matrix * targ,const gretl_matrix * src,double x,int upper)1700 int gretl_matrix_set_triangle (gretl_matrix *targ,
1701 const gretl_matrix *src,
1702 double x, int upper)
1703 {
1704 int r, c, p, i, j, n;
1705 int lower = !upper;
1706 int match = 0;
1707 int err = 0;
1708
1709 if (gretl_is_null_matrix(targ) || targ->is_complex) {
1710 return E_INVARG;
1711 } else if (src != NULL && src->is_complex) {
1712 return E_INVARG;
1713 }
1714
1715 r = targ->rows;
1716 c = targ->cols;
1717
1718 if ((c == 1 && upper) || (r == 1 && !upper)) {
1719 /* no such part */
1720 return E_INVARG;
1721 }
1722
1723 p = MIN(r, c);
1724 n = (p * (p-1)) / 2;
1725
1726 if (r > c && lower) {
1727 n += (r - c) * c;
1728 } else if (c > r && upper) {
1729 n += (c - r) * r;
1730 }
1731
1732 if (src != NULL) {
1733 if (gretl_vector_get_length(src) == n) {
1734 match = 1;
1735 } else if (gretl_matrix_is_scalar(src)) {
1736 x = src->val[0];
1737 match = 2;
1738 }
1739 } else {
1740 match = 2;
1741 }
1742
1743 if (match == 0) {
1744 err = E_NONCONF;
1745 } else {
1746 int jmin = upper ? 1 : 0;
1747 int jmax = upper ? c : r;
1748 int imin = upper ? 0 : 1;
1749 int imax = upper ? 1 : r;
1750 int k = 0;
1751
1752 for (j=jmin; j<jmax; j++) {
1753 for (i=imin; i<imax; i++) {
1754 if (src != NULL) {
1755 x = src->val[k++];
1756 }
1757 gretl_matrix_set(targ, i, j, x);
1758 }
1759 if (lower) {
1760 imin++;
1761 } else if (imax < r) {
1762 imax++;
1763 }
1764 }
1765 }
1766
1767 return err;
1768 }
1769
1770 /**
1771 * gretl_matrix_get_triangle:
1772 * @m: source matrix (real or complex).
1773 * @upper: flag to get the upper part, the default
1774 * being to get the lower part.
1775 * @err: location to receive error code.
1776 *
1777 * Returns: A column vector holding the vec of either the
1778 * infra- or supra-diagonal elements of @m, or NULL on failure.
1779 * Note that the "part" returned may not be an actual
1780 * triangle if @m is not square.
1781 */
1782
gretl_matrix_get_triangle(const gretl_matrix * m,int upper,int * err)1783 gretl_matrix *gretl_matrix_get_triangle (const gretl_matrix *m,
1784 int upper, int *err)
1785 {
1786 gretl_matrix *ret = NULL;
1787 int r, c, p, n, i, j;
1788 int lower = !upper;
1789
1790 if (gretl_is_null_matrix(m)) {
1791 *err = E_INVARG;
1792 return NULL;
1793 }
1794
1795 r = m->rows;
1796 c = m->cols;
1797
1798 if ((c == 1 && upper) || (r == 1 && !upper)) {
1799 /* no such part is available */
1800 *err = E_INVARG;
1801 return NULL;
1802 }
1803
1804 p = MIN(r, c);
1805 n = (p * (p-1)) / 2;
1806
1807 if (r > c && lower) {
1808 n += (r - c) * c;
1809 } else if (c > r && upper) {
1810 n += (c - r) * r;
1811 }
1812
1813 ret = gretl_matching_matrix_new(n, 1, m);
1814
1815 if (ret == NULL) {
1816 *err = E_ALLOC;
1817 } else {
1818 int jmin = upper ? 1 : 0;
1819 int jmax = upper ? c : r;
1820 int imin = upper ? 0 : 1;
1821 int imax = upper ? 1 : r;
1822 int k = 0;
1823
1824 for (j=jmin; j<jmax; j++) {
1825 for (i=imin; i<imax; i++) {
1826 if (m->is_complex) {
1827 ret->z[k++] = gretl_cmatrix_get(m, i, j);
1828 } else {
1829 ret->val[k++] = gretl_matrix_get(m, i, j);
1830 }
1831 }
1832 if (lower) {
1833 imin++;
1834 } else if (imax < r) {
1835 imax++;
1836 }
1837 }
1838 }
1839
1840 return ret;
1841 }
1842
1843 /**
1844 * gretl_matrix_get_row:
1845 * @m: input matrix.
1846 * @i: index of row to access.
1847 * @v: location to receive row values.
1848 *
1849 * Copies row @i of matrix @m into vector @v.
1850 *
1851 * Returns: 0 on success, non-zero on error.
1852 */
1853
gretl_matrix_get_row(const gretl_matrix * m,int i,gretl_vector * v)1854 int gretl_matrix_get_row (const gretl_matrix *m, int i, gretl_vector *v)
1855 {
1856 int j, nc = gretl_matrix_cols(m);
1857
1858 if (gretl_vector_get_length(v) != nc) {
1859 return E_NONCONF;
1860 }
1861
1862 for (j=0; j<nc; j++) {
1863 gretl_vector_set(v, j, gretl_matrix_get(m, i, j));
1864 }
1865
1866 return 0;
1867 }
1868
1869 /**
1870 * gretl_matrix_trace:
1871 * @m: square input matrix.
1872 *
1873 * Returns: the trace (sum of diagonal elements) of @m, if
1874 * @m is square, otherwise #NADBL.
1875 */
1876
gretl_matrix_trace(const gretl_matrix * m)1877 double gretl_matrix_trace (const gretl_matrix *m)
1878 {
1879 double tr = 0.0;
1880 int i;
1881
1882 if (gretl_is_null_matrix(m) || m->rows != m->cols) {
1883 return NADBL;
1884 }
1885
1886 for (i=0; i<m->rows; i++) {
1887 tr += gretl_matrix_get(m, i, i);
1888 }
1889
1890 return tr;
1891 }
1892
1893 /**
1894 * gretl_matrix_random_fill:
1895 * @m: input matrix.
1896 * @dist: either %D_UNIFORM or %D_NORMAL.
1897 *
1898 * Fills @m with pseudo-random values from either the uniform
1899 * or the standard normal distribution.
1900 *
1901 * Returns: 0 on success, 1 on failure.
1902 */
1903
gretl_matrix_random_fill(gretl_matrix * m,int dist)1904 int gretl_matrix_random_fill (gretl_matrix *m, int dist)
1905 {
1906 int n;
1907
1908 if (m == NULL || (dist != D_UNIFORM && dist != D_NORMAL)) {
1909 return 1;
1910 }
1911
1912 n = m->rows * m->cols;
1913
1914 if (n > 0) {
1915 if (dist == D_NORMAL) {
1916 gretl_rand_normal(m->val, 0, n - 1);
1917 } else if (dist == D_UNIFORM) {
1918 gretl_rand_uniform(m->val, 0, n - 1);
1919 }
1920 }
1921
1922 return 0;
1923 }
1924
1925 /**
1926 * gretl_random_matrix_new:
1927 * @r: number of rows.
1928 * @c: number of columns.
1929 * @dist: either %D_UNIFORM or %D_NORMAL.
1930 *
1931 * Creates a new $r x @c matrix and filles it with pseudo-random
1932 * values from either the uniform or the standard normal
1933 * distribution.
1934 *
1935 * Returns: allocated matrix or NULL on failure.
1936 */
1937
gretl_random_matrix_new(int r,int c,int dist)1938 gretl_matrix *gretl_random_matrix_new (int r, int c, int dist)
1939 {
1940 gretl_matrix *m = NULL;
1941
1942 if (dist != D_UNIFORM && dist != D_NORMAL) {
1943 return NULL;
1944 } else if (r < 0 || c < 0) {
1945 return NULL;
1946 } else if (r == 0 || c == 0) {
1947 m = gretl_null_matrix_new();
1948 if (m != NULL) {
1949 m->rows = r;
1950 m->cols = c;
1951 }
1952 } else {
1953 m = gretl_matrix_alloc(r, c);
1954 if (m != NULL) {
1955 if (dist == D_NORMAL) {
1956 gretl_rand_normal(m->val, 0, r * c - 1);
1957 } else if (dist == D_UNIFORM) {
1958 gretl_rand_uniform(m->val, 0, r * c - 1);
1959 }
1960 }
1961 }
1962
1963 return m;
1964 }
1965
1966 /**
1967 * gretl_vector_mean:
1968 * @v: input vector.
1969 *
1970 * Returns: the arithmetic mean of the elements of @v, or
1971 * #NADBL on failure.
1972 */
1973
gretl_vector_mean(const gretl_vector * v)1974 double gretl_vector_mean (const gretl_vector *v)
1975 {
1976 double num = 0.0;
1977 int i, n, den = 0;
1978
1979 if (gretl_is_null_matrix(v)) {
1980 return NADBL;
1981 }
1982
1983 n = gretl_vector_get_length(v);
1984 if (n == 0) {
1985 return NADBL;
1986 }
1987
1988 for (i=0; i<n; i++) {
1989 if (!na(v->val[i])) {
1990 num += v->val[i];
1991 den++;
1992 }
1993 }
1994
1995 return (den > 0)? (num / den) : NADBL;
1996 }
1997
1998 /**
1999 * gretl_vector_variance:
2000 * @v: input vector.
2001 *
2002 * Returns: the variance of the elements of @v, or
2003 * #NADBL on failure.
2004 */
2005
gretl_vector_variance(const gretl_vector * v)2006 double gretl_vector_variance (const gretl_vector *v)
2007 {
2008 double s2 = 0.0;
2009 double x, xbar = 0.0;
2010 int i, n, den = 0;
2011
2012 if (gretl_is_null_matrix(v)) {
2013 return NADBL;
2014 }
2015
2016 n = gretl_vector_get_length(v);
2017 if (n == 0) {
2018 return NADBL;
2019 }
2020
2021 for (i=0; i<n; i++) {
2022 if (!na(v->val[i])) {
2023 xbar += v->val[i];
2024 den++;
2025 }
2026 }
2027
2028 if (den == 0) {
2029 return NADBL;
2030 }
2031
2032 xbar /= den;
2033
2034 for (i=0; i<n; i++) {
2035 x = v->val[i];
2036 if (!na(x)) {
2037 x -= xbar;
2038 s2 += x * x;
2039 }
2040 }
2041
2042 return s2 / den;
2043 }
2044
real_matrix_resample(gretl_matrix * R,const gretl_matrix * m)2045 static int real_matrix_resample (gretl_matrix *R, const gretl_matrix *m)
2046 {
2047 int i, j, k, t1, r = R->rows;
2048 int *z = malloc(r * sizeof *z);
2049 double x;
2050
2051 if (z == NULL) {
2052 return E_ALLOC;
2053 }
2054
2055 /* generate r drawings from [0 .. r-1] */
2056 gretl_rand_int_minmax(z, r, 0, r - 1);
2057
2058 /* sample from source matrix @m based on row indices */
2059 for (i=0; i<r; i++) {
2060 k = z[i] % m->rows;
2061 for (j=0; j<m->cols; j++) {
2062 x = gretl_matrix_get(m, k, j);
2063 gretl_matrix_set(R, i, j, x);
2064 }
2065 }
2066
2067 t1 = gretl_matrix_get_t1(m);
2068 if (t1 > 0 && r <= m->rows) {
2069 gretl_matrix_set_t1(R, t1);
2070 gretl_matrix_set_t2(R, t1 + r - 1);
2071 }
2072
2073 free(z);
2074
2075 return 0;
2076 }
2077
2078 /**
2079 * gretl_matrix_resample:
2080 * @m: input matrix.
2081 * @draws: number of draws (or 0 to use the number or rows
2082 * in @m).
2083 * @err: location to receive error code.
2084 *
2085 * Returns: a new matrix consisting of a random re-sampling
2086 * (with replacement) of the rows of @m, or NULL on
2087 * failure.
2088 */
2089
gretl_matrix_resample(const gretl_matrix * m,int draws,int * err)2090 gretl_matrix *gretl_matrix_resample (const gretl_matrix *m,
2091 int draws, int *err)
2092 {
2093 gretl_matrix *R = NULL;
2094 int r;
2095
2096 if (gretl_is_null_matrix(m)) {
2097 *err = E_DATA;
2098 return NULL;
2099 } else if (m->is_complex) {
2100 *err = E_CMPLX;
2101 return NULL;
2102 }
2103
2104 if (draws < 0) {
2105 *err = E_INVARG;
2106 return NULL;
2107 } else if (draws > 0) {
2108 r = draws;
2109 } else {
2110 r = m->rows;
2111 }
2112
2113 R = gretl_matrix_alloc(r, m->cols);
2114
2115 if (R == NULL) {
2116 *err = E_ALLOC;
2117 } else {
2118 *err = real_matrix_resample(R, m);
2119 }
2120
2121 return R;
2122 }
2123
gretl_matrix_resample2(gretl_matrix * targ,const gretl_matrix * src)2124 int gretl_matrix_resample2 (gretl_matrix *targ,
2125 const gretl_matrix *src)
2126 {
2127 if (gretl_is_null_matrix(targ) || gretl_is_null_matrix(src)) {
2128 return E_DATA;
2129 } else if (targ->is_complex || src->is_complex) {
2130 return E_CMPLX;
2131 } else {
2132 return real_matrix_resample(targ, src);
2133 }
2134 }
2135
2136 /**
2137 * gretl_matrix_block_resample:
2138 * @m: input matrix.
2139 * @blocklen: length of moving blocks.
2140 * @draws: number of draws (or 0 to use the rows of @m).
2141 * @err: location to receive error code.
2142 *
2143 * Returns: a new matrix consisting of a random re-sampling
2144 * (with replacement) of the rows of @m, using blocks of
2145 * contiguous rows of length @blocklen, or NULL on
2146 * failure.
2147 */
2148
gretl_matrix_block_resample(const gretl_matrix * m,int blocklen,int draws,int * err)2149 gretl_matrix *gretl_matrix_block_resample (const gretl_matrix *m,
2150 int blocklen, int draws,
2151 int *err)
2152 {
2153 gretl_matrix *R = NULL;
2154 int *z = NULL;
2155 double x;
2156 int b, n, s, r, rmax;
2157 int t1;
2158 int i, j, k;
2159
2160 if (gretl_is_null_matrix(m) || blocklen <= 0 || draws < 0) {
2161 *err = E_DATA;
2162 return NULL;
2163 } else if (m->is_complex) {
2164 *err = E_CMPLX;
2165 return NULL;
2166 }
2167
2168 if (blocklen == 1) {
2169 return gretl_matrix_resample(m, draws, err);
2170 }
2171
2172 r = draws > 0 ? draws : m->rows;
2173
2174 /* Let n represent the number of blocks of @blocklen
2175 contiguous rows which we need to select; the
2176 last of these may not be fully used.
2177 */
2178 n = r / blocklen + (r % blocklen > 0);
2179
2180 rmax = m->rows - blocklen;
2181 if (rmax < 0) {
2182 *err = E_DATA;
2183 return NULL;
2184 }
2185
2186 R = gretl_matrix_alloc(r, m->cols);
2187 z = malloc(n * sizeof *z);
2188
2189 if (R == NULL || z == NULL) {
2190 gretl_matrix_free(R);
2191 free(z);
2192 *err = E_ALLOC;
2193 return NULL;
2194 }
2195
2196 /* generate n drawings from [0 .. rmax] */
2197 gretl_rand_int_minmax(z, n, 0, rmax);
2198
2199 /* sample from source matrix based on block indices */
2200 i = 0;
2201 for (b=0; b<n; b++) {
2202 for (s=0; s<blocklen; s++) {
2203 if (i < r) {
2204 /* don't spill over the end */
2205 k = z[b] + s;
2206 for (j=0; j<m->cols; j++) {
2207 x = gretl_matrix_get(m, k, j);
2208 gretl_matrix_set(R, i, j, x);
2209 }
2210 i++;
2211 } else {
2212 break;
2213 }
2214 }
2215 }
2216
2217 t1 = gretl_matrix_get_t1(m);
2218 if (t1 > 0 && r <= m->rows) {
2219 gretl_matrix_set_t1(R, t1);
2220 gretl_matrix_set_t2(R, t1 + r - 1);
2221 }
2222
2223 free(z);
2224
2225 return R;
2226 }
2227
2228 /**
2229 * gretl_matrix_block_resample2:
2230 * @targ: target matrix.
2231 * @src: source matrix.
2232 * @blocklen: length of moving blocks.
2233 * @z: array of length XXX.
2234 *
2235 * An "in-place" version of gretl_matrix_block_resample().
2236 * It is assumed that @targ is a matrix of the same dimensions
2237 * as @src, that @blocklen is greater than 1, and that @z
2238 * is long enough to hold n integers, where n is the number
2239 * of rows in @src divided by @blocklen, rounded up to the
2240 * nearest integer.
2241 *
2242 * Returns: 0 on success, non-zero on failure.
2243 */
2244
gretl_matrix_block_resample2(gretl_matrix * targ,const gretl_matrix * src,int blocklen,int * z)2245 int gretl_matrix_block_resample2 (gretl_matrix *targ,
2246 const gretl_matrix *src,
2247 int blocklen,
2248 int *z)
2249 {
2250 double x;
2251 int r = src->rows;
2252 int b, n, s, rmax;
2253 int i, j, k;
2254
2255 n = r / blocklen + (r % blocklen > 0);
2256
2257 rmax = r - blocklen;
2258 if (rmax < 0) {
2259 return E_DATA;
2260 }
2261
2262 /* generate n drawings from [0 .. rmax] */
2263 gretl_rand_int_minmax(z, n, 0, rmax);
2264
2265 /* sample from source matrix based on block indices */
2266 i = 0;
2267 for (b=0; b<n; b++) {
2268 for (s=0; s<blocklen; s++) {
2269 if (i < r) {
2270 k = z[b] + s;
2271 for (j=0; j<src->cols; j++) {
2272 x = gretl_matrix_get(src, k, j);
2273 gretl_matrix_set(targ, i, j, x);
2274 }
2275 i++;
2276 } else {
2277 break;
2278 }
2279 }
2280 }
2281
2282 return 0;
2283 }
2284
gretl_matrix_zero_triangle(gretl_matrix * m,char t)2285 static int gretl_matrix_zero_triangle (gretl_matrix *m, char t)
2286 {
2287 int i, j;
2288
2289 if (gretl_is_null_matrix(m)) {
2290 return E_DATA;
2291 } else if (m->rows != m->cols) {
2292 return E_NONCONF;
2293 }
2294
2295 if (t == 'U') {
2296 for (i=0; i<m->rows-1; i++) {
2297 for (j=i+1; j<m->cols; j++) {
2298 if (m->is_complex) {
2299 gretl_cmatrix_set(m, i, j, 0.0);
2300 } else {
2301 gretl_matrix_set(m, i, j, 0.0);
2302 }
2303 }
2304 }
2305 } else {
2306 for (i=1; i<m->rows; i++) {
2307 for (j=0; j<i; j++) {
2308 if (m->is_complex) {
2309 gretl_cmatrix_set(m, i, j, 0.0);
2310 } else {
2311 gretl_matrix_set(m, i, j, 0.0);
2312 }
2313 }
2314 }
2315 }
2316
2317 return 0;
2318 }
2319
2320 /**
2321 * gretl_matrix_zero_upper:
2322 * @m: square matrix to operate on.
2323 *
2324 * Sets the elements of @m outside of the lower triangle to zero.
2325 *
2326 * Returns: 0 on success, non-zero error code otherwise.
2327 */
2328
gretl_matrix_zero_upper(gretl_matrix * m)2329 int gretl_matrix_zero_upper (gretl_matrix *m)
2330 {
2331 return gretl_matrix_zero_triangle(m, 'U');
2332 }
2333
2334 /**
2335 * gretl_matrix_zero_lower:
2336 * @m: square matrix to operate on.
2337 *
2338 * Sets the elements of @m outside of the upper triangle to zero.
2339 *
2340 * Returns: 0 on success, non-zero error code otherwise.
2341 */
2342
gretl_matrix_zero_lower(gretl_matrix * m)2343 int gretl_matrix_zero_lower (gretl_matrix *m)
2344 {
2345 return gretl_matrix_zero_triangle(m, 'L');
2346 }
2347
2348 /**
2349 * gretl_matrix_multiply_by_scalar:
2350 * @m: matrix to operate on.
2351 * @x: scalar by which to multiply.
2352 *
2353 * Multiplies all elements of @m by @x.
2354 */
2355
gretl_matrix_multiply_by_scalar(gretl_matrix * m,double x)2356 void gretl_matrix_multiply_by_scalar (gretl_matrix *m, double x)
2357 {
2358 int i, n = m->rows * m->cols;
2359
2360 #if defined(USE_SIMD)
2361 if (simd_add_sub(n)) {
2362 gretl_matrix_simd_scalar_mul(m->val, x, n);
2363 return;
2364 }
2365 #endif
2366
2367 for (i=0; i<n; i++) {
2368 m->val[i] *= x;
2369 }
2370 }
2371
2372 /**
2373 * gretl_matrix_divide_by_scalar:
2374 * @m: matrix to operate on.
2375 * @x: scalar by which to divide.
2376 *
2377 * Divides all elements of @m by @x.
2378 *
2379 * Returns: 0 on success, 1 if x = 0.
2380 */
2381
gretl_matrix_divide_by_scalar(gretl_matrix * m,double x)2382 int gretl_matrix_divide_by_scalar (gretl_matrix *m, double x)
2383 {
2384 if (x == 0.0) {
2385 return 1;
2386 } else {
2387 gretl_matrix_multiply_by_scalar(m, 1.0 / x);
2388 return 0;
2389 }
2390 }
2391
2392 /**
2393 * gretl_matrix_switch_sign:
2394 * @m: matrix to operate on.
2395 *
2396 * Changes the sign of each element of @m.
2397 */
2398
gretl_matrix_switch_sign(gretl_matrix * m)2399 void gretl_matrix_switch_sign (gretl_matrix *m)
2400 {
2401 if (!gretl_is_null_matrix(m)) {
2402 int i, n = m->rows * m->cols;
2403
2404 for (i=0; i<n; i++) {
2405 m->val[i] = -m->val[i];
2406 }
2407 }
2408 }
2409
2410 /**
2411 * gretl_matrix_raise:
2412 * @m: matrix to operate on.
2413 * @x: exponent.
2414 *
2415 * Raises each element of @m to the power @x.
2416 */
2417
gretl_matrix_raise(gretl_matrix * m,double x)2418 void gretl_matrix_raise (gretl_matrix *m, double x)
2419 {
2420 if (!gretl_is_null_matrix(m)) {
2421 int i, n = m->rows * m->cols;
2422
2423 for (i=0; i<n; i++) {
2424 m->val[i] = pow(m->val[i], x);
2425 }
2426 }
2427 }
2428
2429 /* if x can be represented as an integer and is an exact power of 2,
2430 return the exact log_2 of x, otherwise use log() to compute an
2431 approximation.
2432 */
2433
log_2(double x)2434 static double log_2 (double x)
2435 {
2436 int i, s;
2437
2438 if (x <= 0) {
2439 return log(x);
2440 }
2441
2442 if (floor(x) != x || x < 2 || x > (double) INT_MAX) {
2443 return log2(x);
2444 }
2445
2446 s = floor(x);
2447
2448 for (i=1; ; i++) {
2449 if (s % 2) {
2450 break;
2451 }
2452 s /= 2;
2453 if (s == 1) {
2454 return (double) i;
2455 }
2456 }
2457
2458 return log2(x);
2459 }
2460
mexp_error_eps(int q)2461 static double mexp_error_eps (int q)
2462 {
2463 double x1, x2, x3, x4;
2464 double qf = x_factorial(q);
2465
2466 x1 = pow(2.0, 3.0 - (q + q));
2467 x2 = qf * qf;
2468 x3 = x_factorial(2 * q);
2469 x4 = (2 * q + 1) * x3;
2470 x3 *= x4;
2471
2472 return x1 * (x2 / x3);
2473 }
2474
2475 /**
2476 * gretl_matrix_exp:
2477 * @m: square matrix to operate on.
2478 * @err: location to receive error code.
2479 *
2480 * Calculates the matrix exponential of @m, using algorithm
2481 * 11.3.1 from Golub and Van Loan, "Matrix Computations", 3e.
2482 *
2483 * Returns: the exponential, or NULL on failure.
2484 */
2485
gretl_matrix_exp(const gretl_matrix * m,int * err)2486 gretl_matrix *gretl_matrix_exp (const gretl_matrix *m, int *err)
2487 {
2488 gretl_matrix *A = NULL;
2489 gretl_matrix *X = NULL;
2490 gretl_matrix *N = NULL;
2491 gretl_matrix *D = NULL;
2492 gretl_matrix *W = NULL;
2493 double xa, c, j, delta = 1.0e-13;
2494 int q, k, n;
2495
2496 if (gretl_is_null_matrix(m) || m->rows != m->cols) {
2497 *err = E_DATA;
2498 return NULL;
2499 }
2500
2501 n = m->rows;
2502
2503 A = gretl_matrix_copy_tmp(m);
2504 X = gretl_identity_matrix_new(n);
2505 N = gretl_identity_matrix_new(n);
2506 D = gretl_identity_matrix_new(n);
2507 W = gretl_matrix_alloc(n, n);
2508
2509 if (A == NULL || X == NULL || N == NULL ||
2510 D == NULL || W == NULL) {
2511 *err = E_ALLOC;
2512 goto bailout;
2513 }
2514
2515 xa = gretl_matrix_infinity_norm(A);
2516
2517 j = floor(log_2(xa));
2518 if (j < 0) {
2519 j = 0;
2520 }
2521
2522 gretl_matrix_divide_by_scalar(A, pow(2.0, j));
2523
2524 for (q=1; q<16; q++) {
2525 c = mexp_error_eps(q);
2526 if (c * xa <= delta) {
2527 break;
2528 }
2529 }
2530
2531 c = 1.0;
2532
2533 for (k=1; k<=q; k++) {
2534 c *= (q - k + 1.0) / ((2.0*q - k + 1) * k);
2535 /* X = AX */
2536 gretl_matrix_multiply(A, X, W);
2537 gretl_matrix_copy_values(X, W);
2538 /* N = N + cX */
2539 gretl_matrix_multiply_by_scalar(W, c);
2540 gretl_matrix_add_to(N, W);
2541 /* D = D + (-1)^k cX */
2542 if (k % 2) {
2543 gretl_matrix_subtract_from(D, W);
2544 } else {
2545 gretl_matrix_add_to(D, W);
2546 }
2547 }
2548
2549 /* solve DF = N for F */
2550 *err = gretl_LU_solve(D, N);
2551
2552 if (!*err) {
2553 for (k=0; k<j; k++) {
2554 gretl_matrix_multiply(N, N, W);
2555 gretl_matrix_copy_values(N, W);
2556 }
2557 }
2558
2559 bailout:
2560
2561 gretl_matrix_free(A);
2562 gretl_matrix_free(X);
2563 gretl_matrix_free(D);
2564 gretl_matrix_free(W);
2565
2566 if (*err) {
2567 gretl_matrix_free(N);
2568 N = NULL;
2569 }
2570
2571 return N;
2572 }
2573
2574 /**
2575 * gretl_matrix_polroots:
2576 * @a: vector of coefficients.
2577 * @force_complex: see below.
2578 * @err: location to receive error code.
2579 *
2580 * Calculates the roots of the polynomial with coefficients
2581 * given by @a. If the degree of the polynomial is p, then
2582 * @a should contain p + 1 coefficients in ascending order,
2583 * i.e. starting with the constant and ending with the
2584 * coefficient on x^p.
2585 *
2586 * Returns: by default, a p-vector if all the roots are real,
2587 * otherwise a p x 2 matrix with the real parts in the first
2588 * column and the imaginary parts in the second. The @force_complex
2589 * flag can be used to enforce a p x 2 return even if the
2590 * imaginary parts are all zero.
2591 */
2592
gretl_matrix_polroots(const gretl_matrix * a,int force_complex,int * err)2593 gretl_matrix *gretl_matrix_polroots (const gretl_matrix *a,
2594 int force_complex,
2595 int *err)
2596 {
2597 gretl_matrix *r = NULL;
2598 double *xcof = NULL, *cof = NULL;
2599 cmplx *roots = NULL;
2600 int i, m, order, polerr;
2601
2602 *err = 0;
2603
2604 m = gretl_vector_get_length(a);
2605
2606 if (m < 2) {
2607 *err = E_DATA;
2608 return NULL;
2609 }
2610
2611 order = m - 1;
2612
2613 xcof = malloc(m * sizeof *xcof);
2614 cof = malloc(m * sizeof *cof);
2615 roots = malloc(order * sizeof *roots);
2616
2617 if (xcof == NULL || cof == NULL || roots == NULL) {
2618 *err = E_ALLOC;
2619 goto bailout;
2620 }
2621
2622 for (i=0; i<m; i++) {
2623 xcof[i] = a->val[i];
2624 }
2625
2626 polerr = polrt(xcof, cof, order, roots);
2627
2628 if (polerr) {
2629 *err = E_DATA;
2630 } else {
2631 int allreal = !force_complex;
2632
2633 for (i=0; i<order && allreal; i++) {
2634 if (roots[i].i != 0) {
2635 allreal = 0;
2636 }
2637 }
2638 if (allreal) {
2639 r = gretl_matrix_alloc(order, 1);
2640 } else {
2641 r = gretl_matrix_alloc(order, 2);
2642 }
2643 if (r == NULL) {
2644 *err = E_ALLOC;
2645 goto bailout;
2646 }
2647 for (i=0; i<order; i++) {
2648 gretl_matrix_set(r, i, 0, roots[i].r);
2649 if (!allreal) {
2650 gretl_matrix_set(r, i, 1, roots[i].i);
2651 }
2652 }
2653 }
2654
2655 bailout:
2656
2657 free(xcof);
2658 free(cof);
2659 free(roots);
2660
2661 return r;
2662 }
2663
2664 /**
2665 * gretl_vector_copy_values:
2666 * @targ: target vector.
2667 * @src: source vector.
2668 *
2669 * Copies the elements of @src into the corresponding elements
2670 * of @targ.
2671 *
2672 * Returns: 0 on successful completion, or %E_NONCONF if the
2673 * two vectors are not of the same length.
2674 */
2675
gretl_vector_copy_values(gretl_vector * targ,const gretl_vector * src)2676 int gretl_vector_copy_values (gretl_vector *targ,
2677 const gretl_vector *src)
2678 {
2679 int n;
2680
2681 if (src == NULL) {
2682 fprintf(stderr, "gretl_vector_copy_values: src is NULL\n");
2683 return E_DATA;
2684 }
2685
2686 if (targ == src) {
2687 /* no-op */
2688 return 0;
2689 }
2690
2691 n = gretl_vector_get_length(src);
2692
2693 if (gretl_vector_get_length(targ) != n) {
2694 return E_NONCONF;
2695 }
2696
2697 if (n > 0) {
2698 memcpy(targ->val, src->val, n * sizeof *targ->val);
2699 }
2700
2701 return 0;
2702 }
2703
2704 /**
2705 * gretl_matrix_copy_values:
2706 * @targ: target matrix.
2707 * @src: source matrix.
2708 *
2709 * Copies the elements of @src into the corresponding elements
2710 * of @targ.
2711 *
2712 * Returns: 0 on successful completion, or
2713 * %E_NONCONF if the two matrices are not
2714 * conformable for the operation.
2715 */
2716
gretl_matrix_copy_values(gretl_matrix * targ,const gretl_matrix * src)2717 int gretl_matrix_copy_values (gretl_matrix *targ,
2718 const gretl_matrix *src)
2719 {
2720 int n;
2721
2722 if (src == NULL) {
2723 fprintf(stderr, "gretl_matrix_copy_values: src is NULL\n");
2724 return E_DATA;
2725 } else if (targ == src) {
2726 /* no-op */
2727 return 0;
2728 } else if (targ->is_complex + src->is_complex == 1) {
2729 return E_MIXED;
2730 }
2731
2732 if (targ->rows != src->rows || targ->cols != src->cols) {
2733 fprintf(stderr, "gretl_matrix_copy_values: targ is %d x %d but src is %d x %d\n",
2734 targ->rows, targ->cols, src->rows, src->cols);
2735 return E_NONCONF;
2736 }
2737
2738 n = src->rows * src->cols;
2739 if (n > 0) {
2740 if (src->is_complex) {
2741 n *= 2;
2742 }
2743 memcpy(targ->val, src->val, n * sizeof *targ->val);
2744 }
2745
2746 return 0;
2747 }
2748
2749 /**
2750 * gretl_matrix_copy_data:
2751 * @targ: target matrix.
2752 * @src: source matrix.
2753 *
2754 * Copies all data from @src to @targ: this does the same
2755 * as gretl_matrix_copy_values() but also transcribes
2756 * t1, t2, colnames and rownames information, if present.
2757 *
2758 * Returns: 0 on successful completion, non-zero code on
2759 * failure.
2760 */
2761
gretl_matrix_copy_data(gretl_matrix * targ,const gretl_matrix * src)2762 int gretl_matrix_copy_data (gretl_matrix *targ,
2763 const gretl_matrix *src)
2764 {
2765 int err;
2766
2767 err = gretl_matrix_copy_values(targ, src);
2768
2769 if (!err) {
2770 err = gretl_matrix_copy_info(targ, src);
2771 }
2772
2773 return err;
2774 }
2775
2776 /**
2777 * gretl_matrix_copy_values_shaped:
2778 * @targ: target matrix.
2779 * @src: source matrix.
2780 *
2781 * Copies the elements of @src into @targ, column
2782 * by column.
2783 *
2784 * Returns: 0 on successful completion, or %E_NONCONF if
2785 * the two matrices do not contain the same number of
2786 * elements.
2787 */
2788
gretl_matrix_copy_values_shaped(gretl_matrix * targ,const gretl_matrix * src)2789 int gretl_matrix_copy_values_shaped (gretl_matrix *targ,
2790 const gretl_matrix *src)
2791 {
2792 int n = targ->rows * targ->cols;
2793
2794 if (src->rows * src->cols != n) {
2795 fprintf(stderr, "gretl_matrix_copy_values_shaped: targ is %d x %d but src is %d x %d\n",
2796 targ->rows, targ->cols, src->rows, src->cols);
2797 return E_NONCONF;
2798 }
2799
2800 if (n > 0) {
2801 memcpy(targ->val, src->val, n * sizeof *targ->val);
2802 }
2803
2804 return 0;
2805 }
2806
add_scalar_to_matrix(gretl_matrix * targ,double x)2807 static int add_scalar_to_matrix (gretl_matrix *targ, double x)
2808 {
2809 int i, n = targ->rows * targ->cols;
2810
2811 for (i=0; i<n; i++) {
2812 targ->val[i] += x;
2813 }
2814
2815 return 0;
2816 }
2817
subtract_scalar_from_matrix(gretl_matrix * targ,double x)2818 static int subtract_scalar_from_matrix (gretl_matrix *targ, double x)
2819 {
2820 int i, n = targ->rows * targ->cols;
2821
2822 for (i=0; i<n; i++) {
2823 targ->val[i] -= x;
2824 }
2825
2826 return 0;
2827 }
2828
2829 /**
2830 * gretl_matrix_add_to:
2831 * @targ: target matrix.
2832 * @src: source matrix.
2833 *
2834 * Adds the elements of @src to the corresponding elements
2835 * of @targ.
2836 *
2837 * Returns: 0 on successful completion, or %E_NONCONF if the
2838 * two matrices are not conformable for the operation.
2839 * In the special case where @src is in fact a scalar, the
2840 * operation always goes through OK, with the scalar being
2841 * added to each element of @targ.
2842 */
2843
2844 int
gretl_matrix_add_to(gretl_matrix * targ,const gretl_matrix * src)2845 gretl_matrix_add_to (gretl_matrix *targ, const gretl_matrix *src)
2846 {
2847 int i, n;
2848
2849 if (targ->rows != src->rows || targ->cols != src->cols) {
2850 if (matrix_is_scalar(src)) {
2851 return add_scalar_to_matrix(targ, src->val[0]);
2852 } else {
2853 fprintf(stderr, "gretl_matrix_add_to: adding %d x %d to %d x %d\n",
2854 src->rows, src->cols, targ->rows, targ->cols);
2855 return E_NONCONF;
2856 }
2857 }
2858
2859 n = src->rows * src->cols;
2860
2861 #if defined(_OPENMP)
2862 if (!gretl_use_openmp(n)) {
2863 goto st_mode;
2864 }
2865 #pragma omp parallel for private(i)
2866 for (i=0; i<n; i++) {
2867 targ->val[i] += src->val[i];
2868 }
2869 return 0;
2870
2871 st_mode:
2872 #endif
2873
2874 #if defined(USE_SIMD)
2875 if (simd_add_sub(n)) {
2876 return gretl_matrix_simd_add_to(targ, src, n);
2877 }
2878 #endif
2879
2880 for (i=0; i<n; i++) {
2881 targ->val[i] += src->val[i];
2882 }
2883
2884 return 0;
2885 }
2886
2887 /**
2888 * gretl_matrix_add:
2889 * @a: source matrix.
2890 * @b: source matrix.
2891 * @c: target matrix.
2892 *
2893 * Adds the elements of @a and @b, the result going to @c.
2894 *
2895 * Returns: 0 on successful completion, or %E_NONCONF if the
2896 * matrices are not conformable for the operation.
2897 */
2898
2899 int
gretl_matrix_add(const gretl_matrix * a,const gretl_matrix * b,gretl_matrix * c)2900 gretl_matrix_add (const gretl_matrix *a, const gretl_matrix *b,
2901 gretl_matrix *c)
2902 {
2903 int rows = a->rows, cols = a->cols;
2904 int i, n;
2905
2906 if (a->is_complex || b->is_complex) {
2907 fprintf(stderr, "E_CMPLX in gretl_matrix_add\n");
2908 return E_CMPLX;
2909 } else if (b->rows != rows || c->rows != rows ||
2910 b->cols != cols || c->cols != cols) {
2911 fprintf(stderr, "gretl_matrix_add: non-conformable\n");
2912 return E_NONCONF;
2913 }
2914
2915 n = rows * cols;
2916
2917 #if defined(USE_SIMD)
2918 if (simd_add_sub(n)) {
2919 return gretl_matrix_simd_add(a->val, b->val, c->val, n);
2920 }
2921 #endif
2922
2923 for (i=0; i<n; i++) {
2924 c->val[i] = a->val[i] + b->val[i];
2925 }
2926
2927 return 0;
2928 }
2929
2930 /**
2931 * gretl_matrix_add_transpose_to:
2932 * @targ: target matrix.
2933 * @src: source matrix.
2934 *
2935 * Adds the elements of @src, transposed, to the corresponding
2936 * elements of @targ.
2937 *
2938 * Returns: 0 on successful completion, or %E_NONCONF if the
2939 * two matrices are not conformable for the operation.
2940 */
2941
gretl_matrix_add_transpose_to(gretl_matrix * targ,const gretl_matrix * src)2942 int gretl_matrix_add_transpose_to (gretl_matrix *targ,
2943 const gretl_matrix *src)
2944 {
2945 int i, j, k = 0;
2946
2947 if (targ->is_complex || src->is_complex) {
2948 fprintf(stderr, "E_CMPLX in gretl_matrix_add_transpose_to\n");
2949 return E_CMPLX;
2950 } else if (targ->rows != src->cols || targ->cols != src->rows) {
2951 fprintf(stderr, "gretl_matrix_add_transpose_to: "
2952 "adding %d x %d to %d x %d\n",
2953 src->cols, src->rows, targ->rows, targ->cols);
2954 return E_NONCONF;
2955 }
2956
2957 /* note: the k index follows column-major order */
2958 for (i=0; i<src->rows; i++) {
2959 for (j=0; j<src->cols; j++) {
2960 targ->val[k++] += gretl_matrix_get(src, i, j);
2961 }
2962 }
2963
2964 return 0;
2965 }
2966
2967 /**
2968 * gretl_matrix_subtract_from:
2969 * @targ: target matrix.
2970 * @src: source matrix.
2971 *
2972 * Subtracts the elements of @src from the corresponding elements
2973 * of @targ.
2974 *
2975 * Returns: 0 on successful completion, or %E_NONCONF if the
2976 * two matrices are not conformable for the operation.
2977 * In the special case where @src is in fact a scalar, the
2978 * operation always goes through OK, with the scalar being
2979 * subtracted from each element of @targ.
2980 */
2981
2982 int
gretl_matrix_subtract_from(gretl_matrix * targ,const gretl_matrix * src)2983 gretl_matrix_subtract_from (gretl_matrix *targ, const gretl_matrix *src)
2984 {
2985 int i, n;
2986
2987 if (targ->is_complex || src->is_complex) {
2988 fprintf(stderr, "E_CMPLX in gretl_matrix_subtract_from\n");
2989 return E_CMPLX;
2990 } else if (targ->rows != src->rows || targ->cols != src->cols) {
2991 if (matrix_is_scalar(src)) {
2992 return subtract_scalar_from_matrix(targ, src->val[0]);
2993 } else {
2994 return E_NONCONF;
2995 }
2996 }
2997
2998 n = src->rows * src->cols;
2999
3000 #if defined(_OPENMP)
3001 if (!gretl_use_openmp(n)) {
3002 goto st_mode;
3003 }
3004 #pragma omp parallel for private(i)
3005 for (i=0; i<n; i++) {
3006 targ->val[i] -= src->val[i];
3007 }
3008 return 0;
3009
3010 st_mode:
3011 #endif
3012
3013 #if defined(USE_SIMD)
3014 if (simd_add_sub(n)) {
3015 return gretl_matrix_simd_subt_from(targ, src, n);
3016 }
3017 #endif
3018
3019 for (i=0; i<n; i++) {
3020 targ->val[i] -= src->val[i];
3021 }
3022
3023 return 0;
3024 }
3025
3026 /**
3027 * gretl_matrix_subtract:
3028 * @a: source_matrix.
3029 * @b: source matrix.
3030 * @c: target matrix.
3031 *
3032 * Subtracts the elements of @b from the corresponding elements
3033 * of @a, the result going to @c.
3034 *
3035 * Returns: 0 on successful completion, or %E_NONCONF if the
3036 * matrices are not conformable for the operation.
3037 */
3038
3039 int
gretl_matrix_subtract(const gretl_matrix * a,const gretl_matrix * b,gretl_matrix * c)3040 gretl_matrix_subtract (const gretl_matrix *a, const gretl_matrix *b,
3041 gretl_matrix *c)
3042 {
3043 int rows = a->rows, cols = a->cols;
3044 int i, n;
3045
3046 if (a->is_complex || b->is_complex) {
3047 fprintf(stderr, "E_CMPLX in gretl_matrix_subtract\n");
3048 return E_CMPLX;
3049 } else if (b->rows != rows || c->rows != rows ||
3050 b->cols != cols || c->cols != cols) {
3051 fprintf(stderr, "gretl_matrix_subtract: non-conformable\n");
3052 return E_NONCONF;
3053 }
3054
3055 n = rows * cols;
3056
3057 #if defined(USE_SIMD)
3058 if (simd_add_sub(n)) {
3059 return gretl_matrix_simd_subtract(a->val, b->val, c->val, n);
3060 }
3061 #endif
3062
3063 for (i=0; i<n; i++) {
3064 c->val[i] = a->val[i] - b->val[i];
3065 }
3066
3067 return 0;
3068 }
3069
3070 /**
3071 * gretl_matrix_subtract_reversed:
3072 * @a: m x n matrix.
3073 * @b: m x n matrix.
3074 *
3075 * Operates on @b such that b_{ij} = a_{ij} - b_{ij}.
3076 *
3077 * Returns: 0 on successful completion, or %E_NONCONF if the
3078 * two matrices are not conformable for the operation.
3079 */
3080
3081 int
gretl_matrix_subtract_reversed(const gretl_matrix * a,gretl_matrix * b)3082 gretl_matrix_subtract_reversed (const gretl_matrix *a, gretl_matrix *b)
3083 {
3084 int i, n;
3085
3086 if (a->rows != b->rows || a->cols != b->cols) {
3087 return E_NONCONF;
3088 }
3089
3090 n = a->rows * b->cols;
3091
3092 #if defined(_OPENMP)
3093 if (!gretl_use_openmp(n)) {
3094 goto st_mode;
3095 }
3096 #pragma omp parallel for private(i)
3097 for (i=0; i<n; i++) {
3098 b->val[i] = a->val[i] - b->val[i];
3099 }
3100 return 0;
3101
3102 st_mode:
3103 #endif
3104
3105 for (i=0; i<n; i++) {
3106 b->val[i] = a->val[i] - b->val[i];
3107 }
3108
3109 return 0;
3110 }
3111
3112 /**
3113 * gretl_matrix_I_minus:
3114 * @m: original square matrix, n x n.
3115 *
3116 * Rewrites @m as (I - m), where I is the n x n identity
3117 * matrix.
3118 *
3119 * Returns: 0 on successful completion, or %E_NONCONF if @m is
3120 * not square.
3121 */
3122
gretl_matrix_I_minus(gretl_matrix * m)3123 int gretl_matrix_I_minus (gretl_matrix *m)
3124 {
3125 double x;
3126 int i, j;
3127
3128 if (m->rows != m->cols) {
3129 return E_NONCONF;
3130 }
3131
3132 for (i=0; i<m->rows; i++) {
3133 for (j=0; j<m->cols; j++) {
3134 x = gretl_matrix_get(m, i, j);
3135 if (i == j) {
3136 gretl_matrix_set(m, i, j, 1.0 - x);
3137 } else if (x != 0.0) {
3138 gretl_matrix_set(m, i, j, -x);
3139 }
3140 }
3141 }
3142
3143 return 0;
3144 }
3145
3146 /**
3147 * gretl_matrix_inscribe_I:
3148 * @m: original matrix.
3149 * @row: top row for insertion.
3150 * @col: leftmost row for insertion.
3151 * @n: dimension (rows and columns) of identity matrix.
3152 *
3153 * Writes an n x n identity matrix into matrix @m, the top left-hand
3154 * corner of the insertion being given by @row and @col (which are
3155 * 0-based).
3156 *
3157 * Returns: 0 on successful completion, or %E_NONCONF if an identity
3158 * matrix of the specified size cannot be fitted into @m at the
3159 * specified location.
3160 */
3161
gretl_matrix_inscribe_I(gretl_matrix * m,int row,int col,int n)3162 int gretl_matrix_inscribe_I (gretl_matrix *m, int row, int col, int n)
3163 {
3164 int i, j, mi, mj;
3165
3166 if (n <= 0) {
3167 return E_NONCONF;
3168 }
3169
3170 if (row < 0 || row + n > m->rows) {
3171 return E_NONCONF;
3172 }
3173
3174 if (col < 0 || col + n > m->cols) {
3175 return E_NONCONF;
3176 }
3177
3178 for (i=0; i<n; i++) {
3179 mi = row + i;
3180 for (j=0; j<n; j++) {
3181 mj = col + j;
3182 gretl_matrix_set(m, mi, mj, (i == j)? 1.0 : 0.0);
3183 }
3184 }
3185
3186 return 0;
3187 }
3188
3189
3190 /**
3191 * gretl_matrix_transpose_in_place:
3192 * @m: matrix to transpose.
3193 *
3194 * Tranposes @m in place.
3195 *
3196 * Returns: 0 on success, non-zero error code otherwise.
3197 */
3198
gretl_matrix_transpose_in_place(gretl_matrix * m)3199 int gretl_matrix_transpose_in_place (gretl_matrix *m)
3200 {
3201 int r = m->rows;
3202 int c = m->cols;
3203 int i, j;
3204
3205 gretl_matrix_destroy_info(m);
3206
3207 if (r == 1 || c == 1) {
3208 m->cols = r;
3209 m->rows = c;
3210 return 0;
3211 }
3212
3213 if (r == c) {
3214 double mij, mji;
3215 int n = r - 1;
3216
3217 for (i=0; i<n; i++) {
3218 for (j=i+1; j<c; j++) {
3219 mij = gretl_matrix_get(m, i, j);
3220 mji = gretl_matrix_get(m, j, i);
3221 gretl_matrix_set(m, i, j, mji);
3222 gretl_matrix_set(m, j, i, mij);
3223 }
3224 }
3225 } else {
3226 size_t sz = r * c * sizeof(double);
3227 double *val;
3228 int k = 0;
3229
3230 val = mval_malloc(sz);
3231 if (val == NULL) {
3232 return E_ALLOC;
3233 }
3234
3235 memcpy(val, m->val, sz);
3236
3237 m->rows = c;
3238 m->cols = r;
3239
3240 for (j=0; j<c; j++) {
3241 for (i=0; i<r; i++) {
3242 gretl_matrix_set(m, j, i, val[k++]);
3243 }
3244 }
3245
3246 mval_free(val);
3247 }
3248
3249 return 0;
3250 }
3251
3252 /**
3253 * gretl_matrix_transpose:
3254 * @targ: target matrix.
3255 * @src: source matrix.
3256 *
3257 * Fills out @targ (which must be pre-allocated and of the right
3258 * dimensions) with the transpose of @src.
3259 *
3260 * Returns: 0 on success, non-zero error code otherwise.
3261 */
3262
gretl_matrix_transpose(gretl_matrix * targ,const gretl_matrix * src)3263 int gretl_matrix_transpose (gretl_matrix *targ, const gretl_matrix *src)
3264 {
3265 int i, j, k = 0;
3266 double x;
3267
3268 if (targ->rows != src->cols || targ->cols != src->rows) {
3269 return E_NONCONF;
3270 }
3271
3272 for (j=0; j<src->cols; j++) {
3273 for (i=0; i<src->rows; i++) {
3274 x = src->val[k++];
3275 gretl_matrix_set(targ, j, i, x);
3276 }
3277 }
3278
3279 return 0;
3280 }
3281
3282 /**
3283 * gretl_square_matrix_transpose:
3284 * @m: square matrix to operate on.
3285 *
3286 * Transposes the matrix @m.
3287 *
3288 * Returns: 0 on success, non-zero error code otherwise.
3289 */
3290
gretl_square_matrix_transpose(gretl_matrix * m)3291 int gretl_square_matrix_transpose (gretl_matrix *m)
3292 {
3293 double x, y;
3294 int mij, mji;
3295 int i, j;
3296
3297 if (m->rows != m->cols) {
3298 fputs("gretl_square_matrix_transpose: matrix must be square\n",
3299 stderr);
3300 return 1;
3301 }
3302
3303 for (i=0; i<m->rows-1; i++) {
3304 for (j=i+1; j<m->rows; j++) {
3305 mij = mdx(m,i,j);
3306 mji = mdx(m,j,i);
3307 x = m->val[mij];
3308 y = m->val[mji];
3309 m->val[mij] = y;
3310 m->val[mji] = x;
3311 }
3312 }
3313
3314 return 0;
3315 }
3316
3317 /**
3318 * gretl_matrix_xtr_symmetric:
3319 * @m: gretl_matrix.
3320 *
3321 * Computes the symmetric part of @m by averaging its off-diagonal
3322 * elements.
3323 */
3324
gretl_matrix_xtr_symmetric(gretl_matrix * m)3325 void gretl_matrix_xtr_symmetric (gretl_matrix *m)
3326 {
3327 double x;
3328 int mij, mji;
3329 int i, j;
3330
3331 for (i=0; i<m->rows; i++) {
3332 for (j=0; j<i; j++) {
3333 mij = mdx(m,i,j);
3334 mji = mdx(m,j,i);
3335 x = m->val[mij];
3336 x += m->val[mji];
3337 m->val[mij] = m->val[mji] = 0.5 * x;
3338 }
3339 }
3340 }
3341
3342 /**
3343 * gretl_matrix_add_self_transpose:
3344 * @m: (square) matrix to operate on.
3345 *
3346 * Adds the transpose of @m to @m itself, yielding a symmetric
3347 * matrix.
3348 *
3349 * Returns: 0 on successful completion, or
3350 * 1 if the source matrix is not square.
3351 */
3352
gretl_matrix_add_self_transpose(gretl_matrix * m)3353 int gretl_matrix_add_self_transpose (gretl_matrix *m)
3354 {
3355 double x;
3356 int mij, mji;
3357 int i, j;
3358
3359 if (m->rows != m->cols) {
3360 fputs("gretl_matrix_add_self_transpose: matrix must be square\n",
3361 stderr);
3362 return E_NONCONF;
3363 }
3364
3365 for (i=0; i<m->rows; i++) {
3366 for (j=i; j<m->rows; j++) {
3367 mij = mdx(m,i,j);
3368 mji = mdx(m,j,i);
3369 x = m->val[mij];
3370 x += m->val[mji];
3371 m->val[mij] = m->val[mji] = x;
3372 }
3373 }
3374
3375 return 0;
3376 }
3377
3378 /**
3379 * gretl_matrix_vectorize:
3380 * @targ: target vector, (m * n) x 1.
3381 * @src: source matrix, m x n.
3382 *
3383 * Writes into @targ vec(@src), that is, a column vector
3384 * formed by stacking the columns of @src.
3385 *
3386 * Returns: 0 on successful completion, or %E_NONCONF if
3387 * @targ is not correctly dimensioned.
3388 */
3389
3390 int
gretl_matrix_vectorize(gretl_matrix * targ,const gretl_matrix * src)3391 gretl_matrix_vectorize (gretl_matrix *targ, const gretl_matrix *src)
3392 {
3393 int n;
3394
3395 if (gretl_is_null_matrix(src) || gretl_is_null_matrix(targ)) {
3396 return E_DATA;
3397 } else if (src->is_complex + targ->is_complex == 1) {
3398 return E_MIXED;
3399 }
3400
3401 n = src->rows * src->cols;
3402
3403 if (targ->cols != 1 || targ->rows != n) {
3404 return E_NONCONF;
3405 }
3406
3407 if (src->is_complex) {
3408 n *= 2;
3409 }
3410 memcpy(targ->val, src->val, n * sizeof *src->val);
3411
3412 return 0;
3413 }
3414
3415 /**
3416 * gretl_matrix_vectorize_new:
3417 * @m: matrix to be vectorized.
3418 *
3419 * Returns: a gretl column vector, vec(@m), or NULL on failure.
3420 */
3421
gretl_matrix_vectorize_new(const gretl_matrix * m)3422 gretl_matrix *gretl_matrix_vectorize_new (const gretl_matrix *m)
3423 {
3424 gretl_matrix *v;
3425 int n;
3426
3427 if (gretl_is_null_matrix(m)) {
3428 return NULL;
3429 }
3430
3431 n = m->rows * m->cols;
3432
3433 v = gretl_matching_matrix_new(n, 1, m);
3434
3435 if (v != NULL) {
3436 if (m->is_complex) {
3437 n *= 2;
3438 }
3439 memcpy(v->val, m->val, n * sizeof *m->val);
3440 }
3441
3442 return v;
3443 }
3444
3445 /**
3446 * gretl_matrix_unvectorize:
3447 * @targ: target matrix, m x n.
3448 * @src: source vector, (m * n) x 1.
3449 *
3450 * Writes successive blocks of length m from @src into
3451 * the successive columns of @targ (that is, performs the
3452 * inverse of the vec() operation).
3453 *
3454 * Returns: 0 on successful completion, or %E_NONCONF if
3455 * @targ is not correctly dimensioned.
3456 */
3457
3458 int
gretl_matrix_unvectorize(gretl_matrix * targ,const gretl_matrix * src)3459 gretl_matrix_unvectorize (gretl_matrix *targ, const gretl_matrix *src)
3460 {
3461 int n;
3462
3463 if (gretl_is_null_matrix(src) || gretl_is_null_matrix(targ)) {
3464 return E_DATA;
3465 } else if (src->is_complex + targ->is_complex == 1) {
3466 return E_MIXED;
3467 }
3468
3469 n = targ->rows * targ->cols;
3470
3471 if (src->cols != 1 || src->rows != n) {
3472 return E_NONCONF;
3473 }
3474
3475 if (src->is_complex) {
3476 n *= 2;
3477 }
3478 memcpy(targ->val, src->val, n * sizeof *src->val);
3479
3480 return 0;
3481 }
3482
3483 /**
3484 * gretl_matrix_vectorize_h:
3485 * @targ: target vector, (m * (m+1)/2) x 1.
3486 * @src: source square matrix, m x m.
3487 *
3488 * Writes into @targ vech(@src), that is, a column vector
3489 * containing the lower-triangular elements of @src.
3490 * This is only useful for symmetric matrices, but for the
3491 * sake of performance we don't check for that.
3492 *
3493 * Returns: 0 on successful completion, or %E_NONCONF if
3494 * @targ is not correctly dimensioned.
3495 */
3496
3497 int
gretl_matrix_vectorize_h(gretl_matrix * targ,const gretl_matrix * src)3498 gretl_matrix_vectorize_h (gretl_matrix *targ, const gretl_matrix *src)
3499 {
3500 int n = src->rows;
3501 int m = n * (n+1) / 2;
3502 int i, j, k;
3503
3504 if (targ->cols != 1 || targ->rows != m) {
3505 return E_NONCONF;
3506 } else if (src->is_complex + targ->is_complex == 1) {
3507 return E_MIXED;
3508 }
3509
3510 k = 0;
3511 for (i=0; i<n; i++) {
3512 for (j=i; j<n; j++) {
3513 if (src->is_complex) {
3514 targ->z[k++] = gretl_cmatrix_get(src, i, j);
3515 } else {
3516 targ->val[k++] = gretl_matrix_get(src, i, j);
3517 }
3518 }
3519 }
3520
3521 return 0;
3522 }
3523
3524 /**
3525 * gretl_matrix_unvectorize_h:
3526 * @targ: target matrix, n x n.
3527 * @src: source vector, m x 1.
3528 *
3529 * Rearranges successive blocks of decreasing length from @src into
3530 * the successive columns of @targ (that is, performs the
3531 * inverse of the vech() operation): @targ comes out symmetric.
3532 *
3533 * Returns: 0 on successful completion, or %E_NONCONF if
3534 * @targ is not correctly dimensioned.
3535 */
3536
3537 int
gretl_matrix_unvectorize_h(gretl_matrix * targ,const gretl_matrix * src)3538 gretl_matrix_unvectorize_h (gretl_matrix *targ, const gretl_matrix *src)
3539 {
3540 int n = targ->rows, m = src->rows;
3541 double complex z;
3542 double x;
3543 int i, j, k;
3544
3545 if (src->cols != 1 || n * (n + 1) != 2 * m) {
3546 return E_NONCONF;
3547 } else if (src->is_complex + targ->is_complex == 1) {
3548 return E_MIXED;
3549 }
3550
3551 k = 0;
3552 for (j=0; j<n; j++) {
3553 for (i=j; i<n; i++) {
3554 if (src->is_complex) {
3555 z = src->z[k++];
3556 gretl_cmatrix_set(targ, i, j, conj(z));
3557 gretl_cmatrix_set(targ, j, i, z);
3558 } else {
3559 x = src->val[k++];
3560 gretl_matrix_set(targ, i, j, x);
3561 gretl_matrix_set(targ, j, i, x);
3562 }
3563 }
3564 }
3565
3566 return 0;
3567 }
3568
3569 /**
3570 * gretl_matrix_inscribe_matrix:
3571 * @targ: target matrix.
3572 * @src: source matrix.
3573 * @row: row offset for insertion (0-based).
3574 * @col: column offset for insertion.
3575 * @mod: either %GRETL_MOD_TRANSPOSE or %GRETL_MOD_NONE.
3576 *
3577 * Writes @src into @targ, starting at offset @row, @col.
3578 * The @targ matrix must be large enough to sustain the
3579 * inscription of @src at the specified point. If @mod
3580 * is %GRETL_MOD_TRANSPOSE it is in fact the transpose of
3581 * @src that is written into @targ.
3582 *
3583 * Returns: 0 on success, %E_NONCONF if the matrices are
3584 * not conformable for the operation.
3585 */
3586
gretl_matrix_inscribe_matrix(gretl_matrix * targ,const gretl_matrix * src,int row,int col,GretlMatrixMod mod)3587 int gretl_matrix_inscribe_matrix (gretl_matrix *targ,
3588 const gretl_matrix *src,
3589 int row, int col,
3590 GretlMatrixMod mod)
3591 {
3592 int m = (mod == GRETL_MOD_TRANSPOSE)? src->cols : src->rows;
3593 int n = (mod == GRETL_MOD_TRANSPOSE)? src->rows : src->cols;
3594 double complex z;
3595 double x;
3596 int i, j, ri, cj;
3597
3598 if (row < 0 || col < 0) {
3599 return E_NONCONF;
3600 } else if (targ->is_complex + src->is_complex == 1) {
3601 return E_MIXED;
3602 }
3603
3604 if (row + m > targ->rows ||
3605 col + n > targ->cols) {
3606 fprintf(stderr, "gretl_matrix_inscribe_matrix: out of bounds\n");
3607 return E_NONCONF;
3608 }
3609
3610 for (i=0; i<m; i++) {
3611 ri = row + i;
3612 for (j=0; j<n; j++) {
3613 cj = col + j;
3614 if (src->is_complex) {
3615 if (mod == GRETL_MOD_TRANSPOSE) {
3616 z = cmatrix_transp_get(src, i, j);
3617 } else {
3618 z = gretl_cmatrix_get(src, i, j);
3619 if (mod == GRETL_MOD_CUMULATE) {
3620 z += gretl_cmatrix_get(targ, ri, cj);
3621 }
3622 }
3623 gretl_cmatrix_set(targ, ri, cj, z);
3624 } else {
3625 if (mod == GRETL_MOD_TRANSPOSE) {
3626 x = matrix_transp_get(src, i, j);
3627 } else {
3628 x = gretl_matrix_get(src, i, j);
3629 if (mod == GRETL_MOD_CUMULATE) {
3630 x += gretl_matrix_get(targ, ri, cj);
3631 }
3632 }
3633 gretl_matrix_set(targ, ri, cj, x);
3634 }
3635 }
3636 }
3637
3638 return 0;
3639 }
3640
3641 /**
3642 * gretl_matrix_extract_matrix:
3643 * @targ: target matrix.
3644 * @src: source matrix.
3645 * @row: row offset for extraction (0-based).
3646 * @col: column offset for extraction.
3647 * @mod: either %GRETL_MOD_TRANSPOSE or %GRETL_MOD_NONE.
3648 *
3649 * Writes into @targ a sub-matrix of @src, taken from the
3650 * offset @row, @col. The @targ matrix must be large enough
3651 * to provide a sub-matrix of the dimensions of @src.
3652 * If @mod is %GRETL_MOD_TRANSPOSE it is in fact the transpose
3653 * of the sub-matrix that that is written into @targ.
3654 *
3655 * Returns: 0 on success, %E_NONCONF if the matrices are
3656 * not conformable for the operation.
3657 */
3658
gretl_matrix_extract_matrix(gretl_matrix * targ,const gretl_matrix * src,int row,int col,GretlMatrixMod mod)3659 int gretl_matrix_extract_matrix (gretl_matrix *targ,
3660 const gretl_matrix *src,
3661 int row, int col,
3662 GretlMatrixMod mod)
3663 {
3664 int m = (mod == GRETL_MOD_TRANSPOSE)? targ->cols : targ->rows;
3665 int n = (mod == GRETL_MOD_TRANSPOSE)? targ->rows : targ->cols;
3666 double complex z;
3667 double x;
3668 int i, j, si, sj;
3669
3670 if (row < 0 || col < 0) {
3671 return E_NONCONF;
3672 } else if (src->is_complex + targ->is_complex == 1) {
3673 return E_MIXED;
3674 } else if (row >= src->rows) {
3675 fprintf(stderr, "extract_matrix: requested starting row=%d, but "
3676 "src has %d rows\n", row, src->rows);
3677 return E_NONCONF;
3678 } else if (col >= src->cols) {
3679 fprintf(stderr, "extract_matrix: requested starting col=%d, but "
3680 "src has %d cols\n", col, src->cols);
3681 return E_NONCONF;
3682 } else if (row + m > src->rows || col + n > src->cols) {
3683 fprintf(stderr, "gretl_matrix_extract_matrix: out of bounds\n");
3684 return E_NONCONF;
3685 }
3686
3687 si = row;
3688 for (i=0; i<m; i++) {
3689 sj = col;
3690 for (j=0; j<n; j++) {
3691 if (src->is_complex) {
3692 z = gretl_cmatrix_get(src, si, sj++);
3693 if (mod == GRETL_MOD_TRANSPOSE) {
3694 cmatrix_transp_set(targ, i, j, z);
3695 } else {
3696 gretl_cmatrix_set(targ, i, j, z);
3697 }
3698 } else {
3699 x = gretl_matrix_get(src, si, sj++);
3700 if (mod == GRETL_MOD_TRANSPOSE) {
3701 matrix_transp_set(targ, i, j, x);
3702 } else {
3703 gretl_matrix_set(targ, i, j, x);
3704 }
3705 }
3706 }
3707 si++;
3708 }
3709
3710 return 0;
3711 }
3712
3713 /**
3714 * gretl_matrix_steal_data:
3715 * @m: matrix to operate on.
3716 *
3717 * "Steals" the allocated data from @m, which is left with a
3718 * NULL data pointer.
3719 *
3720 * Returns: a pointer to the "stolen" data.
3721 */
3722
gretl_matrix_steal_data(gretl_matrix * m)3723 double *gretl_matrix_steal_data (gretl_matrix *m)
3724 {
3725 double *vals = NULL;
3726
3727 if (m != NULL) {
3728 if (is_block_matrix(m)) {
3729 matrix_block_error("gretl_matrix_steal_data");
3730 return NULL;
3731 }
3732 vals = m->val;
3733 m->val = NULL;
3734 m->z = NULL;
3735 }
3736
3737 return vals;
3738 }
3739
3740 /**
3741 * gretl_matrix_print:
3742 * @m: matrix.
3743 * @msg: message to print with matrix, or NULL.
3744 *
3745 * Prints the given matrix to stderr.
3746 */
3747
gretl_matrix_print(const gretl_matrix * m,const char * msg)3748 void gretl_matrix_print (const gretl_matrix *m, const char *msg)
3749 {
3750 char *fmt = "%#12.5g ";
3751 char *envstr;
3752 int i, j;
3753
3754 if (m == NULL || m->val == NULL) {
3755 if (msg != NULL && *msg != '\0') {
3756 fprintf(stderr, "%s: matrix is NULL\n", msg);
3757 } else {
3758 fputs("matrix is NULL\n", stderr);
3759 }
3760 return;
3761 }
3762
3763 if (m->is_complex) {
3764 PRN *prn = gretl_print_new(GRETL_PRINT_STDERR, NULL);
3765
3766 if (prn != NULL) {
3767 gretl_cmatrix_print(m, msg, prn);
3768 gretl_print_destroy(prn);
3769 }
3770 return;
3771 }
3772
3773 envstr = getenv("GRETL_MATRIX_DEBUG");
3774 if (envstr != NULL && atoi(envstr) > 0) {
3775 fmt = "%#22.15g ";
3776 } else {
3777 envstr = getenv("GRETL_MATRIX_PRINT6");
3778 if (envstr != NULL && atoi(envstr) > 0) {
3779 fmt = "%#12.6g ";
3780 }
3781 }
3782
3783 if (msg != NULL && *msg != '\0') {
3784 fprintf(stderr, "%s (%d x %d)", msg, m->rows, m->cols);
3785 if (is_block_matrix(m)) {
3786 fprintf(stderr, " (part of matrix block)\n\n");
3787 } else if (gretl_matrix_is_dated(m)) {
3788 int mt1 = gretl_matrix_get_t1(m);
3789 int mt2 = gretl_matrix_get_t2(m);
3790
3791 fprintf(stderr, " [t1 = %d, t2 = %d]\n\n", mt1 + 1, mt2 + 1);
3792 } else {
3793 fputs("\n\n", stderr);
3794 }
3795 }
3796
3797 for (i=0; i<m->rows; i++) {
3798 for (j=0; j<m->cols; j++) {
3799 fprintf(stderr, fmt, gretl_matrix_get(m, i, j));
3800 }
3801 fputc('\n', stderr);
3802 }
3803
3804 fputc('\n', stderr);
3805 }
3806
3807 #define DEFAULT_EQTOL 1.0e-9 /* 2014-08-05: was 1.5e-12 */
3808
3809 static double eq_tol = DEFAULT_EQTOL;
3810
3811 /**
3812 * gretl_matrix_set_equals_tolerance:
3813 * @tol: tolerance value.
3814 *
3815 * Sets the tolerance for judging whether or not a matrix is symmetric
3816 * (see gretl_matrix_is_symmetric() and also
3817 * gretl_invert_symmetric_matrix()). The tolerance is the maximum
3818 * relative difference between corresponding off-diagonal elements that
3819 * is acceptable in a supposedly "symmetric" matrix. The default
3820 * value is 1.0e-9.
3821 */
3822
gretl_matrix_set_equals_tolerance(double tol)3823 void gretl_matrix_set_equals_tolerance (double tol)
3824 {
3825 eq_tol = tol;
3826 }
3827
3828 /**
3829 * gretl_matrix_unset_equals_tolerance:
3830 *
3831 * Sets the tolerance for judging whether or not a matrix is symmetric
3832 * to its default value. See also gretl_matrix_set_equals_tolerance().
3833 */
3834
gretl_matrix_unset_equals_tolerance(void)3835 void gretl_matrix_unset_equals_tolerance (void)
3836 {
3837 eq_tol = DEFAULT_EQTOL;
3838 }
3839
sneq_reldiff(double x,double y)3840 static double sneq_reldiff (double x, double y)
3841 {
3842 double rd;
3843
3844 if (x == 0.0) {
3845 rd = fabs(y);
3846 } else if (y == 0.0) {
3847 rd = fabs(x);
3848 } else if (x > y) {
3849 rd = fabs((x - y) / y);
3850 } else {
3851 rd = fabs((y - x) / x);
3852 }
3853
3854 return rd;
3855 }
3856
real_gretl_matrix_is_symmetric(const gretl_matrix * m,int verbose)3857 static int real_gretl_matrix_is_symmetric (const gretl_matrix *m,
3858 int verbose)
3859 {
3860 double x, y, rd;
3861 int i, j;
3862
3863 if (gretl_is_null_matrix(m)) {
3864 return 0;
3865 }
3866
3867 for (i=1; i<m->rows; i++) {
3868 for (j=0; j<i; j++) {
3869 x = gretl_matrix_get(m, i, j);
3870 y = gretl_matrix_get(m, j, i);
3871 if ((rd = sneq_reldiff(x, y)) > eq_tol) {
3872 if (verbose) {
3873 fprintf(stderr, "M(%d,%d) = %.16g but M(%d,%d) = %.16g\n"
3874 " reldiff = %g\n", i, j, x, j, i, y, rd);
3875 if (m->rows < 100) {
3876 gretl_matrix_print(m, "gretl_matrix_is_symmetric()");
3877 }
3878 }
3879 return 0;
3880 }
3881 }
3882 }
3883
3884 return 1;
3885 }
3886
3887 /**
3888 * gretl_matrix_is_symmetric:
3889 * @m: gretl_matrix.
3890 *
3891 * Returns: 1 if @m is symmetric (with a small relative tolerance
3892 * for asymmetry), otherwise 0.
3893 */
3894
gretl_matrix_is_symmetric(const gretl_matrix * m)3895 int gretl_matrix_is_symmetric (const gretl_matrix *m)
3896 {
3897 return real_gretl_matrix_is_symmetric(m, 0);
3898 }
3899
3900 /**
3901 * gretl_matrix_is_idempotent:
3902 * @m: gretl_matrix.
3903 * @tol: numerical tolerance
3904 *
3905 * Returns: 1 if @m is idempotent, otherwise 0.
3906 */
3907
gretl_matrix_is_idempotent(const gretl_matrix * m,double tol)3908 int gretl_matrix_is_idempotent (const gretl_matrix *m, double tol)
3909 {
3910 gretl_matrix *b;
3911 int k, ret, err;
3912
3913 if (gretl_is_null_matrix(m)) {
3914 return 0;
3915 }
3916
3917 k = m->rows;
3918
3919 if (m->cols != k) {
3920 return 0;
3921 }
3922
3923 b = gretl_matrix_alloc(k, k);
3924 if (b == NULL) {
3925 return 0;
3926 }
3927
3928 gretl_matrix_multiply(m, m, b);
3929 ret = gretl_matrices_are_equal(m, b, tol, &err);
3930 gretl_matrix_free(b);
3931
3932 return ret;
3933 }
3934
3935 /**
3936 * gretl_matrix_infinity_norm:
3937 * @m: gretl_matrix.
3938 *
3939 * Returns: the infinity-norm of @m (the maximum value across
3940 * the rows of @m of the sum of the absolute values of
3941 * the elements in the given row).
3942 */
3943
gretl_matrix_infinity_norm(const gretl_matrix * m)3944 double gretl_matrix_infinity_norm (const gretl_matrix *m)
3945 {
3946 double rsum, rmax = 0.0;
3947 int i, j;
3948
3949 if (gretl_is_null_matrix(m)) {
3950 return NADBL;
3951 }
3952
3953 for (i=0; i<m->rows; i++) {
3954 rsum = 0.0;
3955 for (j=0; j<m->cols; j++) {
3956 rsum += fabs(gretl_matrix_get(m, i, j));
3957 }
3958 if (rsum > rmax) {
3959 rmax = rsum;
3960 }
3961 }
3962
3963 return rmax;
3964 }
3965
3966 /**
3967 * gretl_matrix_one_norm:
3968 * @m: gretl_matrix.
3969 *
3970 * Returns: the 1-norm of @m (the maximum value across
3971 * the columns of @m of the sum of the absolute values of
3972 * the elements in the given column).
3973 */
3974
gretl_matrix_one_norm(const gretl_matrix * m)3975 double gretl_matrix_one_norm (const gretl_matrix *m)
3976 {
3977 double csum, cmax = 0.0;
3978 int i, j;
3979
3980 if (gretl_is_null_matrix(m)) {
3981 return NADBL;
3982 }
3983
3984 for (j=0; j<m->cols; j++) {
3985 csum = 0.0;
3986 for (i=0; i<m->rows; i++) {
3987 csum += fabs(gretl_matrix_get(m, i, j));
3988 }
3989 if (csum > cmax) {
3990 cmax = csum;
3991 }
3992 }
3993
3994 return cmax;
3995 }
3996
3997 /**
3998 * gretl_vcv_log_determinant:
3999 * @m: gretl_matrix.
4000 * @err: location to receive error code.
4001 *
4002 * Compute the log determinant of the symmetric positive-definite
4003 * matrix @m using Cholesky decomposition.
4004 *
4005 * Returns: the log determinant, or #NADBL on failure.
4006 */
4007
gretl_vcv_log_determinant(const gretl_matrix * m,int * err)4008 double gretl_vcv_log_determinant (const gretl_matrix *m, int *err)
4009 {
4010 gretl_matrix *a = NULL;
4011 char uplo = 'L';
4012 integer n, info;
4013 double det = NADBL;
4014 int i;
4015
4016 if (gretl_is_null_matrix(m)) {
4017 return NADBL;
4018 }
4019
4020 n = m->rows;
4021
4022 if (m->rows != m->cols) {
4023 fputs("gretl_vcv_log_determinant: matrix must be square\n", stderr);
4024 *err = E_INVARG;
4025 return det;
4026 }
4027
4028 if (!real_gretl_matrix_is_symmetric(m, 1)) {
4029 fputs("gretl_vcv_log_determinant: matrix is not symmetric\n", stderr);
4030 *err = E_INVARG;
4031 return det;
4032 }
4033
4034 a = gretl_matrix_copy_tmp(m);
4035 if (a == NULL) {
4036 fputs("gretl_vcv_log_determinant: out of memory\n", stderr);
4037 *err = E_ALLOC;
4038 return det;
4039 }
4040
4041 dpotrf_(&uplo, &n, a->val, &n, &info);
4042
4043 if (info != 0) {
4044 if (info > 0) {
4045 *err = E_NOTPD;
4046 } else {
4047 fputs("gretl_vcv_log_determinant: illegal argument to dpotrf\n",
4048 stderr);
4049 *err = E_INVARG;
4050 }
4051 } else {
4052 double x;
4053
4054 det = 1.0;
4055 for (i=0; i<n; i++) {
4056 x = gretl_matrix_get(a, i, i);
4057 det *= x * x;
4058 }
4059 det = log(det);
4060 }
4061
4062 gretl_matrix_free(a);
4063
4064 return det;
4065 }
4066
4067 /* This is really only necessary when using OpenBLAS:
4068 when the matrix under analysis contains NaN values
4069 the pivot values calculated by dgetrf() can go out
4070 of bounds. We could flag an error here if we find
4071 an out-of-bounds value, but the downside of that is
4072 that we'd get different results when using OpenBLAS
4073 versus netlib lapack/blas (since netlib returns a
4074 NaN matrix rather than erroring out).
4075
4076 This check added 2015-12-24, required for OpenBLAS
4077 0.2.16.dev and earlier.
4078 */
4079
pivot_check(integer * ipiv,int n)4080 static void pivot_check (integer *ipiv, int n)
4081 {
4082 int i;
4083
4084 for (i=0; i<n; i++) {
4085 if (ipiv[i] > n) {
4086 /* clamp the bad value to avoid a crash */
4087 fprintf(stderr, "pivot_check: clamped bad ipiv[%d] = %d\n",
4088 i, ipiv[i]);
4089 ipiv[i] = n;
4090 }
4091 }
4092 }
4093
4094 /* Calculate the determinant of @a using LU factorization.
4095 If logdet != 0 and absval == 0, return the log of the
4096 determinant, or NA if the determinant is non-positive.
4097 if logdet != 0 and absval != 0, return the log of the
4098 absolute value of the determinant. Otherwise return the
4099 determinant itself.
4100 */
4101
gretl_LU_determinant(gretl_matrix * a,int logdet,int absval,int * err)4102 static double gretl_LU_determinant (gretl_matrix *a, int logdet,
4103 int absval, int *err)
4104 {
4105 integer n, info;
4106 integer *ipiv;
4107 double det;
4108 int i;
4109
4110 if (gretl_is_null_matrix(a)) {
4111 *err = E_DATA;
4112 return NADBL;
4113 }
4114
4115 *err = 0;
4116 n = a->rows;
4117 if (a->cols != n) {
4118 fputs("gretl_LU_determinant: matrix must be square\n", stderr);
4119 *err = E_NONCONF;
4120 return NADBL;
4121 }
4122
4123 if (n == 1) {
4124 /* simple 1 x 1 case */
4125 det = a->val[0];
4126 if (logdet) {
4127 if (det > 0) {
4128 return log(det);
4129 } else if (det < 0) {
4130 return absval ? log(-det) : NADBL;
4131 } else {
4132 return NADBL;
4133 }
4134 } else {
4135 return det;
4136 }
4137 }
4138
4139 ipiv = malloc(n * sizeof *ipiv);
4140 if (ipiv == NULL) {
4141 *err = E_ALLOC;
4142 return NADBL;
4143 }
4144
4145 dgetrf_(&n, &n, a->val, &n, ipiv, &info);
4146
4147 if (info > 0) {
4148 if (logdet) {
4149 *err = E_SINGULAR;
4150 return NADBL;
4151 } else {
4152 return 0;
4153 }
4154 } else if (info < 0) {
4155 fprintf(stderr, "gretl_LU_determinant: dgetrf gave info = %d\n",
4156 (int) info);
4157 free(ipiv);
4158 *err = E_DATA;
4159 return NADBL;
4160 } else {
4161 pivot_check(ipiv, n);
4162 }
4163
4164 if (logdet) {
4165 int negcount = 0;
4166
4167 /* Note: we're better off here taking logs and adding, rather
4168 than multiplying terms then taking the log of the product.
4169 In this way we can get a finite result for the log-determinant
4170 of a matrix whose determinant is numerically "infinite" --
4171 up to a point.
4172 */
4173 det = 0.0;
4174 for (i=0; i<n; i++) {
4175 double aii = gretl_matrix_get(a, i, i);
4176
4177 if (aii == 0.0) {
4178 fputs("gretl_matrix_log_determinant: determinant = 0\n", stderr);
4179 det = NADBL;
4180 break;
4181 }
4182 if (ipiv[i] != i + 1) {
4183 aii = -aii;
4184 }
4185 if (aii < 0) {
4186 aii = -aii;
4187 negcount++;
4188 }
4189 det += log(aii);
4190 }
4191 if (!absval && negcount % 2) {
4192 fputs("gretl_matrix_log_determinant: determinant is < 0\n", stderr);
4193 det = NADBL;
4194 }
4195 } else {
4196 /* plain determinant */
4197 det = 1.0;
4198 for (i=0; i<n; i++) {
4199 if (ipiv[i] != i + 1) {
4200 det = -det;
4201 }
4202 det *= gretl_matrix_get(a, i, i);
4203 }
4204 }
4205
4206 free(ipiv);
4207
4208 return det;
4209 }
4210
det_22(const double * a,int * err)4211 static double det_22 (const double *a, int *err)
4212 {
4213 double d = a[0]*a[3] - a[1]*a[2];
4214
4215 if (na(d)) {
4216 *err = E_NAN;
4217 }
4218
4219 return d;
4220 }
4221
det_33(const double * a,int * err)4222 static double det_33 (const double *a, int *err)
4223 {
4224 double d = a[0]*a[4]*a[8] - a[0]*a[7]*a[5]
4225 + a[3]*a[7]*a[2] - a[3]*a[1]*a[8]
4226 + a[6]*a[1]*a[5] - a[6]*a[4]*a[2];
4227
4228 if (na(d)) {
4229 *err = E_NAN;
4230 }
4231
4232 return d;
4233 }
4234
4235 /**
4236 * gretl_matrix_determinant:
4237 * @a: gretl_matrix.
4238 * @err: location to receive error code.
4239 *
4240 * Compute the determinant of the square matrix @a using the LU
4241 * factorization. Matrix @a is not preserved: it is overwritten
4242 * by the factorization.
4243 *
4244 * Returns: the determinant, or #NADBL on failure.
4245 */
4246
gretl_matrix_determinant(gretl_matrix * a,int * err)4247 double gretl_matrix_determinant (gretl_matrix *a, int *err)
4248 {
4249 if (a != NULL) {
4250 if (a->rows == 2 && a->cols == 2) {
4251 return det_22(a->val, err);
4252 } else if (a->rows == 3 && a->cols == 3) {
4253 return det_33(a->val, err);
4254 }
4255 }
4256
4257 return gretl_LU_determinant(a, 0, 0, err);
4258 }
4259
4260 /**
4261 * gretl_matrix_log_determinant:
4262 * @a: gretl_matrix.
4263 * @err: location to receive error code.
4264 *
4265 * Compute the log of the determinant of the square matrix @a using LU
4266 * factorization. Matrix @a is not preserved: it is overwritten
4267 * by the factorization.
4268 *
4269 * Returns: the determinant, or #NADBL on failure.
4270 */
4271
gretl_matrix_log_determinant(gretl_matrix * a,int * err)4272 double gretl_matrix_log_determinant (gretl_matrix *a, int *err)
4273 {
4274 return gretl_LU_determinant(a, 1, 0, err);
4275 }
4276
4277 /**
4278 * gretl_matrix_log_abs_determinant:
4279 * @a: gretl_matrix.
4280 * @err: location to receive error code.
4281 *
4282 * Compute the log of the absolute value of the determinant of the
4283 * square matrix @a using LU factorization. Matrix @a is not
4284 * preserved: it is overwritten by the factorization.
4285 *
4286 * Returns: the determinant, or #NADBL on failure.
4287 */
4288
gretl_matrix_log_abs_determinant(gretl_matrix * a,int * err)4289 double gretl_matrix_log_abs_determinant (gretl_matrix *a, int *err)
4290 {
4291 return gretl_LU_determinant(a, 1, 1, err);
4292 }
4293
matrix_grab_content(gretl_matrix * targ,gretl_matrix * src)4294 static void matrix_grab_content (gretl_matrix *targ, gretl_matrix *src)
4295 {
4296 targ->rows = src->rows;
4297 targ->cols = src->cols;
4298 targ->is_complex = src->is_complex;
4299
4300 mval_free(targ->val);
4301 targ->val = src->val;
4302 targ->z = src->z;
4303 src->val = NULL;
4304 src->z = NULL;
4305
4306 gretl_matrix_destroy_info(targ);
4307 targ->info = src->info;
4308 src->info = NULL;
4309 }
4310
4311 /* least squares solution using QR, with column pivoting and
4312 detection of rank deficiency, using lapack dgelsy
4313 */
4314
QR_solve(gretl_matrix * A,gretl_matrix * B)4315 static int QR_solve (gretl_matrix *A, gretl_matrix *B)
4316 {
4317 integer m, n, lda, nrhs;
4318 integer rank, info = 0;
4319 integer lwork = -1;
4320 integer *jpvt = NULL;
4321 double *work = NULL;
4322 double *rwork = NULL;
4323 double rcond = QR_RCOND_MIN;
4324 int zfunc = 0;
4325 int wsz = 1;
4326 int i, err = 0;
4327
4328 lda = m = A->rows;
4329 n = A->cols;
4330 nrhs = B->cols;
4331
4332 if (m > n && is_block_matrix(B)) {
4333 matrix_block_error("QR solve");
4334 return E_DATA;
4335 }
4336
4337 if (n > m || B->rows != m) {
4338 return E_NONCONF;
4339 }
4340
4341 if (A->is_complex) {
4342 if (!B->is_complex) {
4343 return E_INVARG;
4344 }
4345 zfunc = 1;
4346 wsz = 2;
4347 }
4348
4349 jpvt = malloc(n * sizeof *jpvt);
4350 work = lapack_malloc(wsz * sizeof *work);
4351 if (jpvt == NULL || work == NULL) {
4352 err = E_ALLOC;
4353 goto bailout;
4354 }
4355
4356 if (zfunc) {
4357 rwork = malloc(2 * n * sizeof *rwork);
4358 if (rwork == NULL) {
4359 err = E_ALLOC;
4360 goto bailout;
4361 }
4362 }
4363
4364 for (i=0; i<n; i++) {
4365 jpvt[i] = 0;
4366 }
4367
4368 /* workspace query */
4369 if (zfunc) {
4370 zgelsy_(&m, &n, &nrhs, (cmplx *) A->z, &lda, (cmplx *) B->z, &lda,
4371 jpvt, &rcond, &rank, (cmplx *) work, &lwork, rwork, &info);
4372 } else {
4373 dgelsy_(&m, &n, &nrhs, A->val, &lda, B->val, &lda,
4374 jpvt, &rcond, &rank, work, &lwork, &info);
4375 }
4376 if (info != 0) {
4377 fprintf(stderr, "gelsy: info = %d\n", (int) info);
4378 err = 1;
4379 goto bailout;
4380 }
4381
4382 /* optimally sized work array */
4383 lwork = (integer) work[0];
4384 work = lapack_realloc(work, (size_t) lwork * wsz * sizeof *work);
4385 if (work == NULL) {
4386 err = E_ALLOC;
4387 goto bailout;
4388 }
4389
4390 /* run actual computation */
4391 if (zfunc) {
4392 zgelsy_(&m, &n, &nrhs, (cmplx *) A->z, &lda, (cmplx *) B->z, &lda,
4393 jpvt, &rcond, &rank, (cmplx *) work, &lwork, rwork, &info);
4394 } else {
4395 dgelsy_(&m, &n, &nrhs, A->val, &lda, B->val, &lda,
4396 jpvt, &rcond, &rank, work, &lwork, &info);
4397 }
4398 if (info != 0) {
4399 fprintf(stderr, "gelsy: info = %d\n", (int) info);
4400 err = 1;
4401 } else if (rank < n) {
4402 fprintf(stderr, "gelsy: cols(A) = %d, rank(A) = %d\n",
4403 A->cols, rank);
4404 }
4405
4406 if (!err && m > n) {
4407 gretl_matrix *C;
4408
4409 C = gretl_matrix_trim_rows(B, 0, m - n, &err);
4410 if (!err) {
4411 matrix_grab_content(B, C);
4412 gretl_matrix_free(C);
4413 }
4414 }
4415
4416 bailout:
4417
4418 free(jpvt);
4419 lapack_free(work);
4420 if (zfunc) {
4421 free(rwork);
4422 }
4423
4424 return err;
4425 }
4426
4427 /**
4428 * gretl_LU_solve_invert:
4429 * @a: square matrix.
4430 * @b: matrix.
4431 *
4432 * Solves ax = b for the unknown x, using LU decomposition,
4433 * then proceeds to use the decomposition to invert @a. Calls
4434 * the LAPACK functions dgetrf(), dgetrs() and dgetri(); the
4435 * decomposition proceeds via partial pivoting with row
4436 * interchanges.
4437 *
4438 * On exit, @b is replaced by the solution and @a is replaced
4439 * by its inverse.
4440 *
4441 * Returns: 0 on successful completion, non-zero code on error.
4442 */
4443
gretl_LU_solve_invert(gretl_matrix * a,gretl_matrix * b)4444 int gretl_LU_solve_invert (gretl_matrix *a, gretl_matrix *b)
4445 {
4446 char trans = 'N';
4447 integer info;
4448 integer n, ldb, nrhs = 1;
4449 integer lwork = -1;
4450 double *work = NULL;
4451 integer *ipiv;
4452 int err = 0;
4453
4454 if (gretl_is_null_matrix(a) ||
4455 gretl_is_null_matrix(b) ||
4456 a->rows != a->cols) {
4457 return E_DATA;
4458 }
4459
4460 n = a->rows;
4461
4462 if (b->cols == 1) {
4463 ldb = b->rows;
4464 } else if (b->rows == 1) {
4465 ldb = b->cols;
4466 } else {
4467 nrhs = b->cols;
4468 ldb = b->rows;
4469 }
4470
4471 ipiv = malloc(n * sizeof *ipiv);
4472 if (ipiv == NULL) {
4473 return E_ALLOC;
4474 }
4475
4476 dgetrf_(&n, &n, a->val, &n, ipiv, &info);
4477
4478 if (info != 0) {
4479 fprintf(stderr, "gretl_LU_solve_invert: dgetrf gave info = %d\n",
4480 (int) info);
4481 err = (info < 0)? E_DATA : E_SINGULAR;
4482 } else {
4483 pivot_check(ipiv, n);
4484 }
4485
4486 if (!err) {
4487 dgetrs_(&trans, &n, &nrhs, a->val, &n, ipiv, b->val, &ldb, &info);
4488 if (info != 0) {
4489 fprintf(stderr, "gretl_LU_solve_invert: dgetrs gave info = %d\n",
4490 (int) info);
4491 err = E_DATA;
4492 }
4493 }
4494
4495 if (!err) {
4496 work = lapack_malloc(sizeof *work);
4497 if (work == NULL) {
4498 err = E_ALLOC;
4499 }
4500 }
4501
4502 if (!err) {
4503 dgetri_(&n, a->val, &n, ipiv, work, &lwork, &info);
4504 if (info != 0) {
4505 err = wspace_fail(info, work[0]);
4506 } else {
4507 lwork = (integer) work[0];
4508 work = lapack_realloc(work, lwork * sizeof *work);
4509 if (work == NULL) {
4510 err = E_ALLOC;
4511 }
4512 }
4513 }
4514
4515 if (!err) {
4516 dgetri_(&n, a->val, &n, ipiv, work, &lwork, &info);
4517 if (info != 0) {
4518 fprintf(stderr, "gretl_LU_solve_invert: dgetri gave info = %d\n",
4519 (int) info);
4520 err = E_DATA;
4521 }
4522 }
4523
4524 free(ipiv);
4525 lapack_free(work);
4526
4527 return err;
4528 }
4529
4530 #define BLASDEBUG 1
4531
4532 /**
4533 * gretl_LU_solve:
4534 * @a: square matrix.
4535 * @b: matrix.
4536 *
4537 * Solves ax = b for the unknown x, via LU decomposition
4538 * using partial pivoting with row interchanges.
4539 * On exit, @b is replaced by the solution and @a is replaced
4540 * by its decomposition. Calls the LAPACK functions dgetrf()
4541 * and dgetrs().
4542 *
4543 * Returns: 0 on successful completion, non-zero code on error.
4544 */
4545
gretl_LU_solve(gretl_matrix * a,gretl_matrix * b)4546 int gretl_LU_solve (gretl_matrix *a, gretl_matrix *b)
4547 {
4548 char trans = 'N';
4549 integer info;
4550 integer n, ldb, nrhs = 1;
4551 integer *ipiv;
4552 int zfunc = 0;
4553 int debug = 0;
4554 int err = 0;
4555
4556 #if BLASDEBUG
4557 const char *envstr = getenv("GRETL_MATRIX_DEBUG");
4558
4559 debug = (envstr != NULL && atoi(envstr) > 0);
4560 #endif
4561
4562 if (gretl_is_null_matrix(a) ||
4563 gretl_is_null_matrix(b) ||
4564 a->rows != a->cols) {
4565 return E_DATA;
4566 }
4567
4568 zfunc = a->is_complex;
4569 if (zfunc && !b->is_complex) {
4570 return E_INVARG;
4571 }
4572
4573 if (debug) {
4574 fputs("gretl_LU_solve\n", stderr);
4575 gretl_matrix_print(a, "a, on input");
4576 gretl_matrix_print(b, "b, on input");
4577 }
4578
4579 n = a->cols;
4580
4581 if (b->cols == 1) {
4582 ldb = b->rows;
4583 } else if (b->rows == 1) {
4584 ldb = b->cols;
4585 } else {
4586 nrhs = b->cols;
4587 ldb = b->rows;
4588 }
4589
4590 ipiv = malloc(n * sizeof *ipiv);
4591 if (ipiv == NULL) {
4592 return E_ALLOC;
4593 }
4594
4595 if (zfunc) {
4596 zgetrf_(&n, &n, (cmplx *) a->val, &n, ipiv, &info);
4597 } else {
4598 dgetrf_(&n, &n, a->val, &n, ipiv, &info);
4599 }
4600
4601 if (info != 0) {
4602 fprintf(stderr, "gretl_LU_solve: getrf gave info = %d\n",
4603 (int) info);
4604 err = (info < 0)? E_DATA : E_SINGULAR;
4605 } else {
4606 pivot_check(ipiv, n);
4607 }
4608
4609 if (!err) {
4610 if (zfunc) {
4611 zgetrs_(&trans, &n, &nrhs, (cmplx *) a->val, &n, ipiv,
4612 (cmplx *) b->val, &ldb, &info);
4613 } else {
4614 dgetrs_(&trans, &n, &nrhs, a->val, &n, ipiv, b->val, &ldb, &info);
4615 }
4616 if (info != 0) {
4617 fprintf(stderr, "gretl_LU_solve: dgetrs gave info = %d\n",
4618 (int) info);
4619 err = E_DATA;
4620 }
4621 }
4622
4623 if (debug) {
4624 gretl_matrix_print(a, "a, on return");
4625 gretl_matrix_print(b, "b, on return");
4626 fprintf(stderr, "err, on return = %d\n", err);
4627 }
4628
4629 free(ipiv);
4630
4631 return err;
4632 }
4633
4634 /*
4635 * gretl_matrix_solve:
4636 * @a: m x n matrix, with m >= n.
4637 * @b: gretl_matrix.
4638 *
4639 * Solves ax = b for the unknown x. If @a is square the method
4640 * is LU decomposition, on which see also gretl_LU_solve().
4641 * If m > n the QR decomposition is used to find the least
4642 * squares solution.
4643 *
4644 * On exit, @b is replaced by the solution and @a is replaced
4645 * by its decomposition.
4646 *
4647 * Returns: 0 on successful completion, non-zero code on error.
4648 */
4649
gretl_matrix_solve(gretl_matrix * a,gretl_matrix * b)4650 static int gretl_matrix_solve (gretl_matrix *a, gretl_matrix *b)
4651 {
4652 if (gretl_is_null_matrix(a) || gretl_is_null_matrix(b)) {
4653 return E_DATA;
4654 }
4655
4656 if (a->rows == a->cols) {
4657 return gretl_LU_solve(a, b);
4658 } else if (a->rows > a->cols) {
4659 return QR_solve(a, b);
4660 } else {
4661 return E_DATA;
4662 }
4663 }
4664
4665 #define CHOL_TINY 8.0e-09
4666 #define CHOL_SMALL 1.0e-08
4667
4668 /* Native Cholesky decomposition and back-solution, with a check for
4669 excessively small diagonal elements. The matrix @a is the vech
4670 of X'X, and b is the right-hand side on entry, the solution on
4671 successful exit. This may not be as efficient as lapack's
4672 dpotrf/dpotrs, but the advantage is that this function flags
4673 near-singularity whereas the LAPACK functions generate an error
4674 condition only on outright singularity.
4675
4676 Note that the matrix @a is overwritten.
4677 */
4678
native_cholesky_decomp_solve(gretl_matrix * a,gretl_matrix * b)4679 static int native_cholesky_decomp_solve (gretl_matrix *a, gretl_matrix *b)
4680 {
4681 double *xtx = a->val;
4682 double *xty = b->val;
4683 int i, j, k, kk, l, jm1;
4684 double e, d, d1, d2, test, xx;
4685 int nc = b->rows;
4686
4687 if (xtx[0] <= 0.0) {
4688 fprintf(stderr, "%s %d: xtx <= 0.0\n", __FILE__, __LINE__);
4689 return E_NAN;
4690 }
4691
4692 e = 1.0 / sqrt(xtx[0]);
4693 xtx[0] = e;
4694 xty[0] *= e;
4695 for (i=1; i<nc; i++) {
4696 xtx[i] *= e;
4697 }
4698
4699 kk = nc;
4700
4701 for (j=1; j<nc; j++) {
4702 /* diagonal elements */
4703 d = d1 = 0.0;
4704 k = jm1 = j;
4705
4706 for (l=1; l<=jm1; l++) {
4707 xx = xtx[k];
4708 d1 += xx * xty[l-1];
4709 d += xx * xx;
4710 k += nc-l;
4711 }
4712
4713 d2 = xtx[kk] - d;
4714 test = d2 / xtx[kk];
4715
4716 /* check for effective singularity */
4717 if (test < CHOL_TINY) {
4718 fprintf(stderr, "cholesky: test[%d] = %g\n", j, test);
4719 return E_SINGULAR;
4720 } else if (test < CHOL_SMALL) {
4721 fprintf(stderr, "cholesky: test[%d] = %g\n", j, test);
4722 }
4723
4724 e = 1 / sqrt(d2);
4725 xtx[kk] = e;
4726 xty[j] = (xty[j] - d1) * e;
4727
4728 /* off-diagonal elements */
4729 for (i=j+1; i<nc; i++) {
4730 kk++;
4731 d = 0.0;
4732 k = j;
4733 for (l=1; l<=jm1; l++) {
4734 d += xtx[k] * xtx[k-j+i];
4735 k += nc - l;
4736 }
4737 xtx[kk] = (xtx[kk] - d) * e;
4738 }
4739 kk++;
4740 }
4741
4742 kk--;
4743
4744 /* back-solve for the coefficients, into b */
4745
4746 xty[nc-1] *= xtx[kk];
4747
4748 for (j=nc-2; j>=0; j--) {
4749 d = xty[j];
4750 for (i=nc-1; i>j; i--) {
4751 d -= xty[i] * xtx[--kk];
4752 }
4753 xty[j] = d * xtx[--kk];
4754 }
4755
4756 for (j=0; j<nc; j++) {
4757 if (isnan(xty[j])) {
4758 fprintf(stderr, "%s %d: coeff %d is NaN\n", __FILE__, __LINE__, j);
4759 return E_NAN;
4760 }
4761 }
4762
4763 return 0;
4764 }
4765
4766 #define CHOL_RCOND_MIN 1.0e-6
4767
4768 /**
4769 * gretl_cholesky_decomp_solve:
4770 * @a: symmetric positive-definite matrix.
4771 * @b: vector 'x' on input, solution 'b' on output.
4772 *
4773 * Solves ax = b for the unknown vector x, using Cholesky decomposition
4774 * via the LAPACK functions dpotrf() and dpotrs().
4775 *
4776 * On exit, @b is replaced by the solution and @a is replaced by its
4777 * Cholesky decomposition.
4778 *
4779 * Returns: 0 on successful completion, or non-zero code on error.
4780 */
4781
gretl_cholesky_decomp_solve(gretl_matrix * a,gretl_matrix * b)4782 int gretl_cholesky_decomp_solve (gretl_matrix *a, gretl_matrix *b)
4783 {
4784 integer n, m, info = 0;
4785 double rcond;
4786 double *work = NULL;
4787 integer *iwork = NULL;
4788 char diag = 'N';
4789 char norm = '1';
4790 char uplo = 'L';
4791 int err = 0;
4792
4793 if (gretl_is_null_matrix(a) || gretl_is_null_matrix(b)) {
4794 return E_DATA;
4795 }
4796
4797 n = a->cols;
4798 m = b->cols;
4799
4800 dpotrf_(&uplo, &n, a->val, &n, &info);
4801 if (info != 0) {
4802 fprintf(stderr, "gretl_cholesky_decomp_solve: "
4803 "dpotrf failed with info = %d (n = %d)\n", (int) info, (int) n);
4804 err = (info > 0)? E_NOTPD : E_DATA;
4805 }
4806
4807 if (!err) {
4808 work = lapack_malloc(3 * n * sizeof *work);
4809 iwork = malloc(n * sizeof *iwork);
4810 if (work == NULL || iwork == NULL) {
4811 err = E_ALLOC;
4812 }
4813 }
4814
4815 if (!err) {
4816 dtrcon_(&norm, &uplo, &diag, &n, a->val, &n, &rcond, work, iwork, &info);
4817 if (rcond < CHOL_RCOND_MIN) {
4818 #if 0
4819 fprintf(stderr, "gretl_cholesky_decomp_solve: rcond = %g (info = %d)\n",
4820 rcond, (int) info);
4821 #endif
4822 err = E_SINGULAR;
4823 }
4824 }
4825
4826 if (!err) {
4827 dpotrs_(&uplo, &n, &m, a->val, &n, b->val, &n, &info);
4828 if (info != 0) {
4829 fprintf(stderr, "gretl_cholesky_decomp_solve:\n"
4830 " dpotrs failed with info = %d (n = %d)\n", (int) info, (int) n);
4831 err = E_SINGULAR;
4832 }
4833 }
4834
4835 lapack_free(work);
4836 free(iwork);
4837
4838 return err;
4839 }
4840
4841 /**
4842 * gretl_cholesky_solve:
4843 * @a: Cholesky-decomposed symmetric positive-definite matrix.
4844 * @b: vector 'x'.
4845 *
4846 * Solves ax = b for the unknown vector x, using the pre-computed
4847 * Cholesky decomposition of @a. On exit, @b is replaced by the
4848 * solution.
4849 *
4850 * Returns: 0 on successful completion, or non-zero code on error.
4851 */
4852
gretl_cholesky_solve(const gretl_matrix * a,gretl_vector * b)4853 int gretl_cholesky_solve (const gretl_matrix *a, gretl_vector *b)
4854 {
4855 integer n, info, one = 1;
4856 char uplo = 'L';
4857
4858 if (gretl_is_null_matrix(a) || gretl_is_null_matrix(b)) {
4859 return E_DATA;
4860 }
4861
4862 n = a->cols;
4863
4864 dpotrs_(&uplo, &n, &one, a->val, &n, b->val, &n, &info);
4865 if (info != 0) {
4866 fprintf(stderr, "gretl_cholesky_solve:\n"
4867 " dpotrs failed with info = %d (n = %d)\n", (int) info, (int) n);
4868 return E_SINGULAR;
4869 }
4870
4871 return 0;
4872 }
4873
4874 /**
4875 * gretl_cholesky_invert:
4876 * @a: Cholesky-decomposed symmetric positive-definite matrix.
4877 *
4878 * Inverts @a, which must contain the pre-computed Cholesky
4879 * decomposition of a p.d. matrix, as may be obtained using
4880 * gretl_cholesky_decomp_solve(). For speed there's no error
4881 * checking of the input -- the caller should make sure it's OK.
4882 *
4883 * Returns: 0 on successful completion, or non-zero code on error.
4884 */
4885
gretl_cholesky_invert(gretl_matrix * a)4886 int gretl_cholesky_invert (gretl_matrix *a)
4887 {
4888 integer info, n = a->cols;
4889 char uplo = 'L';
4890 int err = 0;
4891
4892 dpotri_(&uplo, &n, a->val, &n, &info);
4893
4894 if (info != 0) {
4895 err = E_SINGULAR;
4896 fprintf(stderr, "gretl_cholesky_invert:\n"
4897 " dpotri failed with info = %d\n", (int) info);
4898 } else {
4899 gretl_matrix_mirror(a, uplo);
4900 }
4901
4902 return err;
4903 }
4904
4905 /* translation to C of tsld1.f in the netlib toeplitz package,
4906 code as of 07/23/82; see http://www.netlib.org/toeplitz/
4907
4908 tsld1 solves the double precision linear system
4909 A * x = b for Toeplitz matrix A
4910
4911 on entry:
4912
4913 a1 double precision(m), the first row of A
4914
4915 a2 double precision(m - 1), the first column of A
4916 beginning with the second element
4917
4918 b double precision(m), the right hand side vector
4919
4920 c1 double precision(m - 1), workspace
4921
4922 c2 double precision(m - 1), workspace
4923
4924 m integer, order of the matrix A
4925
4926 (c1 and c2 are internalized below)
4927
4928 on exit:
4929
4930 x double precision(m), the solution vector
4931 */
4932
4933 #define TOEPLITZ_SMALL 1.0e-20
4934
tsld1(const double * a1,const double * a2,const double * b,double * x,int m)4935 static int tsld1 (const double *a1, const double *a2,
4936 const double *b, double *x, int m)
4937 {
4938 double r1, r2, r3, r5, r6;
4939 int n, i, n1;
4940 double *c1 = NULL;
4941 double *c2 = NULL;
4942
4943 if (fabs(a1[0]) < TOEPLITZ_SMALL) {
4944 return E_SINGULAR;
4945 }
4946
4947 /* solve the system with principal minor of order 1 */
4948
4949 r1 = a1[0];
4950
4951 x[0] = b[0] / r1;
4952 if (m == 1) {
4953 return 0;
4954 }
4955
4956 c1 = malloc((m-1) * sizeof *c1);
4957 c2 = malloc((m-1) * sizeof *c2);
4958
4959 if (c1 == NULL || c2 == NULL) {
4960 free(c1);
4961 free(c2);
4962 return E_ALLOC;
4963 }
4964
4965 r2 = 0.0;
4966
4967 /* recurrent process for solving the system for
4968 order = 2 to m */
4969
4970 for (n=1; n<m; n++) {
4971
4972 /* compute multiples of the first and last columns of
4973 the inverse of the principal minor of order n + 1
4974 */
4975 n1 = n - 1;
4976 r5 = a2[n1];
4977 r6 = a1[n];
4978 if (n > 1) {
4979 c1[n1] = r2;
4980 for (i=0; i<n1; i++) {
4981 r5 += a2[i] * c1[n1-i];
4982 r6 += a1[i+1] * c2[i];
4983 }
4984 }
4985
4986 r2 = -r5 / r1;
4987 r3 = -r6 / r1;
4988 r1 += r5 * r3;
4989
4990 if (fabs(r1) < TOEPLITZ_SMALL) {
4991 free(c1);
4992 free(c2);
4993 return E_SINGULAR;
4994 }
4995
4996 if (n > 1) {
4997 r6 = c2[0];
4998 c2[n1] = 0.0;
4999 for (i=1; i<n; i++) {
5000 r5 = c2[i];
5001 c2[i] = c1[i] * r3 + r6;
5002 c1[i] += r6 * r2;
5003 r6 = r5;
5004 }
5005 }
5006 c2[0] = r3;
5007
5008 /* compute the solution of the system with
5009 principal minor of order n + 1 */
5010 r5 = 0.0;
5011 for (i=0; i<n; i++) {
5012 r5 += a2[i] * x[n1-i];
5013 }
5014 r6 = (b[n] - r5) / r1;
5015 for (i=0; i<n; i++) {
5016 x[i] += c2[i] * r6;
5017 }
5018 x[n] = r6;
5019 }
5020
5021 free(c1);
5022 free(c2);
5023
5024 return 0;
5025 }
5026
5027 /**
5028 * gretl_toeplitz_solve:
5029 * @c: Toeplitz column.
5030 * @r: Toeplitz row.
5031 * @b: right-hand side vector.
5032 * @err: error code.
5033 *
5034 * Solves Tx = b for the unknown vector x, where T is a Toeplitz
5035 * matrix, that is (zero-based)
5036 *
5037 * T_{ij} = c_{i-j} for i <= j
5038 * T_{ij} = r_{i-j} for i > j
5039 *
5040 * Note that c[0] should equal r[0].
5041 *
5042 * Returns: a newly allocated vector, containing the solution, x.
5043 */
5044
gretl_toeplitz_solve(const gretl_vector * c,const gretl_vector * r,const gretl_vector * b,int * err)5045 gretl_vector *gretl_toeplitz_solve (const gretl_vector *c,
5046 const gretl_vector *r,
5047 const gretl_vector *b,
5048 int *err)
5049 {
5050 int m = gretl_vector_get_length(c);
5051 gretl_matrix *y = NULL;
5052
5053 if (gretl_is_complex(c) || gretl_is_complex(r) ||
5054 gretl_is_complex(b)) {
5055 fprintf(stderr, "E_CMPLX in gretl_toeplitz_solve\n");
5056 *err = E_CMPLX;
5057 return NULL;
5058 }
5059
5060 /* a few sanity checks */
5061
5062 if (m == 0 ||
5063 m != gretl_vector_get_length(r) ||
5064 m != gretl_vector_get_length(b)) {
5065 *err = E_NONCONF;
5066 return NULL;
5067 }
5068
5069 if (r->val[0] != c->val[0]) {
5070 *err = E_DATA;
5071 return NULL;
5072 }
5073
5074 y = gretl_column_vector_alloc(m);
5075
5076 if (y == NULL) {
5077 *err = E_ALLOC;
5078 } else {
5079 /* invoke gretlized netlib routine */
5080 *err = tsld1(r->val, c->val + 1, b->val, y->val, m);
5081 if (*err) {
5082 gretl_matrix_free(y);
5083 y = NULL;
5084 }
5085 }
5086
5087 return y;
5088 }
5089
5090 #define gretl_matrix_cum(m,i,j,x) (m->val[(j)*m->rows+(i)]+=x)
5091
5092 #define BLAS_DEBUG 0
5093
5094 /* FIXME set this to a positive value under OS X on Intel,
5095 to take advantage of VecLib?
5096 */
5097
5098 static int blas_mnk_min = -1;
5099
5100 /**
5101 * set_blas_mnk_min:
5102 * @mnk: value to set.
5103 *
5104 * By default all matrix multiplication within libgretl is
5105 * done using native code, but there is the possibility of
5106 * farming out multiplication to the BLAS.
5107 *
5108 * When multiplying an m x n matrix into an n x k matrix
5109 * libgretl finds the product of the dimensions, m*n*k,
5110 * and compares this with an internal threshhold variable,
5111 * blas_mnk_min. If and only if blas_mnk_min >= 0 and
5112 * n*m*k >= blas_mnk_min, then we use the BLAS. By default
5113 * blas_mnk_min is set to -1 (BLAS never used).
5114 *
5115 * If you have an optimized version of the BLAS you may want
5116 * to set blas_mnk_min to some suitable positive value. (Setting
5117 * it to 0 would result in external calls to the BLAS for all
5118 * matrix multiplications, however small, which is unlikely
5119 * to be optimal.)
5120 */
5121
set_blas_mnk_min(int mnk)5122 void set_blas_mnk_min (int mnk)
5123 {
5124 blas_mnk_min = mnk;
5125 }
5126
5127 /**
5128 * get_blas_mnk_min:
5129 *
5130 * Returns: the value of the internal variable blas_mnk_min.
5131 * See set_blas_mnk_min().
5132 */
5133
get_blas_mnk_min(void)5134 int get_blas_mnk_min (void)
5135 {
5136 return blas_mnk_min;
5137 }
5138
use_blas(int m,int n,int k)5139 static int use_blas (int m, int n, int k)
5140 {
5141 #if BLAS_DEBUG
5142 fprintf(stderr, "use_blas ? mnk_min = %d\n", blas_mnk_min);
5143 #endif
5144 if (blas_mnk_min >= 0) {
5145 guint64 mnk = (guint64) m * n * k;
5146
5147 #if BLAS_DEBUG
5148 fprintf(stderr, " and mnk = %g\n", mnk);
5149 #endif
5150 return mnk >= (guint64) blas_mnk_min;
5151 } else {
5152 return 0;
5153 }
5154 }
5155
gretl_blas_dsyrk(const gretl_matrix * a,int atr,gretl_matrix * c,GretlMatrixMod cmod)5156 static void gretl_blas_dsyrk (const gretl_matrix *a, int atr,
5157 gretl_matrix *c, GretlMatrixMod cmod)
5158 {
5159 char uplo = 'U';
5160 char tr = (atr)? 'T' : 'N';
5161 integer n = c->rows;
5162 integer k = (atr)? a->rows : a->cols;
5163 integer lda = a->rows;
5164 double x, alpha = 1.0, beta = 0.0;
5165 #if defined(_OPENMP)
5166 guint64 fpm;
5167 #endif
5168 int i, j;
5169
5170 if (cmod == GRETL_MOD_CUMULATE) {
5171 beta = 1.0;
5172 } else if (cmod == GRETL_MOD_DECREMENT) {
5173 alpha = -1.0;
5174 beta = 1.0;
5175 }
5176
5177 dsyrk_(&uplo, &tr, &n, &k, &alpha, a->val, &lda,
5178 &beta, c->val, &n);
5179
5180 #if defined(_OPENMP)
5181 fpm = (guint64) n * n;
5182 if (!gretl_use_openmp(fpm)) {
5183 goto st_mode;
5184 }
5185 #pragma omp parallel for private(i, j, x)
5186 for (i=0; i<n; i++) {
5187 for (j=i+1; j<n; j++) {
5188 x = gretl_matrix_get(c, i, j);
5189 gretl_matrix_set(c, j, i, x);
5190 }
5191 }
5192 return;
5193
5194 st_mode:
5195 #endif
5196
5197 for (i=0; i<n; i++) {
5198 for (j=i+1; j<n; j++) {
5199 x = gretl_matrix_get(c, i, j);
5200 gretl_matrix_set(c, j, i, x);
5201 }
5202 }
5203 }
5204
5205 #define gretl_st_result(c,i,j,x,m) \
5206 do { \
5207 if (m==GRETL_MOD_CUMULATE) { \
5208 c->val[(j)*c->rows+(i)]+=x; \
5209 if (i!=j) c->val[(i)*c->rows+(j)]+=x; \
5210 } else if (m==GRETL_MOD_DECREMENT) { \
5211 c->val[(j)*c->rows+(i)]-=x; \
5212 if (i!=j) c->val[(i)*c->rows+(j)]-=x; \
5213 } else { \
5214 gretl_matrix_set(c,i,j,x); \
5215 gretl_matrix_set(c,j,i,x); \
5216 } \
5217 } while (0);
5218
5219
5220 static int
matrix_multiply_self_transpose(const gretl_matrix * a,int atr,gretl_matrix * c,GretlMatrixMod cmod)5221 matrix_multiply_self_transpose (const gretl_matrix *a, int atr,
5222 gretl_matrix *c, GretlMatrixMod cmod)
5223 {
5224 register int i, j, k;
5225 int nc = (atr)? a->cols : a->rows;
5226 int nr = (atr)? a->rows : a->cols;
5227 int idx1, idx2;
5228 #if defined(_OPENMP)
5229 guint64 fpm;
5230 #endif
5231 double x;
5232
5233 if (c->rows != nc) {
5234 return E_NONCONF;
5235 }
5236
5237 if (use_blas(nc, nc, nr)) {
5238 gretl_blas_dsyrk(a, atr, c, cmod);
5239 return 0;
5240 }
5241
5242 if (c->rows == 1) {
5243 k = a->cols * a->rows;
5244 if (cmod != GRETL_MOD_CUMULATE) {
5245 c->val[0] = 0.0;
5246 }
5247 for (i=0; i<k; i++) {
5248 c->val[0] += a->val[i] * a->val[i];
5249 }
5250 return 0;
5251 }
5252
5253 #if defined(_OPENMP)
5254 fpm = (guint64) nc * nc * nr;
5255 if (!gretl_use_openmp(fpm)) {
5256 goto st_mode;
5257 }
5258
5259 if (atr) {
5260 #pragma omp parallel for private(i, j, k, idx1, idx2, x)
5261 for (i=0; i<nc; i++) {
5262 for (j=i; j<nc; j++) {
5263 idx1 = i * a->rows;
5264 idx2 = j * a->rows;
5265 x = 0.0;
5266 for (k=0; k<nr; k++) {
5267 x += a->val[idx1++] * a->val[idx2++];
5268 }
5269 gretl_st_result(c,i,j,x,cmod);
5270 }
5271 }
5272 } else {
5273 #pragma omp parallel for private(i, j, k, idx1, idx2, x)
5274 for (i=0; i<nc; i++) {
5275 for (j=i; j<nc; j++) {
5276 idx1 = i;
5277 idx2 = j;
5278 x = 0.0;
5279 for (k=0; k<nr; k++) {
5280 x += a->val[idx1] * a->val[idx2];
5281 idx1 += a->rows;
5282 idx2 += a->rows;
5283 }
5284 gretl_st_result(c,i,j,x,cmod);
5285 }
5286 }
5287 }
5288
5289 return 0;
5290
5291 st_mode:
5292
5293 #endif /* _OPENMP */
5294
5295 if (atr) {
5296 for (i=0; i<nc; i++) {
5297 for (j=i; j<nc; j++) {
5298 idx1 = i * a->rows;
5299 idx2 = j * a->rows;
5300 x = 0.0;
5301 for (k=0; k<nr; k++) {
5302 x += a->val[idx1++] * a->val[idx2++];
5303 }
5304 gretl_st_result(c,i,j,x,cmod);
5305 }
5306 }
5307 } else {
5308 for (i=0; i<nc; i++) {
5309 for (j=i; j<nc; j++) {
5310 idx1 = i;
5311 idx2 = j;
5312 x = 0.0;
5313 for (k=0; k<nr; k++) {
5314 x += a->val[idx1] * a->val[idx2];
5315 idx1 += a->rows;
5316 idx2 += a->rows;
5317 }
5318 gretl_st_result(c,i,j,x,cmod);
5319 }
5320 }
5321 }
5322
5323 return 0;
5324 }
5325
5326 static int
matrix_multiply_self_transpose_single(const gretl_matrix * a,int atr,gretl_matrix * c,GretlMatrixMod cmod)5327 matrix_multiply_self_transpose_single (const gretl_matrix *a,
5328 int atr,
5329 gretl_matrix *c,
5330 GretlMatrixMod cmod)
5331 {
5332 register int i, j, k;
5333 int nc = (atr)? a->cols : a->rows;
5334 int nr = (atr)? a->rows : a->cols;
5335 int idx1, idx2;
5336 double x;
5337
5338 if (c->rows != nc) {
5339 return E_NONCONF;
5340 }
5341
5342 if (c->rows == 1) {
5343 k = a->cols * a->rows;
5344 if (cmod != GRETL_MOD_CUMULATE) {
5345 c->val[0] = 0.0;
5346 }
5347 for (i=0; i<k; i++) {
5348 c->val[0] += a->val[i] * a->val[i];
5349 }
5350 return 0;
5351 }
5352
5353 if (atr) {
5354 for (i=0; i<nc; i++) {
5355 for (j=i; j<nc; j++) {
5356 idx1 = i * a->rows;
5357 idx2 = j * a->rows;
5358 x = 0.0;
5359 for (k=0; k<nr; k++) {
5360 x += a->val[idx1++] * a->val[idx2++];
5361 }
5362 gretl_st_result(c,i,j,x,cmod);
5363 }
5364 }
5365 } else {
5366 for (i=0; i<nc; i++) {
5367 for (j=i; j<nc; j++) {
5368 idx1 = i;
5369 idx2 = j;
5370 x = 0.0;
5371 for (k=0; k<nr; k++) {
5372 x += a->val[idx1] * a->val[idx2];
5373 idx1 += a->rows;
5374 idx2 += a->rows;
5375 }
5376 gretl_st_result(c,i,j,x,cmod);
5377 }
5378 }
5379 }
5380
5381 return 0;
5382 }
5383
5384 /**
5385 * gretl_matrix_XTX_new:
5386 * @X: matrix to process.
5387 *
5388 * Returns: a newly allocated matrix containing X'X, or
5389 * NULL on error.
5390 */
5391
gretl_matrix_XTX_new(const gretl_matrix * X)5392 gretl_matrix *gretl_matrix_XTX_new (const gretl_matrix *X)
5393 {
5394 gretl_matrix *XTX = NULL;
5395
5396 if (!gretl_is_null_matrix(X)) {
5397 XTX = gretl_matrix_alloc(X->cols, X->cols);
5398 }
5399
5400 if (XTX != NULL) {
5401 matrix_multiply_self_transpose(X, 1, XTX, GRETL_MOD_NONE);
5402 }
5403
5404 maybe_preserve_names(XTX, X, COLNAMES, NULL);
5405
5406 return XTX;
5407 }
5408
5409 /**
5410 * gretl_matrix_packed_XTX_new:
5411 * @X: matrix to process.
5412 * @nasty: location to receive warning if any diagonal element
5413 * is less than %DBL_EPSILON.
5414 *
5415 * Performs the multiplication X'X producing a packed result,
5416 * that is, the vech() of the full solution.
5417 *
5418 * Returns: a newly allocated column vector containing the
5419 * unique elements of X'X, or NULL on error.
5420 */
5421
gretl_matrix_packed_XTX_new(const gretl_matrix * X,int * nasty)5422 static gretl_matrix *gretl_matrix_packed_XTX_new (const gretl_matrix *X,
5423 int *nasty)
5424 {
5425 gretl_matrix *XTX = NULL;
5426 double x;
5427 #if defined(_OPENMP)
5428 int ii;
5429 guint64 fpm;
5430 #endif
5431 int i, j, k, nc, nr, n;
5432
5433 if (gretl_is_null_matrix(X)) {
5434 return NULL;
5435 }
5436
5437 nc = X->cols;
5438 nr = X->rows;
5439 n = (nc * nc + nc) / 2;
5440 XTX = gretl_matrix_alloc(n, 1);
5441
5442 if (XTX == NULL) {
5443 return NULL;
5444 }
5445
5446 #if defined(_OPENMP)
5447 fpm = (guint64) n * nr;
5448 if (!gretl_use_openmp(fpm)) {
5449 goto st_mode;
5450 }
5451 #pragma omp parallel for private(i, j, k, ii, x)
5452 for (i=0; i<nc; i++) {
5453 for (j=i; j<nc; j++) {
5454 ii = ijton(i,j, nc);
5455 x = 0.0;
5456 for (k=0; k<nr; k++) {
5457 x += X->val[i*nr+k] * X->val[j*nr+k];
5458 }
5459 if (i == j && x < DBL_EPSILON) {
5460 *nasty = 1;
5461 }
5462 XTX->val[ii] = x;
5463 }
5464 }
5465 return XTX;
5466
5467 st_mode:
5468 #endif
5469
5470 n = 0;
5471 for (i=0; i<nc; i++) {
5472 for (j=i; j<nc; j++) {
5473 x = 0.0;
5474 for (k=0; k<nr; k++) {
5475 x += X->val[i*nr+k] * X->val[j*nr+k];
5476 }
5477 if (i == j && x < DBL_EPSILON) {
5478 *nasty = 1;
5479 }
5480 XTX->val[n++] = x;
5481 }
5482 }
5483
5484 return XTX;
5485 }
5486
gretl_blas_dgemm(const gretl_matrix * a,int atr,const gretl_matrix * b,int btr,gretl_matrix * c,GretlMatrixMod cmod,int m,int n,int k)5487 static void gretl_blas_dgemm (const gretl_matrix *a, int atr,
5488 const gretl_matrix *b, int btr,
5489 gretl_matrix *c, GretlMatrixMod cmod,
5490 int m, int n, int k)
5491 {
5492 char TransA = (atr)? 'T' : 'N';
5493 char TransB = (btr)? 'T' : 'N';
5494 double alpha = 1.0, beta = 0.0;
5495
5496 if (cmod == GRETL_MOD_CUMULATE) {
5497 beta = 1.0;
5498 } else if (cmod == GRETL_MOD_DECREMENT) {
5499 alpha = -1.0;
5500 beta = 1.0;
5501 }
5502
5503 dgemm_(&TransA, &TransB, &m, &n, &k,
5504 &alpha, a->val, &a->rows, b->val, &b->rows, &beta,
5505 c->val, &c->rows);
5506 }
5507
5508 /* below: a native C re-write of netlib BLAS dgemm.f: note that
5509 for gretl's purposes we do not support values of 'beta'
5510 other than 0 or 1 */
5511
gretl_dgemm(const gretl_matrix * a,int atr,const gretl_matrix * b,int btr,gretl_matrix * c,GretlMatrixMod cmod,int m,int n,int k)5512 static void gretl_dgemm (const gretl_matrix *a, int atr,
5513 const gretl_matrix *b, int btr,
5514 gretl_matrix *c, GretlMatrixMod cmod,
5515 int m, int n, int k)
5516 {
5517 const double * restrict A = a->val;
5518 const double * restrict B = b->val;
5519 double * restrict C = c->val;
5520 double x, alpha = 1.0;
5521 int beta = 0;
5522 int ar = a->rows;
5523 int br = b->rows;
5524 int cr = c->rows;
5525 #if defined(_OPENMP)
5526 guint64 fpm;
5527 #endif
5528 int i, j, l;
5529
5530 if (cmod == GRETL_MOD_CUMULATE) {
5531 beta = 1;
5532 } else if (cmod == GRETL_MOD_DECREMENT) {
5533 alpha = -1.0;
5534 beta = 1;
5535 }
5536
5537 #if defined(_OPENMP)
5538 fpm = (guint64) m * n * k;
5539 if (!gretl_use_openmp(fpm)) {
5540 goto st_mode;
5541 }
5542
5543 if (!btr) {
5544 if (!atr) {
5545 /* C := alpha*A*B + beta*C */
5546 #pragma omp parallel for private(j, i, l, x)
5547 for (j=0; j<n; j++) {
5548 if (beta == 0) {
5549 for (i=0; i<m; i++) {
5550 C[j*cr+i] = 0.0;
5551 }
5552 }
5553 for (l=0; l<k; l++) {
5554 if (B[j*br+l] != 0.0) {
5555 x = alpha * B[j*br+l];
5556 for (i=0; i<m; i++) {
5557 C[j*cr+i] += x * A[l*ar+i];
5558 }
5559 }
5560 }
5561 }
5562 } else {
5563 /* C := alpha*A'*B + beta*C */
5564 #pragma omp parallel for private(j, i, l, x)
5565 for (j=0; j<n; j++) {
5566 for (i=0; i<m; i++) {
5567 x = 0.0;
5568 for (l=0; l<k; l++) {
5569 x += A[i*ar+l] * B[j*br+l];
5570 }
5571 if (beta == 0) {
5572 C[j*cr+i] = alpha * x;
5573 } else {
5574 C[j*cr+i] += alpha * x;
5575 }
5576 }
5577 }
5578 }
5579 } else {
5580 if (!atr) {
5581 /* C := alpha*A*B' + beta*C */
5582 #pragma omp parallel for private(j, i, l, x)
5583 for (j=0; j<n; j++) {
5584 if (beta == 0) {
5585 for (i=0; i<m; i++) {
5586 C[j*cr+i] = 0.0;
5587 }
5588 }
5589 for (l=0; l<k; l++) {
5590 if (B[l*br+j] != 0.0) {
5591 x = alpha * B[l*br+j];
5592 for (i=0; i<m; i++) {
5593 C[j*cr+i] += x * A[l*ar+i];
5594 }
5595 }
5596 }
5597 }
5598 } else {
5599 /* C := alpha*A'*B' + beta*C */
5600 #pragma omp parallel for private(j, i, l, x)
5601 for (j=0; j<n; j++) {
5602 for (i=0; i<m; i++) {
5603 x = 0.0;
5604 for (l=0; l<k; l++) {
5605 x += A[i*ar+l] * B[l*br+j];
5606 }
5607 if (beta == 0) {
5608 C[j*cr+i] = alpha * x;
5609 } else {
5610 C[j*cr+i] += alpha * x;
5611 }
5612 }
5613 }
5614 }
5615 }
5616
5617 return;
5618
5619 st_mode:
5620
5621 #endif /* _OPENMP */
5622
5623 #if defined(USE_SIMD)
5624 if (k <= simd_k_max && !atr && !btr && !cmod) {
5625 gretl_matrix_simd_mul(a, b, c);
5626 return;
5627 }
5628 #endif
5629
5630 if (!btr) {
5631 if (!atr) {
5632 /* C := alpha*A*B + beta*C */
5633 for (j=0; j<n; j++) {
5634 if (beta == 0) {
5635 for (i=0; i<m; i++) {
5636 C[j*cr+i] = 0.0;
5637 }
5638 }
5639 for (l=0; l<k; l++) {
5640 if (B[j*br+l] != 0.0) {
5641 x = alpha * B[j*br+l];
5642 for (i=0; i<m; i++) {
5643 C[j*cr+i] += x * A[l*ar+i];
5644 }
5645 }
5646 }
5647 }
5648 } else {
5649 /* C := alpha*A'*B + beta*C */
5650 for (j=0; j<n; j++) {
5651 for (i=0; i<m; i++) {
5652 x = 0.0;
5653 for (l=0; l<k; l++) {
5654 x += A[i*ar+l] * B[j*br+l];
5655 }
5656 if (beta == 0) {
5657 C[j*cr+i] = alpha * x;
5658 } else {
5659 C[j*cr+i] += alpha * x;
5660 }
5661 }
5662 }
5663 }
5664 } else {
5665 if (!atr) {
5666 /* C := alpha*A*B' + beta*C */
5667 for (j=0; j<n; j++) {
5668 if (beta == 0) {
5669 for (i=0; i<m; i++) {
5670 C[j*cr+i] = 0.0;
5671 }
5672 }
5673 for (l=0; l<k; l++) {
5674 if (B[l*br+j] != 0.0) {
5675 x = alpha * B[l*br+j];
5676 for (i=0; i<m; i++) {
5677 C[j*cr+i] += x * A[l*ar+i];
5678 }
5679 }
5680 }
5681 }
5682 } else {
5683 /* C := alpha*A'*B' + beta*C */
5684 for (j=0; j<n; j++) {
5685 for (i=0; i<m; i++) {
5686 x = 0.0;
5687 for (l=0; l<k; l++) {
5688 x += A[i*ar+l] * B[l*br+j];
5689 }
5690 if (beta == 0) {
5691 C[j*cr+i] = alpha * x;
5692 } else {
5693 C[j*cr+i] += alpha * x;
5694 }
5695 }
5696 }
5697 }
5698 }
5699 }
5700
5701 /* non-threaded version of gretl_dgemm() */
5702
gretl_dgemm_single(const gretl_matrix * a,int atr,const gretl_matrix * b,int btr,gretl_matrix * c,GretlMatrixMod cmod,int m,int n,int k)5703 static void gretl_dgemm_single (const gretl_matrix *a, int atr,
5704 const gretl_matrix *b, int btr,
5705 gretl_matrix *c, GretlMatrixMod cmod,
5706 int m, int n, int k)
5707 {
5708 const double *A = a->val;
5709 const double *B = b->val;
5710 double *C = c->val;
5711 double x, alpha = 1.0;
5712 int beta = 0;
5713 int ar = a->rows;
5714 int br = b->rows;
5715 int cr = c->rows;
5716 int i, j, l;
5717
5718 if (cmod == GRETL_MOD_CUMULATE) {
5719 beta = 1;
5720 } else if (cmod == GRETL_MOD_DECREMENT) {
5721 alpha = -1.0;
5722 beta = 1;
5723 }
5724
5725 #if defined(USE_SIMD)
5726 if (k <= simd_k_max && !atr && !btr && !cmod) {
5727 gretl_matrix_simd_mul(a, b, c);
5728 return;
5729 }
5730 #endif
5731
5732 if (!btr) {
5733 if (!atr) {
5734 /* C := alpha*A*B + beta*C */
5735 for (j=0; j<n; j++) {
5736 if (beta == 0) {
5737 for (i=0; i<m; i++) {
5738 C[j*cr+i] = 0.0;
5739 }
5740 }
5741 for (l=0; l<k; l++) {
5742 if (B[j*br+l] != 0.0) {
5743 x = alpha * B[j*br+l];
5744 for (i=0; i<m; i++) {
5745 C[j*cr+i] += x * A[l*ar+i];
5746 }
5747 }
5748 }
5749 }
5750 } else {
5751 /* C := alpha*A'*B + beta*C */
5752 for (j=0; j<n; j++) {
5753 for (i=0; i<m; i++) {
5754 x = 0.0;
5755 for (l=0; l<k; l++) {
5756 x += A[i*ar+l] * B[j*br+l];
5757 }
5758 if (beta == 0) {
5759 C[j*cr+i] = alpha * x;
5760 } else {
5761 C[j*cr+i] += alpha * x;
5762 }
5763 }
5764 }
5765 }
5766 } else {
5767 if (!atr) {
5768 /* C := alpha*A*B' + beta*C */
5769 for (j=0; j<n; j++) {
5770 if (beta == 0) {
5771 for (i=0; i<m; i++) {
5772 C[j*cr+i] = 0.0;
5773 }
5774 }
5775 for (l=0; l<k; l++) {
5776 if (B[l*br+j] != 0.0) {
5777 x = alpha * B[l*br+j];
5778 for (i=0; i<m; i++) {
5779 C[j*cr+i] += x * A[l*ar+i];
5780 }
5781 }
5782 }
5783 }
5784 } else {
5785 /* C := alpha*A'*B' + beta*C */
5786 for (j=0; j<n; j++) {
5787 for (i=0; i<m; i++) {
5788 x = 0.0;
5789 for (l=0; l<k; l++) {
5790 x += A[i*ar+l] * B[l*br+j];
5791 }
5792 if (beta == 0) {
5793 C[j*cr+i] = alpha * x;
5794 } else {
5795 C[j*cr+i] += alpha * x;
5796 }
5797 }
5798 }
5799 }
5800 }
5801 }
5802
5803 static int
matmul_mod_w_scalar(double x,const gretl_matrix * m,int mtr,gretl_matrix * c,GretlMatrixMod cmod)5804 matmul_mod_w_scalar (double x, const gretl_matrix *m, int mtr,
5805 gretl_matrix *c, GretlMatrixMod cmod)
5806 {
5807 int cr = mtr ? m->cols : m->rows;
5808 int cc = mtr ? m->rows : m->cols;
5809
5810 if (c->rows != cr || c->cols != cc) {
5811 return E_NONCONF;
5812 }
5813
5814 if (mtr) {
5815 double xm, cij;
5816 int i, j, k = 0;
5817
5818 for (i=0; i<cr; i++) {
5819 for (j=0; j<cc; j++) {
5820 xm = x * m->val[k++];
5821 if (cmod == GRETL_MOD_CUMULATE) {
5822 cij = gretl_matrix_get(c, i, j) + xm;
5823 } else if (cmod == GRETL_MOD_DECREMENT) {
5824 cij = gretl_matrix_get(c, i, j) - xm;
5825 } else {
5826 cij = xm;
5827 }
5828 gretl_matrix_set(c, i, j, cij);
5829 }
5830 }
5831 } else {
5832 double xm;
5833 int i, n = cr * cc;
5834
5835 for (i=0; i<n; i++) {
5836 xm = x * m->val[i];
5837 if (cmod == GRETL_MOD_CUMULATE) {
5838 c->val[i] += xm;
5839 } else if (cmod == GRETL_MOD_DECREMENT) {
5840 c->val[i] -= xm;
5841 } else {
5842 c->val[i] = xm;
5843 }
5844 }
5845 }
5846
5847 return 0;
5848 }
5849
5850 /**
5851 * gretl_matrix_multiply_mod:
5852 * @a: left-hand matrix.
5853 * @amod: modifier: %GRETL_MOD_NONE or %GRETL_MOD_TRANSPOSE.
5854 * @b: right-hand matrix.
5855 * @bmod: modifier: %GRETL_MOD_NONE or %GRETL_MOD_TRANSPOSE.
5856 * @c: matrix to hold the product.
5857 * @cmod: modifier: %GRETL_MOD_NONE or %GRETL_MOD_CUMULATE to
5858 * add the result to the existing value of @c, or
5859 * %GRETL_MOD_DECREMENT to subtract from the existing value
5860 * of @c.
5861 *
5862 * Multiplies @a (or a-transpose) into @b (or b transpose),
5863 * with the result written into @c.
5864 *
5865 * Returns: 0 on success; non-zero error code on
5866 * failure.
5867 */
5868
gretl_matrix_multiply_mod(const gretl_matrix * a,GretlMatrixMod amod,const gretl_matrix * b,GretlMatrixMod bmod,gretl_matrix * c,GretlMatrixMod cmod)5869 int gretl_matrix_multiply_mod (const gretl_matrix *a, GretlMatrixMod amod,
5870 const gretl_matrix *b, GretlMatrixMod bmod,
5871 gretl_matrix *c, GretlMatrixMod cmod)
5872 {
5873 const int atr = (amod == GRETL_MOD_TRANSPOSE);
5874 const int btr = (bmod == GRETL_MOD_TRANSPOSE);
5875 int lrows, lcols;
5876 int rrows, rcols;
5877
5878 if (gretl_is_null_matrix(a) ||
5879 gretl_is_null_matrix(b) ||
5880 gretl_is_null_matrix(c)) {
5881 return E_DATA;
5882 }
5883
5884 if (a == c || b == c) {
5885 fputs("gretl_matrix_multiply:\n product matrix must be "
5886 "distinct from both input matrices\n", stderr);
5887 fprintf(stderr, "a = %p, b = %p, c = %p\n",
5888 (void *) a, (void *) b, (void *) c);
5889 return 1;
5890 }
5891
5892 if (a == b && atr != btr && c->rows == c->cols) {
5893 return matrix_multiply_self_transpose(a, atr, c, cmod);
5894 }
5895
5896 if (a->rows == 1 && a->cols == 1) {
5897 return matmul_mod_w_scalar(a->val[0], b, btr, c, cmod);
5898 } else if (b->rows == 1 && b->cols == 1) {
5899 return matmul_mod_w_scalar(b->val[0], a, atr, c, cmod);
5900 }
5901
5902 lrows = (atr)? a->cols : a->rows;
5903 lcols = (atr)? a->rows : a->cols;
5904 rrows = (btr)? b->cols : b->rows;
5905 rcols = (btr)? b->rows : b->cols;
5906
5907 if (lcols != rrows) {
5908 fputs("gretl_matrix_multiply_mod: matrices not conformable\n", stderr);
5909 fprintf(stderr, " Requested (%d x %d) * (%d x %d) = (%d x %d)\n",
5910 lrows, lcols, rrows, rcols, c->rows, c->cols);
5911 return E_NONCONF;
5912 }
5913
5914 if (c->rows != lrows || c->cols != rcols) {
5915 fputs("gretl_matrix_multiply_mod: matrices not conformable\n", stderr);
5916 fprintf(stderr, " Requested (%d x %d) * (%d x %d) = (%d x %d)\n",
5917 lrows, lcols, rrows, rcols, c->rows, c->cols);
5918 return E_NONCONF;
5919 }
5920
5921 if (use_blas(lrows, rcols, lcols)) {
5922 gretl_blas_dgemm(a, atr, b, btr, c, cmod, lrows, rcols, lcols);
5923 } else {
5924 gretl_dgemm(a, atr, b, btr, c, cmod, lrows, rcols, lcols);
5925 }
5926
5927 return 0;
5928 }
5929
5930 /* single-threaded version of gretl_matrix_multiply_mod()
5931 for use when we're performing some larger task under
5932 OMP.
5933 */
5934
gretl_matrix_multiply_mod_single(const gretl_matrix * a,GretlMatrixMod amod,const gretl_matrix * b,GretlMatrixMod bmod,gretl_matrix * c,GretlMatrixMod cmod)5935 int gretl_matrix_multiply_mod_single (const gretl_matrix *a,
5936 GretlMatrixMod amod,
5937 const gretl_matrix *b,
5938 GretlMatrixMod bmod,
5939 gretl_matrix *c,
5940 GretlMatrixMod cmod)
5941 {
5942 const int atr = (amod == GRETL_MOD_TRANSPOSE);
5943 const int btr = (bmod == GRETL_MOD_TRANSPOSE);
5944 int lrows, lcols;
5945 int rrows, rcols;
5946
5947 if (gretl_is_null_matrix(a) ||
5948 gretl_is_null_matrix(b) ||
5949 gretl_is_null_matrix(c)) {
5950 return E_DATA;
5951 }
5952
5953 if (a == c || b == c) {
5954 fputs("gretl_matrix_multiply:\n product matrix must be "
5955 "distinct from both input matrices\n", stderr);
5956 fprintf(stderr, "a = %p, b = %p, c = %p\n",
5957 (void *) a, (void *) b, (void *) c);
5958 return 1;
5959 }
5960
5961 if (a == b && atr != btr && c->rows == c->cols) {
5962 return matrix_multiply_self_transpose_single(a, atr, c, cmod);
5963 }
5964
5965 if (a->rows == 1 && a->cols == 1) {
5966 return matmul_mod_w_scalar(a->val[0], b, btr, c, cmod);
5967 } else if (b->rows == 1 && b->cols == 1) {
5968 return matmul_mod_w_scalar(b->val[0], a, atr, c, cmod);
5969 }
5970
5971 lrows = (atr)? a->cols : a->rows;
5972 lcols = (atr)? a->rows : a->cols;
5973 rrows = (btr)? b->cols : b->rows;
5974 rcols = (btr)? b->rows : b->cols;
5975
5976 if (lcols != rrows) {
5977 fputs("gretl_matrix_multiply_mod: matrices not conformable\n", stderr);
5978 fprintf(stderr, " Requested (%d x %d) * (%d x %d) = (%d x %d)\n",
5979 lrows, lcols, rrows, rcols, c->rows, c->cols);
5980 return E_NONCONF;
5981 }
5982
5983 if (c->rows != lrows || c->cols != rcols) {
5984 fputs("gretl_matrix_multiply_mod: matrices not conformable\n", stderr);
5985 fprintf(stderr, " Requested (%d x %d) * (%d x %d) = (%d x %d)\n",
5986 lrows, lcols, rrows, rcols, c->rows, c->cols);
5987 return E_NONCONF;
5988 }
5989
5990 gretl_dgemm_single(a, atr, b, btr, c, cmod, lrows, rcols, lcols);
5991
5992 return 0;
5993 }
5994
5995 /**
5996 * gretl_matrix_I_kronecker:
5997 * @p: dimension of left-hand identity matrix.
5998 * @B: right-hand matrix, r x s.
5999 * @K: target matrix, (p * r) x (p * s).
6000 *
6001 * Writes the Kronecker product of the identity matrix
6002 * of order @r and @B into @K.
6003 *
6004 * Returns: 0 on success, %E_NONCONF if matrix @K is
6005 * not correctly dimensioned for the operation.
6006 */
6007
6008 int
gretl_matrix_I_kronecker(int p,const gretl_matrix * B,gretl_matrix * K)6009 gretl_matrix_I_kronecker (int p, const gretl_matrix *B,
6010 gretl_matrix *K)
6011 {
6012 double x, aij, bkl;
6013 int r, s;
6014 int i, j, k, l;
6015 int ioff, joff;
6016 int Ki, Kj;
6017
6018 if (gretl_is_null_matrix(B)) {
6019 return E_DATA;
6020 }
6021
6022 r = B->rows;
6023 s = B->cols;
6024
6025 if (K->rows != p * r || K->cols != p * s) {
6026 return E_NONCONF;
6027 }
6028
6029 for (i=0; i<p; i++) {
6030 ioff = i * r;
6031 for (j=0; j<p; j++) {
6032 /* block ij is an r * s matrix, I_{ij} * B */
6033 aij = (i == j)? 1 : 0;
6034 joff = j * s;
6035 for (k=0; k<r; k++) {
6036 Ki = ioff + k;
6037 for (l=0; l<s; l++) {
6038 bkl = gretl_matrix_get(B, k, l);
6039 Kj = joff + l;
6040 x = aij * bkl;
6041 if (x == -0.0) {
6042 x = 0.0;
6043 }
6044 gretl_matrix_set(K, Ki, Kj, x);
6045 }
6046 }
6047 }
6048 }
6049
6050 return 0;
6051 }
6052
6053 /**
6054 * gretl_matrix_I_kronecker_new:
6055 * @p: dimension of left-hand identity matrix.
6056 * @B: right-hand matrix, r x s.
6057 * @err: location to receive error code.
6058 *
6059 * Writes the Kronecker product of the identity matrix
6060 * of order @r and @B into a newly allocated matrix.
6061 *
6062 * Returns: the new matrix, or NULL on failure.
6063 */
6064
6065 gretl_matrix *
gretl_matrix_I_kronecker_new(int p,const gretl_matrix * B,int * err)6066 gretl_matrix_I_kronecker_new (int p, const gretl_matrix *B, int *err)
6067 {
6068 gretl_matrix *K;
6069
6070 if (gretl_is_null_matrix(B)) {
6071 *err = E_DATA;
6072 return NULL;
6073 }
6074
6075 K = gretl_matrix_alloc(p * B->rows, p * B->cols);
6076
6077 if (K == NULL) {
6078 *err = E_ALLOC;
6079 } else {
6080 gretl_matrix_I_kronecker(p, B, K);
6081 }
6082
6083 return K;
6084 }
6085
6086 /**
6087 * gretl_matrix_kronecker_I:
6088 * @A: left-hand matrix, p x q.
6089 * @r: dimension of right-hand identity matrix.
6090 * @K: target matrix, (p * r) x (q * r).
6091 *
6092 * Writes the Kronecker product of @A and the identity
6093 * matrix of order @r into @K.
6094 *
6095 * Returns: 0 on success, %E_NONCONF if matrix @K is
6096 * not correctly dimensioned for the operation.
6097 */
6098
6099 int
gretl_matrix_kronecker_I(const gretl_matrix * A,int r,gretl_matrix * K)6100 gretl_matrix_kronecker_I (const gretl_matrix *A, int r,
6101 gretl_matrix *K)
6102 {
6103 double x, aij, bkl;
6104 int p, q;
6105 int i, j, k, l;
6106 int ioff, joff;
6107 int Ki, Kj;
6108
6109 if (gretl_is_null_matrix(A)) {
6110 return E_DATA;
6111 }
6112
6113 p = A->rows;
6114 q = A->cols;
6115
6116 if (K->rows != p * r || K->cols != q * r) {
6117 return E_NONCONF;
6118 }
6119
6120 for (i=0; i<p; i++) {
6121 ioff = i * r;
6122 for (j=0; j<q; j++) {
6123 /* block ij is an r * r matrix, a_{ij} * I_r */
6124 aij = gretl_matrix_get(A, i, j);
6125 joff = j * r;
6126 for (k=0; k<r; k++) {
6127 Ki = ioff + k;
6128 for (l=0; l<r; l++) {
6129 bkl = (k == l)? 1 : 0;
6130 Kj = joff + l;
6131 x = aij * bkl;
6132 if (x == -0.0) {
6133 x = 0.0;
6134 }
6135 gretl_matrix_set(K, Ki, Kj, x);
6136 }
6137 }
6138 }
6139 }
6140
6141 return 0;
6142 }
6143
6144 /**
6145 * gretl_matrix_kronecker_I_new:
6146 * @A: left-hand matrix, p x q.
6147 * @r: dimension of right-hand identity matrix.
6148 * @err: location to receive error code.
6149 *
6150 * Writes into a newl allocated matrix the Kronecker
6151 * product of @A and the identity matrix of order @r.
6152 *
6153 * Returns: the new matrix, or NULL on failure.
6154 */
6155
6156 gretl_matrix *
gretl_matrix_kronecker_I_new(const gretl_matrix * A,int r,int * err)6157 gretl_matrix_kronecker_I_new (const gretl_matrix *A, int r, int *err)
6158 {
6159 gretl_matrix *K;
6160
6161 if (gretl_is_null_matrix(A)) {
6162 *err = E_DATA;
6163 return NULL;
6164 }
6165
6166 K = gretl_matrix_alloc(A->rows * r, A->cols * r);
6167
6168 if (K == NULL) {
6169 *err = E_ALLOC;
6170 } else {
6171 gretl_matrix_kronecker_I(A, r, K);
6172 }
6173
6174 return K;
6175 }
6176
6177 /**
6178 * gretl_matrix_kronecker_product:
6179 * @A: left-hand matrix, p x q.
6180 * @B: right-hand matrix, r x s.
6181 * @K: target matrix, (p * r) x (q * s).
6182 *
6183 * Writes the Kronecker product of @A and @B into @K.
6184 *
6185 * Returns: 0 on success, %E_NONCONF if matrix @K is
6186 * not correctly dimensioned for the operation.
6187 */
6188
6189 int
gretl_matrix_kronecker_product(const gretl_matrix * A,const gretl_matrix * B,gretl_matrix * K)6190 gretl_matrix_kronecker_product (const gretl_matrix *A, const gretl_matrix *B,
6191 gretl_matrix *K)
6192 {
6193 double x, aij, bkl;
6194 int p, q, r, s;
6195 int i, j, k, l;
6196 int ioff, joff;
6197 int Ki, Kj;
6198
6199 if (gretl_is_null_matrix(A) ||
6200 gretl_is_null_matrix(B) ||
6201 gretl_is_null_matrix(K)) {
6202 return E_DATA;
6203 }
6204
6205 p = A->rows;
6206 q = A->cols;
6207 r = B->rows;
6208 s = B->cols;
6209
6210 if (K->rows != p * r || K->cols != q * s) {
6211 return E_NONCONF;
6212 }
6213
6214 for (i=0; i<p; i++) {
6215 ioff = i * r;
6216 for (j=0; j<q; j++) {
6217 /* block ij is an r * s matrix, a_{ij} * B */
6218 aij = gretl_matrix_get(A, i, j);
6219 joff = j * s;
6220 for (k=0; k<r; k++) {
6221 Ki = ioff + k;
6222 for (l=0; l<s; l++) {
6223 bkl = gretl_matrix_get(B, k, l);
6224 Kj = joff + l;
6225 x = aij * bkl;
6226 if (x == -0.0) {
6227 x = 0.0;
6228 }
6229 gretl_matrix_set(K, Ki, Kj, x);
6230 }
6231 }
6232 }
6233 }
6234
6235 return 0;
6236 }
6237
6238 /**
6239 * gretl_matrix_kronecker_product_new:
6240 * @A: left-hand matrix, p x q.
6241 * @B: right-hand matrix, r x s.
6242 * @err: location to receive error code.
6243 *
6244 * Returns: A newly allocated (p * r) x (q * s) matrix which
6245 * is the Kronecker product of matrices @A and @B, or NULL
6246 * on failure.
6247 */
6248
6249 gretl_matrix *
gretl_matrix_kronecker_product_new(const gretl_matrix * A,const gretl_matrix * B,int * err)6250 gretl_matrix_kronecker_product_new (const gretl_matrix *A,
6251 const gretl_matrix *B,
6252 int *err)
6253 {
6254 gretl_matrix *K;
6255 int p, q, r, s;
6256
6257 if (gretl_is_null_matrix(A) || gretl_is_null_matrix(B)) {
6258 *err = E_DATA;
6259 return NULL;
6260 }
6261
6262 p = A->rows;
6263 q = A->cols;
6264 r = B->rows;
6265 s = B->cols;
6266
6267 K = gretl_matrix_alloc(p * r, q * s);
6268
6269 if (K == NULL) {
6270 *err = E_ALLOC;
6271 } else {
6272 gretl_matrix_kronecker_product(A, B, K);
6273 }
6274
6275 return K;
6276 }
6277
6278 /**
6279 * gretl_matrix_hdproduct:
6280 * @A: left-hand matrix, r x p.
6281 * @B: right-hand matrix, r x q or NULL.
6282 * @C: target matrix, r x (p * q).
6283 *
6284 * Writes into @C the horizontal direct product of @A and @B.
6285 * That is, $C_i' = A_i' \otimes B_i'$ (in TeX notation). If @B
6286 * is NULL, then it's understood to be equal to @A.
6287 *
6288 * Returns: 0 on success, %E_NONCONF if @A and @B have different
6289 * numbers of rows or matrix @C is not correctly dimensioned for the
6290 * operation.
6291 */
6292
gretl_matrix_hdproduct(const gretl_matrix * A,const gretl_matrix * B,gretl_matrix * C)6293 int gretl_matrix_hdproduct (const gretl_matrix *A,
6294 const gretl_matrix *B,
6295 gretl_matrix *C)
6296 {
6297 double aij, bik;
6298 int r, p, q;
6299 int i, j, k;
6300 int ndx, retcols;
6301 int do_symmetric;
6302
6303 if (gretl_is_null_matrix(A) || gretl_is_null_matrix(C)) {
6304 return E_DATA;
6305 }
6306
6307 r = A->rows;
6308 p = A->cols;
6309 do_symmetric = gretl_is_null_matrix(B);
6310
6311 if (do_symmetric) {
6312 q = p;
6313 retcols = p * (p+1) / 2;
6314 if (C->rows != r || C->cols != retcols) {
6315 return E_NONCONF;
6316 }
6317 } else {
6318 q = B->cols;
6319 retcols = p * q;
6320 if (B->rows != r || C->rows != r || C->cols != retcols) {
6321 return E_NONCONF;
6322 }
6323 }
6324
6325 for (i=0; i<r; i++) {
6326 ndx = 0;
6327 for (j=0; j<p; j++) {
6328 aij = gretl_matrix_get(A, i, j);
6329 if (do_symmetric) {
6330 for (k=j; k<q; k++) {
6331 bik = gretl_matrix_get(A, i, k);
6332 gretl_matrix_set(C, i, ndx++, aij*bik);
6333 }
6334 } else if (aij != 0.0) {
6335 ndx = j * q;
6336 for (k=0; k<q; k++) {
6337 bik = gretl_matrix_get(B, i, k);
6338 gretl_matrix_set(C, i, ndx + k, aij*bik);
6339 }
6340 }
6341 }
6342 }
6343
6344 return 0;
6345 }
6346
6347 /**
6348 * gretl_matrix_hdproduct_new:
6349 * @A: left-hand matrix, r x p.
6350 * @B: right-hand matrix, r x q or NULL.
6351 * @err: location to receive error code.
6352 *
6353 * If @B is NULL, then it is implicitly taken as equal to @A; in this case,
6354 * the returned matrix only contains the non-redundant elements; therefore,
6355 * it has ncols = p*(p+1)/2 elements. Otherwise, all the products are computed
6356 * and ncols = p*q.
6357 *
6358 * Returns: newly allocated r x ncols matrix which is the horizontal
6359 * direct product of matrices @A and @B, or NULL on failure.
6360 */
6361
gretl_matrix_hdproduct_new(const gretl_matrix * A,const gretl_matrix * B,int * err)6362 gretl_matrix * gretl_matrix_hdproduct_new (const gretl_matrix *A,
6363 const gretl_matrix *B,
6364 int *err)
6365 {
6366 gretl_matrix *K = NULL;
6367 int r, p, q, ncols;
6368
6369 if (gretl_is_null_matrix(A)) {
6370 *err = E_DATA;
6371 } else if (gretl_is_complex(A) && gretl_is_null_matrix(B)) {
6372 *err = E_DATA;
6373 } else if (gretl_is_complex(A) || gretl_is_complex(B)) {
6374 fprintf(stderr, "E_CMPLX in gretl_matrix_hdproduct_new\n");
6375 *err = E_CMPLX;
6376 }
6377
6378 if (*err) {
6379 return NULL;
6380 }
6381
6382 r = A->rows;
6383 p = A->cols;
6384
6385 if (gretl_is_null_matrix(B)) {
6386 q = A->cols;
6387 ncols = p * (p+1) / 2;
6388 } else {
6389 if (B->rows != r) {
6390 *err = E_NONCONF;
6391 } else {
6392 q = B->cols;
6393 ncols = p * q;
6394 }
6395 }
6396
6397 if (!*err) {
6398 K = gretl_zero_matrix_new(r, ncols);
6399 if (K == NULL) {
6400 *err = E_ALLOC;
6401 } else {
6402 gretl_matrix_hdproduct(A, B, K);
6403 }
6404 }
6405
6406 return K;
6407 }
6408
6409 /*
6410 returns the sequence of bits in the binary expansion of s
6411 */
6412
binary_expansion(int s,int * t,int * pow2)6413 static char *binary_expansion (int s, int *t, int *pow2)
6414 {
6415 char *bits = NULL;
6416 double l2 = log_2(s);
6417 int k = (int) floor(l2);
6418
6419 if (l2 == k) {
6420 *pow2 = 1;
6421 }
6422
6423 *t = k;
6424 bits = calloc(k + 1, 1);
6425
6426 if (bits != NULL) {
6427 while (1) {
6428 bits[k] = 1;
6429 s -= pow(2.0, k);
6430 if (s == 0) {
6431 break;
6432 }
6433 l2 = log_2(s);
6434 k = (int) floor(l2);
6435 }
6436 }
6437
6438 return bits;
6439 }
6440
matrix_frac_pow(const gretl_matrix * m,double a,int * err)6441 static gretl_matrix *matrix_frac_pow (const gretl_matrix *m,
6442 double a, int *err)
6443 {
6444 gretl_matrix *ret;
6445 gretl_matrix *tmp;
6446 gretl_matrix *lam;
6447 double eps = 1.0e-12;
6448 int n = m->rows;
6449
6450 tmp = gretl_matrix_copy(m);
6451 ret = gretl_matrix_alloc(n, n);
6452
6453 if (tmp == NULL || ret == NULL) {
6454 gretl_matrix_free(tmp);
6455 gretl_matrix_free(ret);
6456 *err = E_ALLOC;
6457 return NULL;
6458 }
6459
6460 lam = gretl_symmetric_matrix_eigenvals(tmp, 1, err);
6461
6462 if (!*err) {
6463 if (lam->val[0] < -eps) {
6464 /* be a little lenient with positive
6465 semidefinite matrices */
6466 *err = E_NOTPD;
6467 } else if (lam->val[0] < eps && a < 0) {
6468 /* but don't allow negative exponents if @m
6469 is singular */
6470 *err = E_INVARG;
6471 } else {
6472 double x, y, a2 = a/2;
6473 int i, j;
6474
6475 for (j=0; j<n; j++) {
6476 y = pow(fabs(lam->val[j]), a2);
6477 for (i=0; i<n; i++) {
6478 x = gretl_matrix_get(tmp, i, j);
6479 gretl_matrix_set(tmp, i, j, x * y);
6480 }
6481 }
6482 matrix_multiply_self_transpose(tmp, 0, ret, GRETL_MOD_NONE);
6483 }
6484 }
6485
6486 gretl_matrix_free(lam);
6487 gretl_matrix_free(tmp);
6488
6489 if (*err) {
6490 gretl_matrix_free(ret);
6491 ret = NULL;
6492 }
6493
6494 return ret;
6495 }
6496
matrix_int_pow(const gretl_matrix * A,int s,int * err)6497 static gretl_matrix *matrix_int_pow (const gretl_matrix *A,
6498 int s, int *err)
6499 {
6500 gretl_matrix *B = NULL;
6501 gretl_matrix *C = NULL;
6502 gretl_matrix *W = NULL;
6503 char *bits = NULL;
6504 int n, t, pow2 = 0;
6505
6506 n = A->rows;
6507
6508 if (s < 2) {
6509 B = (s == 0)? gretl_identity_matrix_new(n) :
6510 gretl_matrix_copy(A);
6511 if (B == NULL) {
6512 *err = E_ALLOC;
6513 }
6514 return B;
6515 }
6516
6517 bits = binary_expansion(s, &t, &pow2);
6518 if (bits == NULL) {
6519 *err = E_ALLOC;
6520 return NULL;
6521 }
6522
6523 B = gretl_matrix_copy_tmp(A);
6524 C = gretl_matrix_alloc(n, n);
6525
6526 if (!pow2) {
6527 W = gretl_matrix_alloc(n, n);
6528 }
6529
6530 if (B == NULL || C == NULL || (W == NULL && !pow2)) {
6531 gretl_matrix_free(C);
6532 C = NULL;
6533 *err = E_ALLOC;
6534 }
6535
6536 if (!*err) {
6537 int q = 0;
6538
6539 while (bits[q] == 0) {
6540 /* B = B^2 */
6541 gretl_matrix_multiply(B, B, C);
6542 gretl_matrix_copy_values(B, C);
6543 q++;
6544 }
6545
6546 if (!pow2) {
6547 /* more work needed */
6548 int k;
6549
6550 gretl_matrix_copy_values(C, B);
6551
6552 for (k=q+1; k<=t; k++) {
6553 /* B = B^2 */
6554 gretl_matrix_multiply(B, B, W);
6555 gretl_matrix_copy_values(B, W);
6556 if (bits[k]) {
6557 /* C = CB */
6558 gretl_matrix_multiply(C, B, W);
6559 gretl_matrix_copy_values(C, W);
6560 }
6561 }
6562 }
6563 }
6564
6565 gretl_matrix_free(B);
6566 gretl_matrix_free(W);
6567 free(bits);
6568
6569 return C;
6570 }
6571
6572 /**
6573 * gretl_matrix_pow:
6574 * @A: square source matrix.
6575 * @s: exponent.
6576 * @err: location to receive error code.
6577 *
6578 * Calculates the matrix A^s. If @s is a non-negative integer
6579 * Golub and Van Loan's Algorithm 11.2.2 ("Binary Powering")
6580 * is used. Otherwise @A must be positive definite, and the
6581 * power is computed via the eigen-decomposition of @A.
6582 *
6583 * Returns: allocated matrix, or NULL on failure.
6584 */
6585
gretl_matrix_pow(const gretl_matrix * A,double s,int * err)6586 gretl_matrix *gretl_matrix_pow (const gretl_matrix *A,
6587 double s, int *err)
6588 {
6589 if (gretl_is_null_matrix(A)) {
6590 *err = E_DATA;
6591 } else if (A->is_complex) {
6592 fprintf(stderr, "E_CMPLX in gretl_matrix_pow\n");
6593 *err = E_CMPLX;
6594 } else if (A->rows != A->cols) {
6595 *err = E_NONCONF;
6596 }
6597
6598 if (*err) {
6599 return NULL;
6600 } else if (s != floor(s) || s < 0) {
6601 return matrix_frac_pow(A, s, err);
6602 } else {
6603 int k = gretl_int_from_double(s, err);
6604
6605 if (*err) {
6606 return NULL;
6607 } else {
6608 return matrix_int_pow(A, k, err);
6609 }
6610 }
6611 }
6612
6613 /**
6614 * gretl_vector_dot_product:
6615 * @a: first vector.
6616 * @b: second vector.
6617 * @err: pointer to receive error code (zero on success,
6618 * non-zero on failure), or NULL.
6619 *
6620 * Returns: The dot (scalar) product of @a and @b, or #NADBL on
6621 * failure.
6622 */
6623
gretl_vector_dot_product(const gretl_vector * a,const gretl_vector * b,int * err)6624 double gretl_vector_dot_product (const gretl_vector *a,
6625 const gretl_vector *b,
6626 int *err)
6627 {
6628 int i, dima, dimb;
6629 double dp = 0.0;
6630
6631 if (gretl_is_null_matrix(a) || gretl_is_null_matrix(b)) {
6632 return NADBL;
6633 } else if (a->is_complex || b->is_complex) {
6634 *err = E_CMPLX;
6635 return NADBL;
6636 }
6637
6638 dima = (a->rows > 1)? a->rows : a->cols;
6639 dimb = (b->rows > 1)? b->rows : b->cols;
6640
6641 if (!gretl_is_vector(a) || !gretl_is_vector(b) || dima != dimb) {
6642 if (err != NULL) {
6643 *err = E_NONCONF;
6644 }
6645 dp = NADBL;
6646 } else {
6647 #if USE_SIMD
6648 if (simd_add_sub(dima)) {
6649 return gretl_vector_simd_dot_product(a, b);
6650 }
6651 #endif
6652 for (i=0; i<dima; i++) {
6653 dp += a->val[i] * b->val[i];
6654 }
6655 }
6656
6657 return dp;
6658 }
6659
6660 /**
6661 * gretl_matrix_dot_product:
6662 * @a: left-hand matrix.
6663 * @amod: modifier: %GRETL_MOD_NONE or %GRETL_MOD_TRANSPOSE.
6664 * @b: right-hand matrix.
6665 * @bmod: modifier: %GRETL_MOD_NONE or %GRETL_MOD_TRANSPOSE.
6666 * @err: pointer to receive error code (zero on success,
6667 * non-zero on failure), or NULL.
6668 *
6669 * Returns: The dot (scalar) product of @a (or @a-transpose) and
6670 * @b (or @b-transpose), or #NADBL on failure.
6671 */
6672
gretl_matrix_dot_product(const gretl_matrix * a,GretlMatrixMod amod,const gretl_matrix * b,GretlMatrixMod bmod,int * err)6673 double gretl_matrix_dot_product (const gretl_matrix *a,
6674 GretlMatrixMod amod,
6675 const gretl_matrix *b,
6676 GretlMatrixMod bmod,
6677 int *err)
6678 {
6679 gretl_matrix *c = NULL;
6680 double ret = NADBL;
6681 int myerr = 0;
6682
6683 if (gretl_is_null_matrix(a) || gretl_is_null_matrix(b)) {
6684 return NADBL;
6685 }
6686
6687 if (gretl_is_vector(a) && gretl_is_vector(b)) {
6688 return gretl_vector_dot_product(a, b, err);
6689 }
6690
6691 c = gretl_matrix_alloc(1, 1);
6692 if (c == NULL) {
6693 myerr = E_ALLOC;
6694 }
6695
6696 if (!myerr) {
6697 myerr = gretl_matrix_multiply_mod(a, amod, b, bmod,
6698 c, GRETL_MOD_NONE);
6699 }
6700
6701 if (!myerr) {
6702 ret = c->val[0];
6703 }
6704
6705 gretl_matrix_free(c);
6706
6707 if (err != NULL) {
6708 *err = myerr;
6709 }
6710
6711 return ret;
6712 }
6713
6714 /**
6715 * dot_operator_conf:
6716 * @A: first matrix.
6717 * @B: second matrix.
6718 * @r: pointer to rows of result.
6719 * @c: pointer to columns of result.
6720 *
6721 * Used to establish the dimensions of the result of a "dot"
6722 * operation such as A .* B or A .+ B.
6723 *
6724 * Returns: a numeric code identifying the convention to be used;
6725 * %CONF_NONE indicates non-conformability.
6726 */
6727
dot_operator_conf(const gretl_matrix * A,const gretl_matrix * B,int * r,int * c)6728 ConfType dot_operator_conf (const gretl_matrix *A,
6729 const gretl_matrix *B,
6730 int *r, int *c)
6731 {
6732 int ra = A->rows;
6733 int rb = B->rows;
6734 int ca = A->cols;
6735 int cb = B->cols;
6736 int confr = (ra == rb);
6737 int confc = (ca == cb);
6738 int colva = (ca == 1);
6739 int colvb = (cb == 1);
6740 int rowva = (ra == 1);
6741 int rowvb = (rb == 1);
6742 int ret = CONF_NONE;
6743
6744 if (confr && confc) {
6745 /* element-by-element operation */
6746 ret = CONF_ELEMENTS;
6747 *r = ra;
6748 *c = ca;
6749 } else if (confr && colva) {
6750 /* rows match; A is a column vector */
6751 ret = CONF_A_COLVEC;
6752 *r = ra;
6753 *c = (colva)? cb : ca;
6754 } else if (confr && colvb) {
6755 /* rows match; B is a column vector */
6756 ret = CONF_B_COLVEC;
6757 *r = ra;
6758 *c = (colva)? cb : ca;
6759 } else if (confc && rowva) {
6760 /* columns match; A is a row vector */
6761 ret = CONF_A_ROWVEC;
6762 *r = (rowva)? rb : ra;
6763 *c = ca;
6764 } else if (confc && rowvb) {
6765 /* columns match; B is a row vector */
6766 ret = CONF_B_ROWVEC;
6767 *r = (rowva)? rb : ra;
6768 *c = ca;
6769 } else if (ra == 1 && ca == 1) {
6770 /* A is a scalar in disguise */
6771 ret = CONF_A_SCALAR;
6772 *r = rb;
6773 *c = cb;
6774 } else if (rb == 1 && cb == 1) {
6775 /* B is a scalar in disguise */
6776 ret = CONF_B_SCALAR;
6777 *r = ra;
6778 *c = ca;
6779 } else if (colva && rowvb) {
6780 /* A is a column and B is a row */
6781 ret = CONF_AC_BR;
6782 *r = ra;
6783 *c = cb;
6784 } else if (rowva && colvb) {
6785 /* A is a row and B is a column */
6786 ret = CONF_AR_BC;
6787 *r = rb;
6788 *c = ca;
6789 }
6790
6791 return ret;
6792 }
6793
6794 /* give an OPENMP parallelization? */
6795
vec_x_op_vec_y(double * z,const double * x,const double * y,int n,int op)6796 static void vec_x_op_vec_y (double *z, const double *x,
6797 const double *y, int n,
6798 int op)
6799 {
6800 int i;
6801
6802 switch (op) {
6803 case '*':
6804 for (i=0; i<n; i++) {
6805 z[i] = x[i] * y[i];
6806 }
6807 break;
6808 case '/':
6809 for (i=0; i<n; i++) {
6810 z[i] = x[i] / y[i];
6811 }
6812 break;
6813 case '+':
6814 for (i=0; i<n; i++) {
6815 z[i] = x[i] + y[i];
6816 }
6817 break;
6818 case '-':
6819 for (i=0; i<n; i++) {
6820 z[i] = x[i] - y[i];
6821 }
6822 break;
6823 case '^':
6824 for (i=0; i<n; i++) {
6825 z[i] = pow(x[i], y[i]);
6826 }
6827 break;
6828 case '=':
6829 for (i=0; i<n; i++) {
6830 z[i] = x[i] == y[i];
6831 }
6832 break;
6833 case '>':
6834 for (i=0; i<n; i++) {
6835 z[i] = x[i] > y[i];
6836 }
6837 break;
6838 case '<':
6839 for (i=0; i<n; i++) {
6840 z[i] = x[i] < y[i];
6841 }
6842 break;
6843 case ']':
6844 for (i=0; i<n; i++) {
6845 z[i] = x[i] >= y[i];
6846 }
6847 break;
6848 case '[':
6849 for (i=0; i<n; i++) {
6850 z[i] = x[i] <= y[i];
6851 }
6852 break;
6853 case '!':
6854 for (i=0; i<n; i++) {
6855 z[i] = x[i] != y[i];
6856 }
6857 break;
6858 default:
6859 break;
6860 }
6861 }
6862
vec_x_op_y(double * z,const double * x,double y,int n,int op)6863 static void vec_x_op_y (double *z, const double *x,
6864 double y, int n, int op)
6865 {
6866 int i;
6867
6868 switch (op) {
6869 case '*':
6870 for (i=0; i<n; i++) {
6871 z[i] = x[i] * y;
6872 }
6873 break;
6874 case '/':
6875 for (i=0; i<n; i++) {
6876 z[i] = x[i] / y;
6877 }
6878 break;
6879 case '+':
6880 for (i=0; i<n; i++) {
6881 z[i] = x[i] + y;
6882 }
6883 break;
6884 case '-':
6885 for (i=0; i<n; i++) {
6886 z[i] = x[i] - y;
6887 }
6888 break;
6889 case '^':
6890 for (i=0; i<n; i++) {
6891 z[i] = pow(x[i], y);
6892 }
6893 break;
6894 case '=':
6895 for (i=0; i<n; i++) {
6896 z[i] = x[i] == y;
6897 }
6898 break;
6899 case '>':
6900 for (i=0; i<n; i++) {
6901 z[i] = x[i] > y;
6902 }
6903 break;
6904 case '<':
6905 for (i=0; i<n; i++) {
6906 z[i] = x[i] < y;
6907 }
6908 break;
6909 case ']':
6910 for (i=0; i<n; i++) {
6911 z[i] = x[i] >= y;
6912 }
6913 break;
6914 case '[':
6915 for (i=0; i<n; i++) {
6916 z[i] = x[i] <= y;
6917 }
6918 break;
6919 case '!':
6920 for (i=0; i<n; i++) {
6921 z[i] = x[i] != y;
6922 }
6923 break;
6924 default:
6925 break;
6926 }
6927 }
6928
x_op_vec_y(double * z,double x,const double * y,int n,int op)6929 static void x_op_vec_y (double *z, double x,
6930 const double *y, int n,
6931 int op)
6932 {
6933 int i;
6934
6935 switch (op) {
6936 case '*':
6937 for (i=0; i<n; i++) {
6938 z[i] = x * y[i];
6939 }
6940 break;
6941 case '/':
6942 for (i=0; i<n; i++) {
6943 z[i] = x / y[i];
6944 }
6945 break;
6946 case '+':
6947 for (i=0; i<n; i++) {
6948 z[i] = x + y[i];
6949 }
6950 break;
6951 case '-':
6952 for (i=0; i<n; i++) {
6953 z[i] = x - y[i];
6954 }
6955 break;
6956 case '^':
6957 for (i=0; i<n; i++) {
6958 z[i] = pow(x, y[i]);
6959 }
6960 break;
6961 case '=':
6962 for (i=0; i<n; i++) {
6963 z[i] = x == y[i];
6964 }
6965 break;
6966 case '>':
6967 for (i=0; i<n; i++) {
6968 z[i] = x > y[i];
6969 }
6970 break;
6971 case '<':
6972 for (i=0; i<n; i++) {
6973 z[i] = x < y[i];
6974 }
6975 break;
6976 case ']':
6977 for (i=0; i<n; i++) {
6978 z[i] = x >= y[i];
6979 }
6980 break;
6981 case '[':
6982 for (i=0; i<n; i++) {
6983 z[i] = x <= y[i];
6984 }
6985 break;
6986 case '!':
6987 for (i=0; i<n; i++) {
6988 z[i] = x != y[i];
6989 }
6990 break;
6991 default:
6992 break;
6993 }
6994 }
6995
x_op_y(double x,double y,int op)6996 static double x_op_y (double x, double y, int op)
6997 {
6998 switch (op) {
6999 case '*':
7000 return x * y;
7001 case '/':
7002 return x / y;
7003 case '+':
7004 return x + y;
7005 case '-':
7006 return x - y;
7007 case '^':
7008 return pow(x, y);
7009 case '=':
7010 return x == y;
7011 case '>':
7012 return x > y;
7013 case '<':
7014 return x < y;
7015 case ']':
7016 return x >= y;
7017 case '[':
7018 return x <= y;
7019 case '!':
7020 return x != y;
7021 default:
7022 return 0;
7023 }
7024 }
7025
7026 /**
7027 * gretl_matrix_dot_op:
7028 * @a: left-hand matrix.
7029 * @b: right-hand matrix.
7030 * @op: operator.
7031 * @err: location to receive error code.
7032 *
7033 * Returns: a new matrix, each of whose elements is the result
7034 * of (x op y), where x and y are the corresponding elements of
7035 * the matrices @a and @b (or NULL on failure).
7036 */
7037
gretl_matrix_dot_op(const gretl_matrix * a,const gretl_matrix * b,int op,int * err)7038 gretl_matrix *gretl_matrix_dot_op (const gretl_matrix *a,
7039 const gretl_matrix *b,
7040 int op, int *err)
7041 {
7042 ConfType conftype;
7043 gretl_matrix *c = NULL;
7044 double x, y;
7045 int nr, nc;
7046 int i, j, off;
7047
7048 if (gretl_is_null_matrix(a) || gretl_is_null_matrix(b)) {
7049 *err = E_DATA;
7050 return NULL;
7051 }
7052
7053 conftype = dot_operator_conf(a, b, &nr, &nc);
7054
7055 if (conftype == CONF_NONE) {
7056 fputs("gretl_matrix_dot_op: matrices not conformable\n", stderr);
7057 fprintf(stderr, " op = '%c', A is %d x %d, B is %d x %d\n",
7058 (char) op, a->rows, a->cols, b->rows, b->cols);
7059 *err = E_NONCONF;
7060 return NULL;
7061 }
7062
7063 c = gretl_matrix_alloc(nr, nc);
7064 if (c == NULL) {
7065 *err = E_ALLOC;
7066 return NULL;
7067 }
7068
7069 math_err_init();
7070
7071 switch (conftype) {
7072 case CONF_ELEMENTS:
7073 vec_x_op_vec_y(c->val, a->val, b->val, nr*nc, op);
7074 break;
7075 case CONF_A_COLVEC:
7076 for (i=0; i<nr; i++) {
7077 x = a->val[i];
7078 for (j=0; j<nc; j++) {
7079 y = gretl_matrix_get(b, i, j);
7080 y = x_op_y(x, y, op);
7081 gretl_matrix_set(c, i, j, y);
7082 }
7083 }
7084 break;
7085 case CONF_B_COLVEC:
7086 for (i=0; i<nr; i++) {
7087 y = b->val[i];
7088 for (j=0; j<nc; j++) {
7089 x = gretl_matrix_get(a, i, j);
7090 x = x_op_y(x, y, op);
7091 gretl_matrix_set(c, i, j, x);
7092 }
7093 }
7094 break;
7095 case CONF_A_ROWVEC:
7096 off = 0;
7097 for (j=0; j<nc; j++) {
7098 x = a->val[j];
7099 x_op_vec_y(c->val + off, x, b->val + off, nr, op);
7100 off += nr;
7101 }
7102 break;
7103 case CONF_B_ROWVEC:
7104 off = 0;
7105 for (j=0; j<nc; j++) {
7106 y = b->val[j];
7107 vec_x_op_y(c->val + off, a->val + off, y, nr, op);
7108 off += nr;
7109 }
7110 break;
7111 case CONF_A_SCALAR:
7112 x_op_vec_y(c->val, a->val[0], b->val, nr*nc, op);
7113 break;
7114 case CONF_B_SCALAR:
7115 vec_x_op_y(c->val, a->val, b->val[0], nr*nc, op);
7116 break;
7117 case CONF_AC_BR:
7118 for (i=0; i<nr; i++) {
7119 x = a->val[i];
7120 for (j=0; j<nc; j++) {
7121 y = b->val[j];
7122 y = x_op_y(x, y, op);
7123 gretl_matrix_set(c, i, j, y);
7124 }
7125 }
7126 break;
7127 case CONF_AR_BC:
7128 for (j=0; j<nc; j++) {
7129 x = a->val[j];
7130 for (i=0; i<nr; i++) {
7131 y = b->val[i];
7132 y = x_op_y(x, y, op);
7133 gretl_matrix_set(c, i, j, y);
7134 }
7135 }
7136 break;
7137 default: /* hush a warning */
7138 break;
7139 }
7140
7141 if (errno) {
7142 *err = math_err_check("gretl_matrix_dot_op", errno);
7143 if (*err) {
7144 gretl_matrix_free(c);
7145 c = NULL;
7146 }
7147 }
7148
7149 return c;
7150 }
7151
7152 /* Multiplication or division for complex matrices in the old
7153 gretl representation, with real parts in the first column
7154 and imaginary parts (if present) in the second.
7155 */
7156
7157 static gretl_matrix *
gretl_matrix_complex_muldiv(const gretl_matrix * a,const gretl_matrix * b,int multiply,int force_complex,int * err)7158 gretl_matrix_complex_muldiv (const gretl_matrix *a,
7159 const gretl_matrix *b,
7160 int multiply,
7161 int force_complex,
7162 int *err)
7163 {
7164 gretl_matrix *c = NULL;
7165 double *ar, *ai;
7166 double *br, *bi;
7167 double *cr, *ci;
7168 double complex az, bz, cz;
7169 int m, n, p, q;
7170 int i, izero = 1;
7171
7172 if (gretl_is_null_matrix(a) || gretl_is_null_matrix(b)) {
7173 *err = E_DATA;
7174 return NULL;
7175 }
7176
7177 m = a->rows;
7178 n = a->cols;
7179 p = b->rows;
7180 q = b->cols;
7181
7182 if (m != p) {
7183 *err = E_NONCONF;
7184 return NULL;
7185 }
7186
7187 if ((n != 1 && n != 2) || (q != 1 && q != 2)) {
7188 *err = E_NONCONF;
7189 return NULL;
7190 }
7191
7192 if (force_complex) {
7193 p = 2;
7194 } else {
7195 p = (n == 1 && q == 1)? 1 : 2;
7196 }
7197
7198 c = gretl_matrix_alloc(m, p);
7199 if (c == NULL) {
7200 *err = E_ALLOC;
7201 return NULL;
7202 }
7203
7204 math_err_init();
7205
7206 ar = a->val;
7207 ai = (a->cols == 2)? ar + m : NULL;
7208
7209 br = b->val;
7210 bi = (b->cols == 2)? br + m : NULL;
7211
7212 cr = c->val;
7213 ci = (c->cols == 2)? cr + m : NULL;
7214
7215 for (i=0; i<m; i++) {
7216 az = ai == NULL ? ar[i] : ar[i] + ai[i] * I;
7217 bz = bi == NULL ? br[i] : br[i] + bi[i] * I;
7218 cz = multiply ? az * bz : az / bz;
7219 cr[i] = creal(cz);
7220 if (ci != NULL) {
7221 ci[i] = cimag(cz);
7222 if (ci[i] != 0.0) {
7223 izero = 0;
7224 }
7225 }
7226 }
7227
7228 if (errno) {
7229 *err = math_err_check("gretl_matrix_complex_muldiv", errno);
7230 if (*err) {
7231 gretl_matrix_free(c);
7232 c = NULL;
7233 }
7234 }
7235
7236 if (!*err && !force_complex && c->cols == 2 && izero) {
7237 /* drop the all-zero imaginary part */
7238 *err = gretl_matrix_realloc(c, c->rows, 1);
7239 if (*err) {
7240 gretl_matrix_free(c);
7241 c = NULL;
7242 }
7243 }
7244
7245 return c;
7246 }
7247
7248 /**
7249 * gretl_matrix_complex_multiply:
7250 * @a: m x (1 or 2) matrix.
7251 * @b: m x (1 or 2) matrix.
7252 * @force_complex: see below.
7253 * @err: location to receive error code.
7254 *
7255 * Computes the complex product of @a and @b. The first
7256 * column in these matrices is assumed to contain real
7257 * values, and the second column (if present) imaginary
7258 * coefficients.
7259 *
7260 * Returns: a matrix with the result of the multiplication
7261 * of the two vectors of complex numbers. If both @a and @b have no
7262 * imaginary part and the @force_complex flag is zero, the return
7263 * value will be m x 1, otherwise it will be m x 2.
7264 */
7265
gretl_matrix_complex_multiply(const gretl_matrix * a,const gretl_matrix * b,int force_complex,int * err)7266 gretl_matrix *gretl_matrix_complex_multiply (const gretl_matrix *a,
7267 const gretl_matrix *b,
7268 int force_complex,
7269 int *err)
7270 {
7271 return gretl_matrix_complex_muldiv(a, b, 1, force_complex, err);
7272 }
7273
7274 /**
7275 * gretl_matrix_complex_divide:
7276 * @a: m x (1 or 2) matrix.
7277 * @b: m x (1 or 2) matrix.
7278 * @force_complex: see below.
7279 * @err: location to receive error code.
7280 *
7281 * Computes the complex division of @a over @b. The first
7282 * column in these matrices is assumed to contain real
7283 * values, and the second column (if present) imaginary
7284 * coefficients.
7285 *
7286 * Returns: a matrix with the result of the division of the
7287 * two vectors of complex numbers. If both @a and @b have no
7288 * imaginary part and the @force_complex flag is zero, the return
7289 * value will be m x 1, otherwise it will be m x 2.
7290 */
7291
gretl_matrix_complex_divide(const gretl_matrix * a,const gretl_matrix * b,int force_complex,int * err)7292 gretl_matrix *gretl_matrix_complex_divide (const gretl_matrix *a,
7293 const gretl_matrix *b,
7294 int force_complex,
7295 int *err)
7296 {
7297 return gretl_matrix_complex_muldiv(a, b, 0, force_complex, err);
7298 }
7299
7300 /**
7301 * gretl_rmatrix_vector_stat:
7302 * @m: source matrix.
7303 * @vs: the required statistic or quantity: sum, product or mean.
7304 * @rowwise: if non-zero go by rows, otherwise go by columns.
7305 * @err: location to receive error code.
7306 *
7307 * Returns: a row vector or column vector containing the sums,
7308 * products or means of the columns or rows of @m. See also
7309 * gretl_rmatrix_vector_stat() for the complex variant.
7310 */
7311
gretl_rmatrix_vector_stat(const gretl_matrix * m,GretlVecStat vs,int rowwise,int * err)7312 gretl_matrix *gretl_rmatrix_vector_stat (const gretl_matrix *m,
7313 GretlVecStat vs,
7314 int rowwise, int *err)
7315 {
7316 gretl_matrix *ret;
7317 double x;
7318 int r, c, i, j;
7319
7320 if (gretl_is_null_matrix(m)) {
7321 *err = E_DATA;
7322 return NULL;
7323 }
7324
7325 r = rowwise ? m->rows : 1;
7326 c = rowwise ? 1 : m->cols;
7327
7328 ret = gretl_matrix_alloc(r, c);
7329 if (ret == NULL) {
7330 *err = E_ALLOC;
7331 return NULL;
7332 }
7333
7334 if (rowwise) {
7335 /* by rows */
7336 int jmin = vs == V_PROD ? 1 : 0;
7337
7338 for (i=0; i<m->rows; i++) {
7339 x = vs == V_PROD ? m->val[i] : 0;
7340 for (j=jmin; j<m->cols; j++) {
7341 if (vs == V_PROD) {
7342 x *= gretl_matrix_get(m, i, j);
7343 } else {
7344 x += gretl_matrix_get(m, i, j);
7345 }
7346 }
7347 if (vs == V_MEAN) {
7348 x /= m->cols;
7349 }
7350 gretl_matrix_set(ret, i, 0, x);
7351 }
7352 } else {
7353 /* by columns */
7354 int imin = vs == V_PROD ? 1 : 0;
7355
7356 for (j=0; j<m->cols; j++) {
7357 x = vs == V_PROD ? gretl_matrix_get(m, 0, j) : 0;
7358 for (i=imin; i<m->rows; i++) {
7359 if (vs == V_PROD) {
7360 x *= gretl_matrix_get(m, i, j);
7361 } else {
7362 x += gretl_matrix_get(m, i, j);
7363 }
7364 }
7365 if (vs == V_MEAN) {
7366 x /= m->rows;
7367 }
7368 gretl_matrix_set(ret, 0, j, x);
7369 }
7370 }
7371
7372 if (rowwise) {
7373 maybe_preserve_names(ret, m, ROWNAMES, NULL);
7374 } else {
7375 maybe_preserve_names(ret, m, COLNAMES, NULL);
7376 }
7377
7378 return ret;
7379 }
7380
7381 /**
7382 * gretl_matrix_column_sd2:
7383 * @m: source matrix.
7384 * @df: degrees of freedom for standard deviations.
7385 * @err: location to receive error code.
7386 *
7387 * Returns: a row vector containing the standard deviations of
7388 * the columns of @m, or NULL on failure. If @df is positive
7389 * it is used as the divisor when calculating the column
7390 * variance, otherwise the divisor is the number of rows in
7391 * @m.
7392 */
7393
gretl_matrix_column_sd2(const gretl_matrix * m,int df,int * err)7394 gretl_matrix *gretl_matrix_column_sd2 (const gretl_matrix *m,
7395 int df, int *err)
7396 {
7397 gretl_matrix *s;
7398 double xbar, dev, v;
7399 int i, j;
7400
7401 if (gretl_is_null_matrix(m)) {
7402 *err = E_DATA;
7403 return NULL;
7404 } else if (m->is_complex) {
7405 fprintf(stderr, "E_CMPLX in gretl_matrix_columns_sd2\n");
7406 *err = E_CMPLX;
7407 return NULL;
7408 }
7409
7410 s = gretl_matrix_alloc(1, m->cols);
7411
7412 if (s == NULL) {
7413 *err = E_ALLOC;
7414 return NULL;
7415 }
7416
7417 if (df <= 0) {
7418 df = m->rows;
7419 }
7420
7421 for (j=0; j<m->cols; j++) {
7422 xbar = v = 0.0;
7423 for (i=0; i<m->rows; i++) {
7424 xbar += gretl_matrix_get(m, i, j);
7425 }
7426 xbar /= m->rows;
7427 for (i=0; i<m->rows; i++) {
7428 dev = gretl_matrix_get(m, i, j) - xbar;
7429 v += dev * dev;
7430 }
7431 s->val[j] = sqrt(v / df);
7432 }
7433
7434 return s;
7435 }
7436
7437 /**
7438 * gretl_matrix_column_sd:
7439 * @m: source matrix.
7440 * @err: location to receive error code.
7441 *
7442 * Returns: a row vector containing the standard deviations of
7443 * the columns of @m (without a degrees of freedom correction),
7444 * or NULL on failure.
7445 */
7446
gretl_matrix_column_sd(const gretl_matrix * m,int * err)7447 gretl_matrix *gretl_matrix_column_sd (const gretl_matrix *m, int *err)
7448 {
7449 return gretl_matrix_column_sd2(m, 0, err);
7450 }
7451
7452 /**
7453 * gretl_matrix_demean_by_row:
7454 * @m: matrix on which to operate.
7455 *
7456 * For each row of @m, subtracts the row mean from each
7457 * element on the row.
7458 */
7459
gretl_matrix_demean_by_row(gretl_matrix * m)7460 void gretl_matrix_demean_by_row (gretl_matrix *m)
7461 {
7462 double rmean;
7463 int i, j;
7464
7465 for (i=0; i<m->rows; i++) {
7466 rmean = 0;
7467 for (j=0; j<m->cols; j++) {
7468 rmean += gretl_matrix_get(m, i, j);
7469 }
7470 rmean /= m->cols;
7471 for (j=0; j<m->cols; j++) {
7472 gretl_matrix_cum(m, i, j, -rmean);
7473 }
7474 }
7475 }
7476
7477 /**
7478 * gretl_matrix_center:
7479 * @m: matrix on which to operate.
7480 *
7481 * Subtracts the column mean from each column of @m.
7482 */
7483
gretl_matrix_center(gretl_matrix * m)7484 int gretl_matrix_center (gretl_matrix *m)
7485 {
7486 double x, xbar;
7487 int i, j;
7488
7489 #if defined(_OPENMP)
7490 if (m->cols == 1 || m->rows * m->cols < 4096) {
7491 goto st_mode;
7492 }
7493 #pragma omp parallel for private(i, j, x, xbar)
7494 for (j=0; j<m->cols; j++) {
7495 xbar = 0;
7496 for (i=0; i<m->rows; i++) {
7497 xbar += gretl_matrix_get(m, i, j);
7498 }
7499 xbar /= m->rows;
7500 for (i=0; i<m->rows; i++) {
7501 x = gretl_matrix_get(m, i, j) - xbar;
7502 gretl_matrix_set(m, i, j, x);
7503 }
7504 }
7505 return 0;
7506
7507 st_mode:
7508 #endif
7509
7510 for (j=0; j<m->cols; j++) {
7511 xbar = 0;
7512 for (i=0; i<m->rows; i++) {
7513 xbar += gretl_matrix_get(m, i, j);
7514 }
7515 xbar /= m->rows;
7516 for (i=0; i<m->rows; i++) {
7517 x = gretl_matrix_get(m, i, j) - xbar;
7518 gretl_matrix_set(m, i, j, x);
7519 }
7520 }
7521 return 0;
7522 }
7523
7524 /**
7525 * gretl_matrix_standardize:
7526 * @m: matrix on which to operate.
7527 * @dfcorr: degrees of freedom correction.
7528 *
7529 * Subtracts the column mean from each column of @m and
7530 * divides by the column standard deviation, using @dfcorr
7531 * as degrees of freedom correction (0 for MLE).
7532 */
7533
gretl_matrix_standardize(gretl_matrix * m,int dfcorr)7534 int gretl_matrix_standardize (gretl_matrix *m, int dfcorr)
7535 {
7536 double x, xbar, sdc;
7537 int i, j;
7538
7539 if (m->rows < 2) {
7540 return E_TOOFEW;
7541 }
7542
7543 #if defined(_OPENMP)
7544 if (m->cols == 1 || m->rows * m->cols < 4096) {
7545 goto st_mode;
7546 }
7547 #pragma omp parallel for private(i, j, x, xbar, sdc)
7548 for (j=0; j<m->cols; j++) {
7549 xbar = sdc = 0;
7550 for (i=0; i<m->rows; i++) {
7551 xbar += gretl_matrix_get(m, i, j);
7552 }
7553 xbar /= m->rows;
7554 for (i=0; i<m->rows; i++) {
7555 x = gretl_matrix_get(m, i, j) - xbar;
7556 gretl_matrix_set(m, i, j, x);
7557 sdc += x * x;
7558 }
7559 sdc = sqrt(sdc / (m->rows - dfcorr));
7560 for (i=0; i<m->rows; i++) {
7561 x = gretl_matrix_get(m, i, j) / sdc;
7562 gretl_matrix_set(m, i, j, x);
7563 }
7564 }
7565 return 0;
7566
7567 st_mode:
7568 #endif
7569
7570 for (j=0; j<m->cols; j++) {
7571 xbar = sdc = 0;
7572 for (i=0; i<m->rows; i++) {
7573 xbar += gretl_matrix_get(m, i, j);
7574 }
7575 xbar /= m->rows;
7576 for (i=0; i<m->rows; i++) {
7577 x = gretl_matrix_get(m, i, j) - xbar;
7578 gretl_matrix_set(m, i, j, x);
7579 sdc += x * x;
7580 }
7581 sdc = sqrt(sdc / (m->rows - dfcorr));
7582 for (i=0; i<m->rows; i++) {
7583 x = gretl_matrix_get(m, i, j) / sdc;
7584 gretl_matrix_set(m, i, j, x);
7585 }
7586 }
7587 return 0;
7588 }
7589
7590 /**
7591 * gretl_matrix_quantiles:
7592 * @m: matrix on which to operate.
7593 * @p: vector of desired quantiles.
7594 * @err: location to receive error code.
7595 *
7596 * Returns: a matrix containing the @p quantiles
7597 * of the columns of @m, or NULL on failure.
7598 */
7599
gretl_matrix_quantiles(const gretl_matrix * m,const gretl_matrix * p,int * err)7600 gretl_matrix *gretl_matrix_quantiles (const gretl_matrix *m,
7601 const gretl_matrix *p,
7602 int *err)
7603 {
7604 gretl_matrix *qvals;
7605 const double *mval;
7606 double *a, *q;
7607 int i, j, k;
7608 int n, plen;
7609
7610 if (gretl_is_null_matrix(m)) {
7611 *err = E_INVARG;
7612 return NULL;
7613 }
7614
7615 plen = gretl_vector_get_length(p);
7616
7617 if (plen == 0) {
7618 *err = E_INVARG;
7619 return NULL;
7620 }
7621
7622 for (i=0; i<plen; i++) {
7623 if (p->val[i] <= 0 || p->val[i] >= 1 || na(p->val[i])) {
7624 *err = E_INVARG;
7625 return NULL;
7626 }
7627 }
7628
7629 qvals = gretl_matrix_alloc(plen, m->cols);
7630 if (qvals == NULL) {
7631 *err = E_ALLOC;
7632 return NULL;
7633 }
7634
7635 n = m->rows;
7636 a = malloc(n * sizeof *a);
7637 q = malloc(plen * sizeof *q);
7638
7639 if (a == NULL || q == NULL) {
7640 *err = E_ALLOC;
7641 gretl_matrix_free(qvals);
7642 free(a);
7643 free(q);
7644 return NULL;
7645 }
7646
7647 mval = m->val;
7648
7649 for (j=0; j<m->cols && !*err; j++) {
7650 k = 0;
7651 for (i=0; i<n; i++) {
7652 if (!na(mval[i])) {
7653 a[k++] = mval[i];
7654 }
7655 }
7656 memcpy(q, p->val, plen * sizeof *q);
7657 if (k == 0) {
7658 for (i=0; i<plen; i++) {
7659 gretl_matrix_set(qvals, i, j, NADBL);
7660 }
7661 } else {
7662 *err = gretl_array_quantiles(a, k, q, plen);
7663 if (!*err) {
7664 for (i=0; i<plen; i++) {
7665 gretl_matrix_set(qvals, i, j, q[i]);
7666 }
7667 }
7668 }
7669 mval += n;
7670 }
7671
7672 if (*err) {
7673 gretl_matrix_free(qvals);
7674 qvals = NULL;
7675 }
7676
7677 free(a);
7678 free(q);
7679
7680 return qvals;
7681 }
7682
7683 /**
7684 * gretl_matrix_multiply:
7685 * @a: left-hand matrix.
7686 * @b: right-hand matrix.
7687 * @c: matrix to hold the product.
7688 *
7689 * Multiplies @a into @b, with the result written into @c.
7690 *
7691 * Returns: 0 on success; non-zero error code on
7692 * failure.
7693 */
7694
gretl_matrix_multiply(const gretl_matrix * a,const gretl_matrix * b,gretl_matrix * c)7695 int gretl_matrix_multiply (const gretl_matrix *a, const gretl_matrix *b,
7696 gretl_matrix *c)
7697 {
7698 int err = 0;
7699
7700 if (gretl_is_null_matrix(a) ||
7701 gretl_is_null_matrix(b) ||
7702 gretl_is_null_matrix(c)) {
7703 return E_DATA;
7704 }
7705
7706 if (matrix_is_scalar(a)) {
7707 err = gretl_matrix_copy_values(c, b);
7708 if (!err) {
7709 gretl_matrix_multiply_by_scalar(c, a->val[0]);
7710 }
7711 } else if (matrix_is_scalar(b)) {
7712 err = gretl_matrix_copy_values(c, a);
7713 if (!err) {
7714 gretl_matrix_multiply_by_scalar(c, b->val[0]);
7715 }
7716 } else {
7717 err = gretl_matrix_multiply_mod(a, GRETL_MOD_NONE,
7718 b, GRETL_MOD_NONE,
7719 c, GRETL_MOD_NONE);
7720 }
7721
7722 return err;
7723 }
7724
gretl_matrix_multiply_single(const gretl_matrix * a,const gretl_matrix * b,gretl_matrix * c)7725 int gretl_matrix_multiply_single (const gretl_matrix *a,
7726 const gretl_matrix *b,
7727 gretl_matrix *c)
7728 {
7729 int err = 0;
7730
7731 if (gretl_is_null_matrix(a) ||
7732 gretl_is_null_matrix(b) ||
7733 gretl_is_null_matrix(c)) {
7734 return E_DATA;
7735 }
7736
7737 if (matrix_is_scalar(a)) {
7738 err = gretl_matrix_copy_values(c, b);
7739 if (!err) {
7740 gretl_matrix_multiply_by_scalar(c, a->val[0]);
7741 }
7742 } else if (matrix_is_scalar(b)) {
7743 err = gretl_matrix_copy_values(c, a);
7744 if (!err) {
7745 gretl_matrix_multiply_by_scalar(c, b->val[0]);
7746 }
7747 } else {
7748 err = gretl_matrix_multiply_mod_single(a, GRETL_MOD_NONE,
7749 b, GRETL_MOD_NONE,
7750 c, GRETL_MOD_NONE);
7751 }
7752
7753 return err;
7754 }
7755
7756 /**
7757 * gretl_matrix_multiply_new:
7758 * @a: left-hand matrix.
7759 * @b: right-hand matrix.
7760 * @err: location for error code.
7761 *
7762 * Multiplies @a into @b, with the result written into a newly
7763 * allocated matrix.
7764 *
7765 * Returns: matrix product on success, or NULL on failure.
7766 */
7767
gretl_matrix_multiply_new(const gretl_matrix * a,const gretl_matrix * b,int * err)7768 gretl_matrix *gretl_matrix_multiply_new (const gretl_matrix *a,
7769 const gretl_matrix *b,
7770 int *err)
7771 {
7772 gretl_matrix *c;
7773
7774 if (gretl_is_null_matrix(a) || gretl_is_null_matrix(b)) {
7775 *err = E_DATA;
7776 return NULL;
7777 }
7778
7779 if (a->cols != b->rows) {
7780 fprintf(stderr, "gretl_matrix_multiply_new: requested (%d x %d) * (%d x %d)\n",
7781 a->rows, a->cols, b->rows, b->cols);
7782 *err = E_NONCONF;
7783 return NULL;
7784 }
7785
7786 c = gretl_matrix_alloc(a->rows, b->cols);
7787 if (c == NULL) {
7788 *err = E_ALLOC;
7789 return NULL;
7790 }
7791
7792 *err = gretl_matrix_multiply_mod(a, GRETL_MOD_NONE,
7793 b, GRETL_MOD_NONE,
7794 c, GRETL_MOD_NONE);
7795
7796 if (*err) {
7797 gretl_matrix_free(c);
7798 c = NULL;
7799 }
7800
7801 return c;
7802 }
7803
matrix_divide_by_scalmat(gretl_matrix * num,const gretl_matrix * den)7804 static int matrix_divide_by_scalmat (gretl_matrix *num,
7805 const gretl_matrix *den)
7806 {
7807 int i, n = num->rows * num->cols;
7808
7809 if (num->is_complex) {
7810 double complex zden;
7811
7812 zden = den->is_complex ? den->z[0] : den->val[0];
7813 for (i=0; i<n; i++) {
7814 num->z[i] /= zden;
7815 }
7816 } else {
7817 if (den->is_complex) {
7818 return E_TYPES;
7819 } else {
7820 for (i=0; i<n; i++) {
7821 num->val[i] /= den->val[0];
7822 }
7823 }
7824 }
7825
7826 return 0;
7827 }
7828
7829 /**
7830 * gretl_matrix_divide:
7831 * @a: left-hand matrix.
7832 * @b: right-hand matrix.
7833 * @mod: %GRETL_MOD_NONE for left division, or
7834 * %GRETL_MOD_TRANSPOSE for right division.
7835 * @err: location to receive error code.
7836 *
7837 * Follows the semantics of Matlab/Octave for left and right
7838 * matrix "division". In left division, A \ B is in principle
7839 * equivalent to A^{-1} * B, and in right division A / B is
7840 * in principle equivalent to A * B^{-1}, but the result is
7841 * obtained without explicit computation of the inverse.
7842 *
7843 * In left division @a and @b must have the same number of
7844 * rows; in right division they must have the same number
7845 * of columns.
7846 *
7847 * Returns: the "quotient" matrix, or NULL on failure.
7848 */
7849
gretl_matrix_divide(const gretl_matrix * a,const gretl_matrix * b,GretlMatrixMod mod,int * err)7850 gretl_matrix *gretl_matrix_divide (const gretl_matrix *a,
7851 const gretl_matrix *b,
7852 GretlMatrixMod mod,
7853 int *err)
7854 {
7855 gretl_matrix *Q = NULL;
7856 gretl_matrix *AT = NULL, *BT = NULL;
7857 gretl_matrix *Tmp;
7858
7859 if (gretl_is_null_matrix(a) ||
7860 gretl_is_null_matrix(b)) {
7861 *err = E_DATA;
7862 return NULL;
7863 }
7864
7865 /* detect and handle scalar cases */
7866 if (mod == GRETL_MOD_NONE && is_one_by_one(a)) {
7867 Q = gretl_matrix_copy(b);
7868 if (Q == NULL) {
7869 *err = E_ALLOC;
7870 } else {
7871 *err = matrix_divide_by_scalmat(Q, a);
7872 }
7873 return Q;
7874 } else if (mod == GRETL_MOD_TRANSPOSE && is_one_by_one(b)) {
7875 Q = gretl_matrix_copy(a);
7876 if (Q == NULL) {
7877 *err = E_ALLOC;
7878 } else {
7879 *err = matrix_divide_by_scalmat(Q, b);
7880 }
7881 return Q;
7882 }
7883
7884 if (mod == GRETL_MOD_NONE && a->rows != b->rows) {
7885 *err = E_NONCONF;
7886 } else if (mod == GRETL_MOD_TRANSPOSE && a->cols != b->cols) {
7887 *err = E_NONCONF;
7888 }
7889
7890 if (*err) {
7891 return Q;
7892 }
7893
7894 if (mod == GRETL_MOD_TRANSPOSE) {
7895 AT = gretl_matrix_copy_transpose(b);
7896 BT = gretl_matrix_copy_transpose(a);
7897 if (AT == NULL || BT == NULL) {
7898 *err = E_ALLOC;
7899 goto bailout;
7900 } else {
7901 a = AT;
7902 b = BT;
7903 }
7904 }
7905
7906 Q = gretl_matrix_copy(b);
7907 if (Q == NULL) {
7908 *err = E_ALLOC;
7909 } else {
7910 Tmp = gretl_matrix_copy(a);
7911 if (Tmp == NULL) {
7912 *err = E_ALLOC;
7913 } else {
7914 *err = gretl_matrix_solve(Tmp, Q);
7915 gretl_matrix_free(Tmp);
7916 }
7917 }
7918
7919 if (mod == GRETL_MOD_TRANSPOSE && *err == 0) {
7920 Tmp = Q;
7921 Q = gretl_matrix_copy_transpose(Tmp);
7922 if (Q == NULL) {
7923 *err = E_ALLOC;
7924 }
7925 gretl_matrix_free(Tmp);
7926 }
7927
7928 bailout:
7929
7930 if (mod == GRETL_MOD_TRANSPOSE) {
7931 gretl_matrix_free(AT);
7932 gretl_matrix_free(BT);
7933 }
7934
7935 if (*err && Q != NULL) {
7936 gretl_matrix_free(Q);
7937 Q = NULL;
7938 }
7939
7940 return Q;
7941 }
7942
7943 /**
7944 * gretl_general_matrix_rcond:
7945 * @m: matrix to examine.
7946 * @err: location to receive error code.
7947 *
7948 * Estimates the reciprocal condition number of the general
7949 * real matrix @m (in the 1-norm), using the LAPACK
7950 * functions dgetrf() and dgecon().
7951 *
7952 * Returns: the estimate, or #NADBL on failure to allocate memory.
7953 */
7954
gretl_general_matrix_rcond(const gretl_matrix * A,int * err)7955 static double gretl_general_matrix_rcond (const gretl_matrix *A,
7956 int *err)
7957 {
7958 gretl_matrix *a = NULL;
7959 char norm = '1';
7960 integer m, n, lda, info;
7961 integer *iwork = NULL;
7962 integer *ipiv = NULL;
7963 double *work = NULL;
7964 double rcond = NADBL;
7965
7966 *err = 0;
7967
7968 if (gretl_is_null_matrix(A)) {
7969 return NADBL;
7970 }
7971
7972 m = A->rows;
7973 n = A->cols;
7974 lda = A->rows;
7975
7976 a = gretl_matrix_copy_tmp(A);
7977 work = malloc((4 * n) * sizeof *work);
7978 iwork = malloc(n * sizeof *iwork);
7979 ipiv = malloc(min(m, n) * sizeof *ipiv);
7980
7981 if (a == NULL || work == NULL || iwork == NULL || ipiv == NULL) {
7982 *err = E_ALLOC;
7983 goto bailout;
7984 }
7985
7986 dgetrf_(&m, &n, a->val, &lda, ipiv, &info);
7987
7988 if (info != 0) {
7989 fprintf(stderr, "gretl_general_matrix_rcond:\n"
7990 " dgetrf failed with info = %d (n = %d)\n", (int) info, (int) n);
7991 gretl_matrix_print(A, "A in rcond");
7992 *err = E_DATA;
7993 rcond = NADBL;
7994 } else {
7995 pivot_check(ipiv, min(m, n));
7996 }
7997
7998 if (!*err) {
7999 double anorm = gretl_matrix_one_norm(A);
8000
8001 dgecon_(&norm, &n, a->val, &lda, &anorm, &rcond, work, iwork, &info);
8002 if (info != 0) {
8003 *err = E_DATA;
8004 rcond = NADBL;
8005 }
8006 }
8007
8008 bailout:
8009
8010 free(work);
8011 free(iwork);
8012 free(ipiv);
8013 gretl_matrix_free(a);
8014
8015 return rcond;
8016 }
8017
8018 /**
8019 * gretl_symmetric_matrix_rcond:
8020 * @m: matrix to examine.
8021 * @err: location to receive error code.
8022 *
8023 * Estimates the reciprocal condition number of the real symmetric
8024 * positive definite matrix @m (in the 1-norm), using the LAPACK
8025 * functions dpotrf() and dpocon().
8026 *
8027 * Returns: the estimate, or #NADBL on failure to allocate memory.
8028 */
8029
gretl_symmetric_matrix_rcond(const gretl_matrix * m,int * err)8030 double gretl_symmetric_matrix_rcond (const gretl_matrix *m, int *err)
8031 {
8032 gretl_matrix *a = NULL;
8033 char uplo = 'L';
8034 integer n, lda;
8035 integer info, *iwork = NULL;
8036 double *work = NULL;
8037 double rcond = NADBL;
8038
8039 *err = 0;
8040
8041 if (gretl_is_null_matrix(m)) {
8042 return NADBL;
8043 }
8044
8045 n = m->rows;
8046 lda = m->rows;
8047
8048 a = gretl_matrix_copy_tmp(m);
8049 work = malloc((3 * n) * sizeof *work);
8050 iwork = malloc(n * sizeof *iwork);
8051
8052 if (a == NULL || work == NULL || iwork == NULL) {
8053 *err = E_ALLOC;
8054 goto bailout;
8055 }
8056
8057 dpotrf_(&uplo, &n, a->val, &n, &info);
8058
8059 if (info != 0) {
8060 fprintf(stderr, "gretl_symmetric_matrix_rcond: "
8061 "dpotrf failed with info = %d (n = %d)\n", (int) info, (int) n);
8062 rcond = 0.0;
8063 } else {
8064 double anorm = gretl_matrix_one_norm(m);
8065
8066 dpocon_(&uplo, &n, a->val, &lda, &anorm, &rcond, work, iwork, &info);
8067 if (info != 0) {
8068 *err = 1;
8069 rcond = NADBL;
8070 }
8071 }
8072
8073 bailout:
8074
8075 free(work);
8076 free(iwork);
8077 gretl_matrix_free(a);
8078
8079 return rcond;
8080 }
8081
8082 /**
8083 * gretl_matrix_rcond:
8084 * @m: matrix to examine.
8085 * @err: location to receive error code.
8086 *
8087 * Estimates the reciprocal condition number of the real
8088 * matrix @m (in the 1-norm).
8089 *
8090 * Returns: the estimate, or #NADBL on failure to allocate memory.
8091 */
8092
gretl_matrix_rcond(const gretl_matrix * m,int * err)8093 double gretl_matrix_rcond (const gretl_matrix *m, int *err)
8094 {
8095 return gretl_general_matrix_rcond(m, err);
8096 }
8097
8098 /**
8099 * gretl_matrix_cond_index:
8100 * @m: matrix to examine.
8101 * @err: location to receive error code.
8102 *
8103 * Estimates the condition number (a la Belsley) of the real
8104 * matrix @m.
8105 *
8106 * Returns: the estimate, or #NADBL on failure.
8107 */
8108
gretl_matrix_cond_index(const gretl_matrix * m,int * err)8109 double gretl_matrix_cond_index (const gretl_matrix *m, int *err)
8110 {
8111 gretl_matrix *X, *XX, *v;
8112 double xij, den, cidx = NADBL;
8113 int i, j, r, c;
8114
8115 if (gretl_is_null_matrix(m)) {
8116 return NADBL;
8117 }
8118
8119 r = m->rows;
8120 c = m->cols;
8121
8122 X = gretl_matrix_alloc(r, c);
8123 XX = gretl_matrix_alloc(c, c);
8124
8125 if (X == NULL || XX == NULL) {
8126 gretl_matrix_free(X);
8127 gretl_matrix_free(XX);
8128 *err = E_ALLOC;
8129 return NADBL;
8130 }
8131
8132 /* normalize columns of @m into X */
8133 for (j=0; j<c; j++) {
8134 den = 0.0;
8135 for (i=0; i<r; i++) {
8136 xij = gretl_matrix_get(m, i, j);
8137 den += xij * xij;
8138 }
8139 den = sqrt(den);
8140 for (i=0; i<r; i++) {
8141 xij = gretl_matrix_get(m, i, j);
8142 gretl_matrix_set(X, i, j, xij / den);
8143 }
8144 }
8145
8146 /* form X'X */
8147 gretl_matrix_multiply_mod(X, GRETL_MOD_TRANSPOSE,
8148 X, GRETL_MOD_NONE,
8149 XX, GRETL_MOD_NONE);
8150
8151 v = gretl_symmetric_matrix_eigenvals(XX, 0, err);
8152
8153 if (!*err) {
8154 cidx = sqrt(v->val[c-1] / v->val[0]);
8155 }
8156
8157 gretl_matrix_free(X);
8158 gretl_matrix_free(XX);
8159 gretl_matrix_free(v);
8160
8161 return cidx;
8162 }
8163
8164 /**
8165 * gretl_matrix_cholesky_decomp:
8166 * @a: matrix to operate on.
8167 *
8168 * Computes the Cholesky factorization of the symmetric,
8169 * positive definite matrix @a. On exit the lower triangle of
8170 * @a is replaced by the factor L, as in a = LL', and the
8171 * upper triangle is set to zero. Uses the lapack function
8172 * dpotrf.
8173 *
8174 * Returns: 0 on success; 1 on failure.
8175 */
8176
gretl_matrix_cholesky_decomp(gretl_matrix * a)8177 int gretl_matrix_cholesky_decomp (gretl_matrix *a)
8178 {
8179 char uplo = 'L';
8180 integer n, lda;
8181 integer info;
8182 int err = 0;
8183
8184 if (gretl_is_null_matrix(a)) {
8185 return E_DATA;
8186 }
8187
8188 n = lda = a->rows;
8189
8190 if (a->cols != n) {
8191 return E_NONCONF;
8192 }
8193
8194 dpotrf_(&uplo, &n, a->val, &lda, &info);
8195
8196 if (info != 0) {
8197 fprintf(stderr, "gretl_matrix_cholesky_decomp: info = %d\n",
8198 (int) info);
8199 err = (info > 0)? E_NOTPD : E_DATA;
8200 } else {
8201 gretl_matrix_zero_upper(a);
8202 }
8203
8204 return err;
8205 }
8206
process_psd_root(gretl_matrix * L,const gretl_matrix * A,integer rank,integer * piv)8207 static int process_psd_root (gretl_matrix *L,
8208 const gretl_matrix *A,
8209 integer rank,
8210 integer *piv)
8211 {
8212 gretl_matrix *LL = NULL;
8213 double toler = 1.0e-8;
8214 int i, j, n = L->rows;
8215 int err = 0;
8216
8217 LL = gretl_matrix_alloc(n, n);
8218
8219 if (LL == NULL) {
8220 err = E_ALLOC;
8221 } else {
8222 /* form LL' and compare with A to see if @L is
8223 really a viable factor
8224 */
8225 double dj, dmax = 0;
8226
8227 gretl_matrix_multiply_mod(L, GRETL_MOD_NONE,
8228 L, GRETL_MOD_TRANSPOSE,
8229 LL, GRETL_MOD_NONE);
8230 for (j=0; j<n; j++) {
8231 dj = 0.0;
8232 for (i=0; i<n; i++) {
8233 dj += fabs(gretl_matrix_get(LL, i, j) - gretl_matrix_get(A, i, j));
8234 }
8235 if (dj > dmax) {
8236 dmax = dj;
8237 }
8238 }
8239
8240 if (dmax > toler) {
8241 gretl_errmsg_sprintf("psdroot: norm-test of %g exceeds tolerance (%g)",
8242 dmax, toler);
8243 err = E_DATA;
8244 }
8245
8246 gretl_matrix_free(LL);
8247 }
8248
8249 return err;
8250 }
8251
8252 /* PSD cholesky-type factor via the simple algorithm from
8253 Golub and Van Loan.
8254 */
8255
real_psd_root(gretl_matrix * a,const gretl_matrix * a0)8256 static int real_psd_root (gretl_matrix *a, const gretl_matrix *a0)
8257 {
8258 double d, x1, x2, x3;
8259 int i, j, k, n = a->rows;
8260 int err = 0;
8261
8262 /* Golub and Van Loan, algorithm 4.2.11 */
8263
8264 for (k=0; k<n && !err; k++) {
8265 d = gretl_matrix_get(a, k, k);
8266 if (d > 0) {
8267 d = sqrt(d);
8268 gretl_matrix_set(a, k, k, d);
8269 for (i=k+1; i<n; i++) {
8270 x1 = gretl_matrix_get(a, i, k);
8271 gretl_matrix_set(a, i, k, x1 / d);
8272 }
8273 for (j=k+1; j<n; j++) {
8274 x1 = gretl_matrix_get(a, j, k);
8275 for (i=j; i<n; i++) {
8276 x2 = gretl_matrix_get(a, i, j);
8277 x3 = gretl_matrix_get(a, i, k);
8278 gretl_matrix_set(a, i, j, x2 - x3 * x1);
8279 }
8280 }
8281 } else {
8282 if (a0 == NULL && d < -1.0e-8) {
8283 /* Since we can't perform the check against a0, we'll
8284 reject a matrix that has a "significantly" negative
8285 diagonal element.
8286 */
8287 fprintf(stderr, "psdroot: diag[%d] = %g\n", k+1, d);
8288 err = E_DATA;
8289 }
8290 for (i=k; i<n; i++) {
8291 gretl_matrix_set(a, i, k, 0.0);
8292 }
8293 }
8294 }
8295
8296 gretl_matrix_zero_triangle(a, 'U');
8297
8298 if (!err && a0 != NULL) {
8299 err = process_psd_root(a, a0, 0, NULL);
8300 }
8301
8302 return err;
8303 }
8304
8305 /**
8306 * gretl_matrix_psd_root:
8307 * @a: matrix to operate on.
8308 * @check: if non-zero, perform a test for psd status.
8309 *
8310 * Computes the LL' factorization of the symmetric,
8311 * positive semidefinite matrix @a. On successful exit
8312 * the lower triangle of @a is replaced by the factor L
8313 * and the upper triangle is set to zero.
8314 *
8315 * Returns: 0 on success; non-zero on failure.
8316 */
8317
gretl_matrix_psd_root(gretl_matrix * a,int check)8318 int gretl_matrix_psd_root (gretl_matrix *a, int check)
8319 {
8320 gretl_matrix *a0 = NULL;
8321 int err = 0;
8322
8323 if (gretl_is_null_matrix(a) || a->rows != a->cols) {
8324 return E_DATA;
8325 }
8326
8327 if (check) {
8328 /* make a copy of @a so we can test for its
8329 supposed psd attribute
8330 */
8331 a0 = gretl_matrix_copy(a);
8332 if (a0 == NULL) {
8333 return E_ALLOC;
8334 }
8335 }
8336
8337 err = real_psd_root(a, a0);
8338 gretl_matrix_free(a0);
8339
8340 return err;
8341 }
8342
gretl_matrix_QR_pivot_decomp(gretl_matrix * M,gretl_matrix * R,int ** order)8343 int gretl_matrix_QR_pivot_decomp (gretl_matrix *M, gretl_matrix *R,
8344 int **order)
8345 {
8346 integer m = M->rows;
8347 integer n = M->cols;
8348 integer info = 0;
8349 integer lwork = -1;
8350 integer lda = m;
8351 integer *iwork = NULL;
8352 double *tau = NULL;
8353 double *work = NULL;
8354 integer *jpvt = NULL;
8355 int i, j;
8356 int moved = 0;
8357 int err = 0;
8358
8359 if (R == NULL || R->rows != n || R->cols != n) {
8360 return E_NONCONF;
8361 }
8362
8363 fprintf(stderr, "QR decomp: allowing for pivoting\n");
8364
8365 /* dim of tau is min (m, n) */
8366 tau = malloc(n * sizeof *tau);
8367 work = lapack_malloc(sizeof *work);
8368 iwork = malloc(n * sizeof *iwork);
8369
8370 if (tau == NULL || work == NULL || iwork == NULL) {
8371 err = E_ALLOC;
8372 goto bailout;
8373 }
8374
8375 /* pivot array */
8376 jpvt = malloc(n * sizeof *jpvt);
8377 if (jpvt == NULL) {
8378 err = E_ALLOC;
8379 goto bailout;
8380 }
8381
8382 for (i=0; i<n; i++) {
8383 jpvt[i] = 0;
8384 }
8385
8386 /* workspace size query */
8387 dgeqp3_(&m, &n, M->val, &lda, jpvt, tau, work, &lwork, &info);
8388 if (info != 0) {
8389 fprintf(stderr, "dgeqp3: info = %d\n", (int) info);
8390 err = 1;
8391 goto bailout;
8392 }
8393
8394 /* optimally sized work array */
8395 lwork = (integer) work[0];
8396 work = lapack_realloc(work, (size_t) lwork * sizeof *work);
8397 if (work == NULL) {
8398 err = E_ALLOC;
8399 goto bailout;
8400 }
8401
8402 /* run actual QR factorization */
8403 dgeqp3_(&m, &n, M->val, &lda, jpvt, tau, work, &lwork, &info);
8404 if (info != 0) {
8405 fprintf(stderr, "dgeqp3: info = %d\n", (int) info);
8406 err = 1;
8407 goto bailout;
8408 }
8409
8410 /* copy the upper triangular R out of M */
8411 for (i=0; i<n; i++) {
8412 for (j=0; j<n; j++) {
8413 if (i <= j) {
8414 gretl_matrix_set(R, i, j,
8415 gretl_matrix_get(M, i, j));
8416 } else {
8417 gretl_matrix_set(R, i, j, 0.0);
8418 }
8419 }
8420 }
8421
8422 /* obtain the real "Q" matrix (in M) */
8423 dorgqr_(&m, &n, &n, M->val, &lda, tau, work, &lwork, &info);
8424 if (info != 0) {
8425 fprintf(stderr, "dorgqr: info = %d\n", (int) info);
8426 err = 1;
8427 goto bailout;
8428 }
8429
8430 bailout:
8431
8432 free(tau);
8433 lapack_free(work);
8434 free(iwork);
8435
8436 for (i=0; i<n; i++) {
8437 if (jpvt[i] != i + 1) {
8438 moved = 1;
8439 }
8440 }
8441
8442 if (moved && order != NULL) {
8443 *order = malloc(n * sizeof **order);
8444 if (*order == NULL) {
8445 err = E_ALLOC;
8446 } else {
8447 for (i=0; i<n; i++) {
8448 (*order)[i] = jpvt[i] - 1;
8449 }
8450 }
8451 }
8452
8453 free(jpvt);
8454
8455 return err;
8456 }
8457
8458 /**
8459 * gretl_matrix_QR_decomp:
8460 * @M: m x n matrix to be decomposed.
8461 * @R: n x n matrix into which to write R, as in M = Q * R,
8462 * or NULL if this is not wanted.
8463 *
8464 * Computes the QR factorization of @M. On successful exit
8465 * the matrix @M holds Q, and, if @R is not NULL, the upper
8466 * triangle of @R holds R. Uses the LAPACK functions
8467 * dgeqrf() and dorgqr().
8468 *
8469 * Returns: 0 on success, non-zero on failure.
8470 */
8471
gretl_matrix_QR_decomp(gretl_matrix * M,gretl_matrix * R)8472 int gretl_matrix_QR_decomp (gretl_matrix *M, gretl_matrix *R)
8473 {
8474 integer m, n, lda;
8475 integer info = 0;
8476 integer lwork = -1;
8477 double *tau = NULL;
8478 double *work = NULL;
8479 int i, j;
8480 int err = 0;
8481
8482 if (gretl_is_null_matrix(M)) {
8483 return E_DATA;
8484 }
8485
8486 lda = m = M->rows;
8487 n = M->cols;
8488
8489 if (n > m) {
8490 return E_NONCONF;
8491 }
8492
8493 if (R != NULL && (R->rows != n || R->cols != n)) {
8494 return E_NONCONF;
8495 }
8496
8497 /* dim of tau is min (m, n) */
8498 tau = malloc(n * sizeof *tau);
8499 work = lapack_malloc(sizeof *work);
8500
8501 if (tau == NULL || work == NULL) {
8502 err = E_ALLOC;
8503 goto bailout;
8504 }
8505
8506 /* workspace size query */
8507 dgeqrf_(&m, &n, M->val, &lda, tau, work, &lwork, &info);
8508 if (info != 0) {
8509 fprintf(stderr, "dgeqrf: info = %d\n", (int) info);
8510 err = 1;
8511 goto bailout;
8512 }
8513
8514 /* optimally sized work array */
8515 lwork = (integer) work[0];
8516 work = lapack_realloc(work, (size_t) lwork * sizeof *work);
8517 if (work == NULL) {
8518 err = E_ALLOC;
8519 goto bailout;
8520 }
8521
8522 /* run actual QR factorization */
8523 dgeqrf_(&m, &n, M->val, &lda, tau, work, &lwork, &info);
8524 if (info != 0) {
8525 fprintf(stderr, "dgeqrf: info = %d\n", (int) info);
8526 err = 1;
8527 goto bailout;
8528 }
8529
8530 if (R != NULL) {
8531 /* copy the upper triangular R out of M */
8532 double x;
8533
8534 for (i=0; i<n; i++) {
8535 for (j=0; j<n; j++) {
8536 if (i <= j) {
8537 x = gretl_matrix_get(M, i, j);
8538 gretl_matrix_set(R, i, j, x);
8539 } else {
8540 gretl_matrix_set(R, i, j, 0.0);
8541 }
8542 }
8543 }
8544 }
8545
8546 /* obtain the real "Q" matrix (in M) */
8547 dorgqr_(&m, &n, &n, M->val, &lda, tau, work, &lwork, &info);
8548 if (info != 0) {
8549 fprintf(stderr, "dorgqr: info = %d\n", (int) info);
8550 err = 1;
8551 goto bailout;
8552 }
8553
8554 bailout:
8555
8556 free(tau);
8557 lapack_free(work);
8558
8559 return err;
8560 }
8561
get_R_rank(const gretl_matrix * R)8562 static int get_R_rank (const gretl_matrix *R)
8563 {
8564 double d;
8565 int i, rank = R->rows;
8566
8567 #if 0
8568 gretl_matrix_print(R, "R, in get_R_rank");
8569 #endif
8570
8571 for (i=0; i<R->rows; i++) {
8572 d = gretl_matrix_get(R, i, i);
8573 if (isnan(d) || isinf(d) || fabs(d) < R_DIAG_MIN) {
8574 rank--;
8575 }
8576 }
8577
8578 return rank;
8579 }
8580
8581 /**
8582 * gretl_check_QR_rank:
8583 * @R: matrix R from QR decomposition.
8584 * @err: location to receive error code.
8585 * @rcnd: location to receive reciprocal condition number.
8586 *
8587 * Checks the reciprocal condition number of R and calculates
8588 * the rank of the matrix QR. If @rcnd is not NULL it receives
8589 * the reciprocal condition number.
8590 *
8591 * Returns: on success, the rank of QR.
8592 */
8593
gretl_check_QR_rank(const gretl_matrix * R,int * err,double * rcnd)8594 int gretl_check_QR_rank (const gretl_matrix *R, int *err, double *rcnd)
8595 {
8596 integer *iwork = NULL;
8597 double *work = NULL;
8598 integer n, info = 0;
8599 double rcond;
8600 char uplo = 'U';
8601 char diag = 'N';
8602 char norm = '1';
8603 int rank;
8604
8605 if (gretl_is_null_matrix(R)) {
8606 *err = E_DATA;
8607 return 0;
8608 }
8609
8610 *err = 0;
8611
8612 rank = n = R->rows;
8613 work = lapack_malloc(3 * n * sizeof *work);
8614 iwork = malloc(n * sizeof *iwork);
8615
8616 if (work == NULL || iwork == NULL) {
8617 *err = E_ALLOC;
8618 goto bailout;
8619 }
8620
8621 dtrcon_(&norm, &uplo, &diag, &n, R->val, &n, &rcond, work,
8622 iwork, &info);
8623
8624 if (info != 0) {
8625 fprintf(stderr, "dtrcon: info = %d\n", (int) info);
8626 *err = 1;
8627 goto bailout;
8628 }
8629
8630 if (rcond < QR_RCOND_MIN) {
8631 fprintf(stderr, "gretl_matrix_QR_rank: rcond = %g\n", rcond);
8632 rank = get_R_rank(R);
8633 }
8634 #if 0
8635 else if (rcond < QR_RCOND_WARN) {
8636 fprintf(stderr, "QR warning: rcond = %g\n", rcond);
8637 }
8638 #endif
8639
8640 if (rcnd != NULL) {
8641 *rcnd = rcond;
8642 }
8643
8644 bailout:
8645
8646 lapack_free(work);
8647 free(iwork);
8648
8649 return rank;
8650 }
8651
svd_smin(const gretl_matrix * a,double smax)8652 static double svd_smin (const gretl_matrix *a, double smax)
8653 {
8654 const double macheps = 2.20e-16;
8655 int dmax = (a->rows > a->cols)? a->rows : a->cols;
8656
8657 /* as per numpy, Matlab (2015-09-28) */
8658 return dmax * macheps * smax;
8659 }
8660
8661 static int real_gretl_matrix_SVD (const gretl_matrix *x,
8662 gretl_matrix **pu,
8663 gretl_vector **ps,
8664 gretl_matrix **pvt,
8665 int full);
8666
8667 /**
8668 * gretl_matrix_rank:
8669 * @a: matrix to examine.
8670 * @err: location to receive error code on failure.
8671 *
8672 * Computes the rank of @a via its SV decomposition.
8673 *
8674 * Returns: the rank of @a, or 0 on failure.
8675 */
8676
gretl_matrix_rank(const gretl_matrix * a,int * err)8677 int gretl_matrix_rank (const gretl_matrix *a, int *err)
8678 {
8679 gretl_matrix *s = NULL;
8680 int i, k, rank = 0;
8681
8682 if (gretl_is_null_matrix(a)) {
8683 return 0;
8684 }
8685
8686 k = (a->rows < a->cols)? a->rows : a->cols;
8687
8688 if (a->rows > 4 * k || a->cols > 4 * k) {
8689 gretl_matrix *b = gretl_matrix_alloc(k, k);
8690 GretlMatrixMod mod1, mod2;
8691
8692 mod1 = a->rows > k ? GRETL_MOD_TRANSPOSE : 0;
8693 mod2 = a->cols > k ? GRETL_MOD_TRANSPOSE : 0;
8694 gretl_matrix_multiply_mod(a, mod1, a, mod2, b, 0);
8695 *err = real_gretl_matrix_SVD(b, NULL, &s, NULL, 0);
8696 gretl_matrix_free(b);
8697 } else {
8698 *err = real_gretl_matrix_SVD(a, NULL, &s, NULL, 0);
8699 }
8700
8701 if (!*err) {
8702 double smin = svd_smin(a, s->val[0]);
8703
8704 for (i=0; i<k; i++) {
8705 if (s->val[i] > smin) {
8706 rank++;
8707 }
8708 }
8709 }
8710
8711 gretl_matrix_free(s);
8712
8713 return rank;
8714 }
8715
8716 /**
8717 * gretl_invert_triangular_matrix:
8718 * @a: triangular matrix to invert.
8719 * @uplo: 'L' for lower triangular @a, 'U' for upper.
8720 *
8721 * Computes the inverse of a triangular matrix. On exit
8722 * @a is overwritten with the inverse. Uses the lapack
8723 * function dtrtri.
8724 *
8725 * Returns: 0 on success; non-zero error code on failure.
8726 */
8727
gretl_invert_triangular_matrix(gretl_matrix * a,char uplo)8728 int gretl_invert_triangular_matrix (gretl_matrix *a, char uplo)
8729 {
8730 char diag = 'N';
8731 integer n, info = 0;
8732 int err = 0;
8733
8734 if (gretl_is_null_matrix(a)) {
8735 return E_DATA;
8736 }
8737
8738 n = a->rows;
8739
8740 if (a->rows != a->cols) {
8741 return E_NONCONF;
8742 }
8743
8744 dtrtri_(&uplo, &diag, &n, a->val, &n, &info);
8745
8746 if (info < 0) {
8747 err = E_DATA;
8748 } else if (info > 0) {
8749 err = E_SINGULAR;
8750 }
8751
8752 return err;
8753 }
8754
8755 /**
8756 * gretl_invert_general_matrix:
8757 * @a: matrix to invert.
8758 *
8759 * Computes the inverse of a general matrix using LU
8760 * factorization. On exit @a is overwritten with the inverse.
8761 * Uses the LAPACK functions dgetrf() and dgetri().
8762 *
8763 * Returns: 0 on success; non-zero error code on failure.
8764 */
8765
gretl_invert_general_matrix(gretl_matrix * a)8766 int gretl_invert_general_matrix (gretl_matrix *a)
8767 {
8768 integer n;
8769 integer info;
8770 integer lwork;
8771 integer *ipiv;
8772 double *work;
8773 int err = 0;
8774
8775 if (gretl_is_null_matrix(a) || (a->rows != a->cols)) {
8776 return E_DATA;
8777 }
8778
8779 n = a->rows;
8780
8781 ipiv = malloc(n * sizeof *ipiv);
8782 if (ipiv == NULL) {
8783 return E_ALLOC;
8784 }
8785
8786 work = lapack_malloc(sizeof *work);
8787 if (work == NULL) {
8788 free(ipiv);
8789 return E_ALLOC;
8790 }
8791
8792 dgetrf_(&n, &n, a->val, &n, ipiv, &info);
8793
8794 if (info != 0) {
8795 free(ipiv);
8796 fprintf(stderr, "dgetrf: matrix is singular (info=%d)\n", info);
8797 return E_SINGULAR;
8798 } else {
8799 pivot_check(ipiv, n);
8800 }
8801
8802 lwork = -1;
8803 dgetri_(&n, a->val, &n, ipiv, work, &lwork, &info);
8804
8805 if (info != 0 || work[0] <= 0.0) {
8806 free(ipiv);
8807 return wspace_fail(info, work[0]);
8808 }
8809
8810 lwork = (integer) work[0];
8811
8812 #ifdef LAPACK_DEBUG
8813 printf("dgetri: workspace = %d\n", (int) lwork);
8814 #endif
8815
8816 work = lapack_realloc(work, lwork * sizeof *work);
8817 if (work == NULL) {
8818 free(ipiv);
8819 return E_ALLOC;
8820 }
8821
8822 dgetri_(&n, a->val, &n, ipiv, work, &lwork, &info);
8823
8824 #ifdef LAPACK_DEBUG
8825 printf("dgetri: info = %d\n", (int) info);
8826 #endif
8827
8828 lapack_free(work);
8829 free(ipiv);
8830
8831 if (info != 0) {
8832 fprintf(stderr, "dgetri: matrix is singular\n");
8833 err = E_SINGULAR;
8834 }
8835
8836 return err;
8837 }
8838
8839 /**
8840 * gretl_matrix_mirror:
8841 * @m: matrix to expand.
8842 * @uplo: 'L' or 'U'.
8843 *
8844 * If @uplo = 'L', copy the lower triangle of @m into
8845 * the upper triangle; or if @uplo = 'U' copy the upper
8846 * triangle into the lower, in either case producing a
8847 * symmetric result.
8848 *
8849 * Returns: 0 on success; non-zero error code if @m is
8850 * not square.
8851 */
8852
gretl_matrix_mirror(gretl_matrix * m,char uplo)8853 int gretl_matrix_mirror (gretl_matrix *m, char uplo)
8854 {
8855 int i, j, n;
8856 double x;
8857
8858 if (m->cols != m->rows) {
8859 fputs("gretl_matrix_mirror: input is not square\n",
8860 stderr);
8861 return 1;
8862 }
8863
8864 n = m->rows;
8865
8866 for (i=0; i<n; i++) {
8867 for (j=i+1; j<n; j++) {
8868 if (uplo == 'U') {
8869 x = gretl_matrix_get(m, i, j);
8870 gretl_matrix_set(m, j, i, x);
8871 } else {
8872 x = gretl_matrix_get(m, j, i);
8873 gretl_matrix_set(m, i, j, x);
8874 }
8875 }
8876 }
8877
8878 return 0;
8879 }
8880
8881 /**
8882 * gretl_invert_diagonal_matrix:
8883 * @a: matrix to invert.
8884 *
8885 * Computes the inverse of a diagonal matrix.
8886 * On exit @a is overwritten with the inverse.
8887 *
8888 * Returns: 0 on success; non-zero error code on failure.
8889 */
8890
gretl_invert_diagonal_matrix(gretl_matrix * a)8891 int gretl_invert_diagonal_matrix (gretl_matrix *a)
8892 {
8893 double x;
8894 int i;
8895
8896 if (gretl_is_null_matrix(a)) {
8897 return E_DATA;
8898 }
8899
8900 if (a->cols != a->rows) {
8901 fputs("gretl_invert_diagonal_matrix: input is not square\n",
8902 stderr);
8903 return E_NONCONF;
8904 }
8905
8906 for (i=0; i<a->rows; i++) {
8907 if (gretl_matrix_get(a, i, i) == 0.0) {
8908 return E_SINGULAR;
8909 }
8910 }
8911
8912 for (i=0; i<a->rows; i++) {
8913 x = gretl_matrix_get(a, i, i);
8914 gretl_matrix_set(a, i, i, 1.0 / x);
8915 }
8916
8917 return 0;
8918 }
8919
8920 /**
8921 * gretl_invert_matrix:
8922 * @a: matrix to invert.
8923 *
8924 * Computes the inverse of matrix @a: on exit @a is
8925 * overwritten with the inverse. If @a is diagonal
8926 * or symmetric, appropriate simple inversion routines
8927 * are called.
8928 *
8929 * Returns: 0 on success; non-zero error code on failure.
8930 */
8931
gretl_invert_matrix(gretl_matrix * a)8932 int gretl_invert_matrix (gretl_matrix *a)
8933 {
8934 int s, err = 0;
8935
8936 if (gretl_is_null_matrix(a)) {
8937 return E_DATA;
8938 }
8939
8940 s = gretl_matrix_get_structure(a);
8941
8942 if (s == GRETL_MATRIX_IDENTITY) {
8943 return 0;
8944 } else if (s == GRETL_MATRIX_DIAGONAL) {
8945 err = gretl_invert_diagonal_matrix(a);
8946 } else if (s == GRETL_MATRIX_SYMMETRIC) {
8947 err = real_invert_symmetric_matrix(a, 1, 0);
8948 if (err) {
8949 err = gretl_invert_symmetric_indef_matrix(a);
8950 }
8951 } else if (s == GRETL_MATRIX_LOWER_TRIANGULAR) {
8952 err = gretl_invert_triangular_matrix(a, 'L');
8953 } else if (s == GRETL_MATRIX_UPPER_TRIANGULAR) {
8954 err = gretl_invert_triangular_matrix(a, 'U');
8955 } else if (s >= GRETL_MATRIX_SQUARE) {
8956 err = gretl_invert_general_matrix(a);
8957 } else {
8958 err = E_NONCONF;
8959 }
8960
8961 return err;
8962 }
8963
8964 #define RS_RCOND_MIN 1.0e-15
8965
8966 /**
8967 * gretl_invert_symmetric_indef_matrix:
8968 * @a: matrix to invert.
8969 *
8970 * Computes the inverse of a real symmetric matrix via the
8971 * Bunch-Kaufman diagonal pivoting method. Uses the LAPACK
8972 * functions dsytrf() and dsytri(). On exit @a is overwritten
8973 * with the inverse.
8974 *
8975 * Returns: 0 on success; non-zero error code on failure.
8976 */
8977
gretl_invert_symmetric_indef_matrix(gretl_matrix * a)8978 int gretl_invert_symmetric_indef_matrix (gretl_matrix *a)
8979 {
8980 char uplo = 'U';
8981 integer n, info;
8982 integer *ipiv;
8983 integer *iwork;
8984 integer lwork = -1;
8985 double anorm, rcond;
8986 double *work;
8987 int err = 0;
8988
8989 if (gretl_is_null_matrix(a)) {
8990 return E_DATA;
8991 }
8992
8993 if (a->cols != a->rows) {
8994 fputs("gretl_invert_symmetric_indef_matrix: input is not square\n",
8995 stderr);
8996 return E_NONCONF;
8997 }
8998
8999 n = a->rows;
9000 ipiv = malloc(n * sizeof *ipiv);
9001 iwork = malloc(n * sizeof *iwork);
9002 work = lapack_malloc(sizeof *work);
9003
9004 if (ipiv == NULL || iwork == NULL || work == NULL) {
9005 err = E_ALLOC;
9006 goto bailout;
9007 }
9008
9009 anorm = gretl_matrix_one_norm(a);
9010
9011 /* workspace query */
9012 dsytrf_(&uplo, &n, a->val, &n, ipiv, work, &lwork, &info);
9013 if (info != 0 || work[0] <= 0.0) {
9014 err = wspace_fail(info, work[0]);
9015 goto bailout;
9016 }
9017
9018 lwork = (integer) work[0];
9019 #ifdef LAPACK_DEBUG
9020 printf("dsytrf: workspace = %d\n", (int) lwork);
9021 #endif
9022
9023 if (lwork < 2 * n) {
9024 lwork = 2 * n;
9025 }
9026
9027 work = lapack_realloc(work, lwork * sizeof *work);
9028 if (work == NULL) {
9029 err = E_ALLOC;
9030 goto bailout;
9031 }
9032
9033 /* decompose */
9034 dsytrf_(&uplo, &n, a->val, &n, ipiv, work, &lwork, &info);
9035 if (info != 0) {
9036 fprintf(stderr, "dsytrf: matrix is singular\n");
9037 err = E_SINGULAR;
9038 goto bailout;
9039 }
9040
9041 /* check condition number */
9042 dsycon_(&uplo, &n, a->val, &n, ipiv, &anorm, &rcond,
9043 work, iwork, &info);
9044 if (info != 0) {
9045 fprintf(stderr, "dsycon: info = %d\n", (int) info);
9046 err = 1;
9047 goto bailout;
9048 } else if (rcond < RS_RCOND_MIN) {
9049 fprintf(stderr, "dsycon: rcond = %g\n", rcond);
9050 err = E_SINGULAR;
9051 goto bailout;
9052 }
9053
9054 /* invert */
9055 dsytri_(&uplo, &n, a->val, &n, ipiv, work, &info);
9056
9057 #ifdef LAPACK_DEBUG
9058 printf("dsytri: info = %d\n", (int) info);
9059 #endif
9060
9061 bailout:
9062
9063 lapack_free(work);
9064 free(ipiv);
9065 free(iwork);
9066
9067 if (!err) {
9068 if (info != 0) {
9069 fputs("dsytri: matrix is singular\n", stderr);
9070 err = E_SINGULAR;
9071 } else {
9072 gretl_matrix_mirror(a, uplo);
9073 }
9074 }
9075
9076 return err;
9077 }
9078
real_invert_symmetric_matrix(gretl_matrix * a,int checked,int verbose)9079 static int real_invert_symmetric_matrix (gretl_matrix *a,
9080 int checked,
9081 int verbose)
9082 {
9083 integer n, info;
9084 double *aval = NULL;
9085 size_t bytes;
9086 char uplo = 'L';
9087 int err = 0;
9088
9089 if (gretl_is_null_matrix(a)) {
9090 return E_DATA;
9091 }
9092
9093 if (a->cols != a->rows) {
9094 fputs("real_invert_symmetric_matrix: input is not square\n",
9095 stderr);
9096 return E_NONCONF;
9097 }
9098
9099 n = a->cols;
9100
9101 if (n == 1) {
9102 a->val[0] = 1.0 / a->val[0];
9103 return 0;
9104 }
9105
9106 if (!checked && !real_gretl_matrix_is_symmetric(a, 1)) {
9107 fputs("real_invert_symmetric_matrix: matrix is not symmetric\n", stderr);
9108 return E_NOTPD;
9109 }
9110
9111 /* back-up, just in case */
9112 bytes = n * n * sizeof *aval;
9113 aval = lapack_malloc(bytes);
9114 if (aval == NULL) {
9115 return E_ALLOC;
9116 }
9117
9118 memcpy(aval, a->val, bytes);
9119
9120 dpotrf_(&uplo, &n, a->val, &n, &info);
9121
9122 if (info != 0) {
9123 err = (info > 0)? E_NOTPD : E_DATA;
9124 if (err == E_DATA || verbose) {
9125 fprintf(stderr, "real_invert_symmetric_matrix: "
9126 "dpotrf failed with info = %d (n = %d)\n",
9127 (int) info, (int) n);
9128 }
9129 }
9130
9131 if (!err) {
9132 dpotri_(&uplo, &n, a->val, &n, &info);
9133 if (info != 0) {
9134 err = E_NOTPD;
9135 fprintf(stderr, "real_invert_symmetric_matrix:\n"
9136 " dpotri failed with info = %d\n", (int) info);
9137 } else {
9138 gretl_matrix_mirror(a, uplo);
9139 }
9140 }
9141
9142 if (err) {
9143 memcpy(a->val, aval, bytes);
9144 if (getenv("GRETL_MATRIX_DEBUG")) {
9145 gretl_matrix_print(a, "input matrix");
9146 }
9147 }
9148
9149 lapack_free(aval);
9150
9151 return err;
9152 }
9153
9154 /**
9155 * gretl_invert_symmetric_matrix:
9156 * @a: matrix to invert.
9157 *
9158 * Computes the inverse of a symmetric positive definite matrix
9159 * using Cholesky factorization. On exit @a is overwritten with
9160 * the inverse. Uses the LAPACK functions dpotrf() and dpotri().
9161 *
9162 * Returns: 0 on success; non-zero error code on failure.
9163 */
9164
gretl_invert_symmetric_matrix(gretl_matrix * a)9165 int gretl_invert_symmetric_matrix (gretl_matrix *a)
9166 {
9167 return real_invert_symmetric_matrix(a, 0, 1);
9168 }
9169
9170 /**
9171 * gretl_invpd:
9172 * @a: matrix to invert.
9173 *
9174 * Computes the inverse of a symmetric positive definite matrix
9175 * using Cholesky factorization. On exit @a is overwritten with
9176 * the inverse. Uses the LAPACK functions dpotrf() and dpotri().
9177 * Little checking is done, for speed: we assume the caller
9178 * knows what he's doing.
9179 *
9180 * Returns: 0 on success; non-zero error code on failure.
9181 */
9182
gretl_invpd(gretl_matrix * a)9183 int gretl_invpd (gretl_matrix *a)
9184 {
9185 integer n, info;
9186 char uplo = 'L';
9187 int err = 0;
9188
9189 if (a->cols != a->rows) {
9190 fputs("gretl_invpd: input is not square\n",
9191 stderr);
9192 return E_NONCONF;
9193 }
9194
9195 n = a->cols;
9196
9197 if (n == 1) {
9198 a->val[0] = 1.0 / a->val[0];
9199 return 0;
9200 }
9201
9202 dpotrf_(&uplo, &n, a->val, &n, &info);
9203
9204 if (info != 0) {
9205 fprintf(stderr, "gretl_invpd: "
9206 "dpotrf failed with info = %d (n = %d)\n",
9207 (int) info, (int) n);
9208 err = info > 0 ? E_NOTPD : E_DATA;
9209 }
9210
9211 if (!err) {
9212 dpotri_(&uplo, &n, a->val, &n, &info);
9213 if (info != 0) {
9214 err = E_SINGULAR;
9215 fprintf(stderr, "gretl_invpd:\n"
9216 " dpotri failed with info = %d\n", (int) info);
9217 } else {
9218 gretl_matrix_mirror(a, uplo);
9219 }
9220 }
9221
9222 return err;
9223 }
9224
9225 /**
9226 * gretl_inverse_from_cholesky_decomp:
9227 * @targ: matrix to hold inverse.
9228 * @src: Cholesky-decomposed matrix.
9229 *
9230 * Computes in @targ the inverse of a symmetric positive definite
9231 * matrix, on the assumption that the original matrix this has already
9232 * been Cholesky-decomposed in @src.
9233 *
9234 * Returns: 0 on success; non-zero error code on failure.
9235 */
9236
gretl_inverse_from_cholesky_decomp(gretl_matrix * targ,const gretl_matrix * src)9237 int gretl_inverse_from_cholesky_decomp (gretl_matrix *targ,
9238 const gretl_matrix *src)
9239 {
9240 integer info, n;
9241 char uplo = 'L';
9242 int err = 0;
9243
9244 if (gretl_is_null_matrix(targ) || gretl_is_null_matrix(src)) {
9245 return E_DATA;
9246 }
9247
9248 n = src->cols;
9249
9250 if (n != src->rows || targ->cols != targ->rows || targ->cols != n) {
9251 return E_NONCONF;
9252 }
9253
9254 memcpy(targ->val, src->val, n * n * sizeof *src->val);
9255
9256 dpotri_(&uplo, &n, targ->val, &n, &info);
9257
9258 if (info != 0) {
9259 err = E_SINGULAR;
9260 fprintf(stderr, "gretl_invert_symmetric_matrix:\n"
9261 " dpotri failed with info = %d\n", (int) info);
9262 } else {
9263 gretl_matrix_mirror(targ, uplo);
9264 }
9265
9266 return err;
9267 }
9268
9269 /**
9270 * gretl_invert_symmetric_matrix2:
9271 * @a: matrix to invert.
9272 * @ldet: location to recieve log determinant, or NULL.
9273 *
9274 * Computes the inverse of a symmetric positive definite matrix
9275 * using Cholesky factorization, computing the log-determinant
9276 * in the process. On exit @a is overwritten with the inverse
9277 * and if @ldet is not NULL the log-determinant is written to
9278 * that location. Uses the LAPACK functions dpotrf() and dpotri().
9279 *
9280 * Returns: 0 on success; non-zero error code on failure.
9281 */
9282
gretl_invert_symmetric_matrix2(gretl_matrix * a,double * ldet)9283 int gretl_invert_symmetric_matrix2 (gretl_matrix *a, double *ldet)
9284 {
9285 integer n, info;
9286 char uplo = 'L';
9287 int i, err = 0;
9288
9289 if (gretl_is_null_matrix(a)) {
9290 return E_DATA;
9291 }
9292
9293 if (a->cols != a->rows) {
9294 fputs("gretl_invert_symmetric_matrix: input is not square\n",
9295 stderr);
9296 return E_NONCONF;
9297 }
9298
9299 n = a->cols;
9300
9301 if (n == 1) {
9302 if (ldet != NULL) {
9303 *ldet = log(a->val[0]);
9304 }
9305 a->val[0] = 1.0 / a->val[0];
9306 return 0;
9307 }
9308
9309 if (!real_gretl_matrix_is_symmetric(a, 1)) {
9310 fputs("gretl_invert_symmetric_matrix: matrix is not symmetric\n", stderr);
9311 return 1;
9312 }
9313
9314 dpotrf_(&uplo, &n, a->val, &n, &info);
9315
9316 if (info != 0) {
9317 fprintf(stderr, "gretl_invert_symmetric_matrix2: "
9318 "dpotrf failed with info = %d (n = %d)\n", (int) info, (int) n);
9319 return (info > 0)? E_NOTPD : E_DATA;
9320 }
9321
9322 if (ldet != NULL) {
9323 double x = 0.0;
9324
9325 for (i=0; i<n; i++) {
9326 x += log(gretl_matrix_get(a,i,i));
9327 }
9328 *ldet = 2.0 * x;
9329 }
9330
9331 dpotri_(&uplo, &n, a->val, &n, &info);
9332
9333 if (info != 0) {
9334 err = E_SINGULAR;
9335 fprintf(stderr, "gretl_invert_symmetric_matrix:\n"
9336 " dpotri failed with info = %d\n", (int) info);
9337 } else {
9338 gretl_matrix_mirror(a, uplo);
9339 }
9340
9341 return err;
9342 }
9343
9344 /**
9345 * gretl_invert_packed_symmetric_matrix:
9346 * @v: symmetric matrix in vech form (lower triangle packed
9347 * as a column vector).
9348 *
9349 * Computes the inverse of a symmetric positive definite matrix,
9350 * stored in vech form, using Cholesky factorization. On exit
9351 * @v is overwritten with the lower triangle of the inverse.
9352 * Uses the LAPACK functions dpptrf() and dpptri().
9353 *
9354 * Returns: 0 on success; non-zero error code on failure.
9355 */
9356
gretl_invert_packed_symmetric_matrix(gretl_matrix * v)9357 int gretl_invert_packed_symmetric_matrix (gretl_matrix *v)
9358 {
9359 gretl_matrix *vcpy = NULL;
9360 integer info, n;
9361 char uplo = 'L';
9362 int err = 0;
9363
9364 if (gretl_is_null_matrix(v)) {
9365 return E_DATA;
9366 }
9367
9368 if (v->cols != 1) {
9369 fprintf(stderr, "gretl_invert_packed_symmetric_matrix:\n"
9370 " matrix is not in vech form\n");
9371 return E_DATA;
9372 }
9373
9374 if (v->rows == 1) {
9375 v->val[0] = 1.0 / v->val[0];
9376 return 0;
9377 }
9378
9379 if (v->rows < 100) {
9380 vcpy = gretl_matrix_copy_tmp(v);
9381 }
9382
9383 n = (integer) ((sqrt(1.0 + 8.0 * v->rows) - 1.0) / 2.0);
9384
9385 dpptrf_(&uplo, &n, v->val, &info);
9386
9387 if (info != 0) {
9388 fprintf(stderr, "gretl_invert_packed_symmetric_matrix:\n"
9389 " dpptrf failed with info = %d (n = %d)\n", (int) info, (int) n);
9390 if (info > 0) {
9391 fputs(" matrix is not positive definite\n", stderr);
9392 err = E_NOTPD;
9393 } else {
9394 err = E_DATA;
9395 }
9396 if (vcpy != NULL) {
9397 gretl_matrix_print(vcpy, "input matrix");
9398 }
9399 return err;
9400 }
9401
9402 dpptri_(&uplo, &n, v->val, &info);
9403
9404 if (info != 0) {
9405 err = E_SINGULAR;
9406 fprintf(stderr, "gretl_invert_packed_symmetric_matrix:\n"
9407 " dpptri failed with info = %d\n", (int) info);
9408
9409 }
9410
9411 gretl_matrix_free(vcpy);
9412
9413 return err;
9414 }
9415
dgeev_eigvecs_alloc(gretl_matrix * m,gretl_matrix ** pev,gretl_matrix ** pec,int n)9416 static int dgeev_eigvecs_alloc (gretl_matrix *m,
9417 gretl_matrix **pev,
9418 gretl_matrix **pec,
9419 int n)
9420 {
9421 gretl_matrix *ev = NULL;
9422 gretl_matrix *ec = NULL;
9423
9424 if (pev != NULL) {
9425 /* We need an n x n complex matrix for output:
9426 is @m usable or do we need to allocate a
9427 new matrix?
9428 */
9429 int mrc = m->rows * m->cols;
9430 int dim = n * n;
9431
9432 if (m->is_complex && mrc == dim) {
9433 m->rows = m->cols = n;
9434 } else if (!m->is_complex && mrc == 2*dim) {
9435 m->rows = 2*n;
9436 m->cols = n;
9437 matrix_set_complex(m, 1, 1);
9438 } else {
9439 /* have to allocate */
9440 ev = gretl_cmatrix_new0(n, n);
9441 if (ev == NULL) {
9442 return E_ALLOC;
9443 }
9444 }
9445 }
9446
9447 /* We need an n x n real matrix to pass to lapack
9448 to get the compressed representation of the
9449 eigenvectors
9450 */
9451 ec = gretl_matrix_alloc(n, n);
9452 if (ec == NULL) {
9453 gretl_matrix_free(ev);
9454 return E_ALLOC;
9455 }
9456
9457 if (pev != NULL) {
9458 *pev = ev;
9459 }
9460 *pec = ec;
9461
9462 return 0;
9463 }
9464
9465 /* Transcribe from compact representation of eigenvectors
9466 in the n x n real matrix @src to the "new-style" n x n
9467 complex matrix @targ. What happens for each column
9468 depends on whether the associated eigenvalue is real or
9469 a member of a conjugate pair. The arrays @wr and @wi
9470 hold the real and imaginary parts of the eigenvalues,
9471 respectively.
9472 */
9473
dgeev_eigvecs_transcribe(gretl_matrix * targ,gretl_matrix * src,double * wr,double * wi)9474 static void dgeev_eigvecs_transcribe (gretl_matrix *targ,
9475 gretl_matrix *src,
9476 double *wr, double *wi)
9477 {
9478 double re, im;
9479 int i, j, isreal;
9480 int n = src->rows;
9481
9482 for (j=0; j<n; j++) {
9483 isreal = (wi[j] == 0);
9484 for (i=0; i<n; i++) {
9485 re = gretl_matrix_get(src, i, j);
9486 if (isreal) {
9487 /* lambda(j) is real */
9488 gretl_cmatrix_set(targ, i, j, re);
9489 } else {
9490 /* lambda(j) and lambda(j+1) are a conjugate pair */
9491 im = gretl_matrix_get(src, i, j+1);
9492 gretl_cmatrix_set(targ, i, j, re + im * I);
9493 gretl_cmatrix_set(targ, i, j+1, re - im * I);
9494 }
9495 }
9496 if (!isreal) {
9497 j++;
9498 }
9499 }
9500 }
9501
eigen_trivial(const gretl_matrix * A,gretl_matrix * VR,gretl_matrix * VL)9502 static gretl_matrix *eigen_trivial (const gretl_matrix *A,
9503 gretl_matrix *VR,
9504 gretl_matrix *VL)
9505 {
9506 gretl_matrix *ret = gretl_matrix_copy(A);
9507
9508 if (VR != NULL || VL != NULL) {
9509 gretl_matrix *targ[] = {VR, VL};
9510 gretl_matrix *one;
9511 int i;
9512
9513 for (i=0; i<2; i++) {
9514 if (targ[i] != NULL) {
9515 one = gretl_matrix_alloc(1, 1);
9516 one->val[0] = 1.0;
9517 gretl_matrix_replace_content(targ[i], one);
9518 gretl_matrix_free(one);
9519 }
9520 }
9521 }
9522
9523 return ret;
9524 }
9525
9526 /* convert dgeev eigenvalues to cmatrix format */
9527
eigenvals_to_cmatrix(gretl_matrix * lam,double * a,int n)9528 static void eigenvals_to_cmatrix (gretl_matrix *lam,
9529 double *a, int n)
9530 {
9531 int i, k = 0;
9532
9533 for (i=0; i<2*n; i++) {
9534 a[i] = lam->val[i];
9535 }
9536 for (i=0; i<n; i++) {
9537 lam->val[k++] = a[i];
9538 lam->val[k++] = a[i+n];
9539 }
9540 lam->cols = 1;
9541 matrix_set_complex(lam, 1, 0);
9542 }
9543
maybe_eigen_trim(gretl_matrix * lam)9544 static void maybe_eigen_trim (gretl_matrix *lam)
9545 {
9546 double *lv = lam->val + lam->rows;
9547 int i;
9548
9549 for (i=0; i<lam->rows; i++) {
9550 if (lv[i] != 0.0) {
9551 return;
9552 }
9553 }
9554
9555 /* drop the second column */
9556 gretl_matrix_reuse(lam, -1, 1);
9557 }
9558
real_gretl_dgeev(const gretl_matrix * A,gretl_matrix * VR,gretl_matrix * VL,int legacy,int * err)9559 static gretl_matrix *real_gretl_dgeev (const gretl_matrix *A,
9560 gretl_matrix *VR,
9561 gretl_matrix *VL,
9562 int legacy,
9563 int *err)
9564 {
9565 gretl_matrix *ret = NULL;
9566 gretl_matrix *Acpy = NULL;
9567 gretl_matrix *Ltmp = NULL;
9568 gretl_matrix *Rtmp = NULL;
9569 gretl_matrix *VLz = NULL;
9570 gretl_matrix *VRz = NULL;
9571 integer n, info, lwork;
9572 integer ldvl, ldvr;
9573 double *wr, *wi;
9574 double *a = NULL;
9575 double *work = NULL;
9576 double *vl = NULL, *vr = NULL;
9577 char jobvl = VL != NULL ? 'V' : 'N';
9578 char jobvr = VR != NULL ? 'V' : 'N';
9579
9580 if (gretl_is_null_matrix(A) || A->rows != A->cols) {
9581 *err = E_INVARG;
9582 return NULL;
9583 }
9584
9585 n = A->rows;
9586 if (n == 1) {
9587 /* Dispatch the scalar case, hence ensuring that
9588 A has at least two columns, which is useful
9589 to know below.
9590 */
9591 return eigen_trivial(A, VR, VL);
9592 }
9593
9594 ldvl = VL != NULL ? n : 1;
9595 ldvr = VR != NULL ? n : 1;
9596
9597 /* we need a copy of @A, which gets overwritten */
9598 Acpy = gretl_matrix_copy(A);
9599 if (Acpy == NULL) {
9600 *err = E_ALLOC;
9601 goto bailout;
9602 }
9603
9604 a = Acpy->val;
9605
9606 if (VL != NULL) {
9607 if (legacy) {
9608 *err = dgeev_eigvecs_alloc(VL, NULL, &Ltmp, n);
9609 } else {
9610 *err = dgeev_eigvecs_alloc(VL, &VLz, &Ltmp, n);
9611 }
9612 if (*err) {
9613 goto bailout;
9614 }
9615 vl = Ltmp->val;
9616 }
9617
9618 if (VR != NULL) {
9619 if (legacy) {
9620 *err = dgeev_eigvecs_alloc(VR, NULL, &Rtmp, n);
9621 } else {
9622 *err = dgeev_eigvecs_alloc(VR, &VRz, &Rtmp, n);
9623 }
9624 if (*err) {
9625 goto bailout;
9626 }
9627 vr = Rtmp->val;
9628 }
9629
9630 work = lapack_malloc(sizeof *work);
9631 ret = gretl_zero_matrix_new(n, 2);
9632
9633 if (work == NULL || ret == NULL) {
9634 *err = E_ALLOC;
9635 return NULL;
9636 }
9637
9638 wr = ret->val;
9639 wi = wr + n;
9640
9641 /* get optimal workspace size */
9642 lwork = -1;
9643 dgeev_(&jobvl, &jobvr, &n, a, &n, wr, wi, vl, &ldvl,
9644 vr, &ldvr, work, &lwork, &info);
9645 lwork = (integer) work[0];
9646 work = lapack_realloc(work, lwork * sizeof *work);
9647 if (work == NULL) {
9648 *err = E_ALLOC;
9649 goto bailout;
9650 }
9651
9652 /* do the actual decomposition */
9653 dgeev_(&jobvl, &jobvr, &n, a, &n, wr, wi, vl, &ldvl,
9654 vr, &ldvr, work, &lwork, &info);
9655
9656 if (info != 0) {
9657 fprintf(stderr, "dgeev: info = %d\n", info);
9658 *err = E_DATA;
9659 } else {
9660 if (VL != NULL) {
9661 if (legacy) {
9662 gretl_matrix_replace_content(VL, Ltmp);
9663 } else if (VLz != NULL) {
9664 dgeev_eigvecs_transcribe(VLz, Ltmp, wr, wi);
9665 gretl_matrix_replace_content(VL, VLz);
9666 } else {
9667 dgeev_eigvecs_transcribe(VL, Ltmp, wr, wi);
9668 }
9669 }
9670 if (VR != NULL) {
9671 if (legacy) {
9672 gretl_matrix_replace_content(VR, Rtmp);
9673 } else if (VRz != NULL) {
9674 dgeev_eigvecs_transcribe(VRz, Rtmp, wr, wi);
9675 gretl_matrix_replace_content(VR, VRz);
9676 } else {
9677 dgeev_eigvecs_transcribe(VR, Rtmp, wr, wi);
9678 }
9679 }
9680 }
9681
9682 bailout:
9683
9684 if (*err) {
9685 gretl_matrix_free(ret);
9686 ret = NULL;
9687 } else if (legacy) {
9688 maybe_eigen_trim(ret);
9689 } else {
9690 eigenvals_to_cmatrix(ret, a, n);
9691 }
9692
9693 lapack_free(work);
9694 gretl_matrix_free(Acpy);
9695 gretl_matrix_free(Ltmp);
9696 gretl_matrix_free(Rtmp);
9697 gretl_matrix_free(VLz);
9698 gretl_matrix_free(VRz);
9699
9700 return ret;
9701 }
9702
gretl_dgeev(const gretl_matrix * A,gretl_matrix * VR,gretl_matrix * VL,int * err)9703 gretl_matrix *gretl_dgeev (const gretl_matrix *A,
9704 gretl_matrix *VR,
9705 gretl_matrix *VL,
9706 int *err)
9707 {
9708 return real_gretl_dgeev(A, VR, VL, 0, err);
9709 }
9710
9711 /**
9712 * gretl_general_matrix_eigenvals:
9713 * @m: square matrix on which to operate.
9714 * @err: location to receive error code.
9715 *
9716 * Computes the eigenvalues of the general matrix @m.
9717 *
9718 * Returns: allocated matrix containing the eigenvalues, or NULL
9719 * on failure. The returned matrix, on successful completion,
9720 * is n x 2 (where n = the number of rows and columns in the
9721 * matrix @m); the first column holds the real parts of
9722 * the eigenvalues of @m and the second the imaginary parts.
9723 */
9724
9725 gretl_matrix *
gretl_general_matrix_eigenvals(const gretl_matrix * m,int * err)9726 gretl_general_matrix_eigenvals (const gretl_matrix *m, int *err)
9727 {
9728 return real_gretl_dgeev(m, NULL, NULL, 1, err);
9729 }
9730
old_eigengen(const gretl_matrix * m,gretl_matrix * VR,gretl_matrix * VL,int * err)9731 gretl_matrix *old_eigengen (const gretl_matrix *m,
9732 gretl_matrix *VR,
9733 gretl_matrix *VL,
9734 int *err)
9735 {
9736 return real_gretl_dgeev(m, VR, VL, 1, err);
9737 }
9738
9739 /**
9740 * gretl_symmetric_eigen_sort:
9741 * @evals: array of real eigenvalues from symmetric matrix.
9742 * @evecs: matrix of eigenvectors.
9743 * @rank: desired number of columns in output.
9744 *
9745 * Sorts the eigenvalues in @evals from largest to smallest, and
9746 * rearranges the columns in @evecs correspondingly. If @rank is
9747 * greater than zero and less than the number of columns in @evecs,
9748 * then on output @evecs is shrunk so that it contains only the
9749 * columns associated with the largest @rank eigenvalues.
9750 *
9751 * Returns: 0 on success; non-zero error code on failure.
9752 */
9753
gretl_symmetric_eigen_sort(gretl_matrix * evals,gretl_matrix * evecs,int rank)9754 int gretl_symmetric_eigen_sort (gretl_matrix *evals,
9755 gretl_matrix *evecs,
9756 int rank)
9757 {
9758 double *tmp = NULL;
9759 int n, m, err = 0;
9760
9761 n = gretl_vector_get_length(evals);
9762 if (n == 0) {
9763 return E_DATA;
9764 }
9765
9766 if (evecs != NULL && (evecs->rows != n || evecs->cols != n)) {
9767 return E_DATA;
9768 }
9769
9770 if (rank <= 0) {
9771 rank = n;
9772 }
9773 m = n / 2;
9774
9775 if (evecs != NULL && rank >= m) {
9776 /* we'll need some temporary storage for
9777 swapping eigenvectors
9778 */
9779 tmp = malloc(n * sizeof *tmp);
9780 if (tmp == NULL) {
9781 err = E_ALLOC;
9782 }
9783 }
9784
9785 if (!err) {
9786 int i, j, k;
9787 double x;
9788
9789 /* reverse the eigenvalues in @evals */
9790 k = n - 1;
9791 for (i=0; i<m; i++) {
9792 x = evals->val[i];
9793 evals->val[i] = evals->val[k];
9794 evals->val[k] = x;
9795 k--;
9796 }
9797
9798 if (evecs != NULL) {
9799 size_t colsize = n * sizeof *tmp;
9800 double *colj = evecs->val;
9801 double *colk = evecs->val + (n-1)*n;
9802
9803 if (rank < m) {
9804 /* we just have to copy the last @rank cols
9805 to the front in reverse order
9806 */
9807 m = rank;
9808 }
9809
9810 for (j=0; j<m; j++) {
9811 if (tmp == NULL) {
9812 /* col k -> col j */
9813 memcpy(colj, colk, colsize);
9814 } else {
9815 /* col j -> tmp */
9816 memcpy(tmp, colj, colsize);
9817 /* col k -> col j */
9818 memcpy(colj, colk, colsize);
9819 /* tmp -> col k */
9820 memcpy(colk, tmp, colsize);
9821 }
9822 colj += n;
9823 colk -= n;
9824 }
9825 /* and "shrink" @evecs, if wanted */
9826 if (rank < n) {
9827 evecs->cols = rank;
9828 }
9829 }
9830 }
9831
9832 free(tmp);
9833
9834 return err;
9835 }
9836
eigensym_rrr(gretl_matrix * m,int eigenvecs,int * err)9837 static gretl_matrix *eigensym_rrr (gretl_matrix *m,
9838 int eigenvecs,
9839 int *err)
9840 {
9841 integer n, info, lwork, liwork;
9842 integer nv, ldz = 1;
9843 double vl = 0, vu = 0;
9844 gretl_matrix *evals = NULL;
9845 double *z = NULL;
9846 double *work = NULL;
9847 double *w = NULL;
9848 integer *iwork = NULL;
9849 integer *isuppz = NULL;
9850 char jobz = eigenvecs ? 'V' : 'N';
9851 double abstol = 0;
9852 char range = 'A';
9853 char uplo = 'U';
9854
9855 /* Note: vl and vu are required to work around buggy
9856 implementations of dsyevr, which reference these
9857 terms even when they're not supposed to. E.g.
9858 Apple's libLAPACK.dylib. 2020-10-25.
9859 */
9860
9861 n = m->rows;
9862
9863 work = lapack_malloc(sizeof *work);
9864 iwork = malloc(sizeof *iwork);
9865 if (work == NULL || iwork == NULL) {
9866 *err = E_ALLOC;
9867 return NULL;
9868 }
9869
9870 evals = gretl_column_vector_alloc(n);
9871 if (evals == NULL) {
9872 *err = E_ALLOC;
9873 goto bailout;
9874 }
9875
9876 if (eigenvecs) {
9877 z = malloc(n * n * sizeof *z);
9878 isuppz = malloc(2 * n * sizeof *isuppz);
9879 if (z == NULL || isuppz == NULL) {
9880 *err = E_ALLOC;
9881 goto bailout;
9882 }
9883 ldz = n;
9884 }
9885
9886 w = evals->val;
9887
9888 lwork = liwork = -1; /* find optimal workspace size */
9889 dsyevr_(&jobz, &range, &uplo, &n, m->val, &n,
9890 &vl, &vu, NULL, NULL, &abstol, &nv, w,
9891 z, &ldz, isuppz, work, &lwork, iwork,
9892 &liwork, &info);
9893
9894 if (info != 0 || work[0] <= 0.0) {
9895 *err = wspace_fail(info, work[0]);
9896 goto bailout;
9897 }
9898
9899 lwork = (integer) work[0];
9900 liwork = iwork[0];
9901 work = lapack_realloc(work, lwork * sizeof *work);
9902 iwork = realloc(iwork, liwork * sizeof *iwork);
9903 if (work == NULL || iwork == NULL) {
9904 *err = E_ALLOC;
9905 }
9906
9907 if (!*err) {
9908 dsyevr_(&jobz, &range, &uplo, &n, m->val, &n,
9909 &vl, &vu, NULL, NULL, &abstol, &nv, w,
9910 z, &ldz, isuppz, work, &lwork, iwork,
9911 &liwork, &info);
9912 if (info != 0) {
9913 fprintf(stderr, "dsyevr: info = %d\n", info);
9914 *err = E_DATA;
9915 }
9916 }
9917
9918 if (!*err && eigenvecs) {
9919 memcpy(m->val, z, n*n * sizeof *z);
9920 }
9921
9922 bailout:
9923
9924 lapack_free(work);
9925 free(iwork);
9926 free(isuppz);
9927 free(z);
9928
9929 if (*err && evals != NULL) {
9930 gretl_matrix_free(evals);
9931 evals = NULL;
9932 }
9933
9934 return evals;
9935 }
9936
eigensym_standard(gretl_matrix * m,int eigenvecs,int * err)9937 static gretl_matrix *eigensym_standard (gretl_matrix *m,
9938 int eigenvecs,
9939 int *err)
9940 {
9941 integer n, info, lwork;
9942 gretl_matrix *evals = NULL;
9943 double *work = NULL;
9944 double *w = NULL;
9945 char jobz = eigenvecs ? 'V' : 'N';
9946 char uplo = 'U';
9947
9948 n = m->rows;
9949
9950 work = lapack_malloc(sizeof *work);
9951 if (work == NULL) {
9952 *err = E_ALLOC;
9953 return NULL;
9954 }
9955
9956 evals = gretl_column_vector_alloc(n);
9957 if (evals == NULL) {
9958 *err = E_ALLOC;
9959 goto bailout;
9960 }
9961
9962 w = evals->val;
9963
9964 lwork = -1; /* find optimal workspace size */
9965 dsyev_(&jobz, &uplo, &n, m->val, &n,
9966 w, work, &lwork, &info);
9967
9968 if (info != 0 || work[0] <= 0.0) {
9969 *err = wspace_fail(info, work[0]);
9970 goto bailout;
9971 }
9972
9973 lwork = (integer) work[0];
9974 work = lapack_realloc(work, lwork * sizeof *work);
9975 if (work == NULL) {
9976 *err = E_ALLOC;
9977 }
9978
9979 if (!*err) {
9980 dsyev_(&jobz, &uplo, &n, m->val, &n,
9981 w, work, &lwork, &info);
9982 if (info != 0) {
9983 fprintf(stderr, "dsyev: info = %d\n", info);
9984 *err = E_DATA;
9985 }
9986 }
9987
9988 bailout:
9989
9990 lapack_free(work);
9991
9992 if (*err && evals != NULL) {
9993 gretl_matrix_free(evals);
9994 evals = NULL;
9995 }
9996
9997 return evals;
9998 }
9999
10000 /**
10001 * gretl_symmetric_matrix_eigenvals:
10002 * @m: n x n matrix to operate on.
10003 * @eigenvecs: non-zero to calculate eigenvectors, 0 to omit.
10004 * @err: location to receive error code.
10005 *
10006 * Computes the eigenvalues of the real symmetric matrix @m.
10007 * If @eigenvecs is non-zero, also compute the orthonormal
10008 * eigenvectors of @m, which are stored in @m. Uses the lapack
10009 * function dsyevr(), or dsyev() for small matrices.
10010 *
10011 * Returns: n x 1 matrix containing the eigenvalues in ascending
10012 * order, or NULL on failure.
10013 */
10014
10015 gretl_matrix *
gretl_symmetric_matrix_eigenvals(gretl_matrix * m,int eigenvecs,int * err)10016 gretl_symmetric_matrix_eigenvals (gretl_matrix *m, int eigenvecs, int *err)
10017 {
10018 gretl_matrix *ret = NULL;
10019 static int ev_ver;
10020 int save_nt = 0;
10021
10022 *err = 0;
10023
10024 if (gretl_is_null_matrix(m)) {
10025 *err = E_DATA;
10026 return NULL;
10027 }
10028
10029 if (blas_is_openblas()) {
10030 save_nt = blas_get_num_threads();
10031 if (save_nt > 1) {
10032 blas_set_num_threads(1);
10033 }
10034 }
10035
10036 if (ev_ver == 0) {
10037 char *s = getenv("GRETL_OLD_EV");
10038
10039 ev_ver = s != NULL ? 1 : 2;
10040 }
10041
10042 if (m->rows < 10 || ev_ver == 1) {
10043 ret = eigensym_standard(m, eigenvecs, err);
10044 } else {
10045 ret = eigensym_rrr(m, eigenvecs, err);
10046 }
10047
10048 if (blas_is_openblas() && save_nt > 1) {
10049 blas_set_num_threads(save_nt);
10050 }
10051
10052 return ret;
10053 }
10054
10055 static gretl_matrix *
real_symm_eigenvals_descending(gretl_matrix * m,int eigenvecs,int rank,int * err)10056 real_symm_eigenvals_descending (gretl_matrix *m,
10057 int eigenvecs,
10058 int rank,
10059 int *err)
10060 {
10061 gretl_matrix *v =
10062 gretl_symmetric_matrix_eigenvals(m, eigenvecs, err);
10063
10064 if (!*err) {
10065 m = eigenvecs ? m : NULL;
10066 *err = gretl_symmetric_eigen_sort(v, m, rank);
10067 }
10068
10069 if (*err && v != NULL) {
10070 gretl_matrix_free(v);
10071 v = NULL;
10072 }
10073
10074 return v;
10075 }
10076
10077 /**
10078 * gretl_symm_matrix_eigenvals_descending:
10079 * @m: n x n matrix to operate on.
10080 * @eigenvecs: non-zero to calculate eigenvectors, 0 to omit.
10081 * @err: location to receive error code.
10082 *
10083 * Computes the eigenvalues of the real symmetric matrix @m.
10084 * If @eigenvecs is non-zero, also compute the orthonormal
10085 * eigenvectors of @m, which are stored in @m. Uses the lapack
10086 * function dsyev().
10087 *
10088 * Returns: n x 1 matrix containing the eigenvalues in descending
10089 * order, or NULL on failure.
10090 */
10091
10092 gretl_matrix *
gretl_symm_matrix_eigenvals_descending(gretl_matrix * m,int eigenvecs,int * err)10093 gretl_symm_matrix_eigenvals_descending (gretl_matrix *m,
10094 int eigenvecs,
10095 int *err)
10096 {
10097 return real_symm_eigenvals_descending(m, eigenvecs,
10098 0, err);
10099 }
10100
get_extreme_eigenvalue(gretl_matrix * m,int getmax,int * err)10101 static double get_extreme_eigenvalue (gretl_matrix *m, int getmax,
10102 int *err)
10103 {
10104 double ev = 0.0/0.0;
10105 gretl_matrix *v;
10106
10107 v = gretl_symmetric_matrix_eigenvals(m, 0, err);
10108
10109 if (!*err) {
10110 int n = gretl_vector_get_length(v);
10111
10112 /* the eigenvalues, from lapack's dsyev(),
10113 are in ascending order */
10114
10115 if (getmax) {
10116 ev = v->val[n-1];
10117 } else {
10118 ev = v->val[0];
10119 }
10120
10121 gretl_matrix_free(v);
10122 }
10123
10124 if (*err == 0 || *err == 1) {
10125 /* reconstitute full matrix */
10126 gretl_matrix_mirror(m, 'L');
10127 }
10128
10129 return ev;
10130 }
10131
10132 /**
10133 * gretl_symm_matrix_lambda_min:
10134 * @m: n x n matrix to operate on.
10135 * @err: location to receive error code.
10136 *
10137 * Returns: the minimum eigenvalue of the real symmetric matrix @m,
10138 * or %NaN on error.
10139 */
10140
gretl_symm_matrix_lambda_min(const gretl_matrix * m,int * err)10141 double gretl_symm_matrix_lambda_min (const gretl_matrix *m, int *err)
10142 {
10143 return get_extreme_eigenvalue((gretl_matrix *) m, 0, err);
10144 }
10145
10146 /**
10147 * gretl_symm_matrix_lambda_max:
10148 * @m: n x n matrix to operate on.
10149 * @err: location to receive error code.
10150 *
10151 * Returns: the maximum eigenvalue of the real symmetric matrix @m,
10152 * or %NaN on error.
10153 */
10154
gretl_symm_matrix_lambda_max(const gretl_matrix * m,int * err)10155 double gretl_symm_matrix_lambda_max (const gretl_matrix *m, int *err)
10156 {
10157 return get_extreme_eigenvalue((gretl_matrix *) m, 1, err);
10158 }
10159
gensymm_conformable(const gretl_matrix * A,const gretl_matrix * B)10160 static int gensymm_conformable (const gretl_matrix *A,
10161 const gretl_matrix *B)
10162 {
10163 if (!real_gretl_matrix_is_symmetric(A, 1)) {
10164 fputs("gretl_gensymm_eigenvals: matrix A is not symmetric\n",
10165 stderr);
10166 return 0;
10167 }
10168
10169 if (!real_gretl_matrix_is_symmetric(B, 1)) {
10170 fputs("gretl_gensymm_eigenvals: matrix B is not symmetric\n",
10171 stderr);
10172 return 0;
10173 }
10174
10175 if (B->rows != A->rows) {
10176 fputs("gretl_gensymm_eigenvals: matrices A and B have different size\n",
10177 stderr);
10178 return 0;
10179 }
10180
10181 return 1;
10182 }
10183
10184 #define GSDEBUG 0
10185
10186 /**
10187 * gretl_gensymm_eigenvals:
10188 * @A: symmetric matrix.
10189 * @B: symmetric positive definite matrix.
10190 * @V: matrix to hold the generalized eigenvectors, or NULL if
10191 * these are not required.
10192 * @err: location to receive error code.
10193 *
10194 * Solves the generalized eigenvalue problem
10195 * | A - \lambda B | = 0 , where both A and B are symmetric
10196 * and B is positive definite.
10197 *
10198 * Returns: allocated storage containing the eigenvalues, in
10199 * ascending order, or NULL on failure.
10200 */
10201
gretl_gensymm_eigenvals(const gretl_matrix * A,const gretl_matrix * B,gretl_matrix * V,int * err)10202 gretl_matrix *gretl_gensymm_eigenvals (const gretl_matrix *A,
10203 const gretl_matrix *B,
10204 gretl_matrix *V,
10205 int *err)
10206 {
10207 gretl_matrix *K = NULL;
10208 gretl_matrix *tmp = NULL;
10209 gretl_matrix *evals = NULL;
10210 int n;
10211
10212 #if GSDEBUG
10213 gretl_matrix_print(A, "A");
10214 gretl_matrix_print(B, "B");
10215 #endif
10216
10217 if (gretl_is_null_matrix(A) || gretl_is_null_matrix(B)) {
10218 *err = E_DATA;
10219 return NULL;
10220 }
10221
10222 if (!gensymm_conformable(A, B)) {
10223 *err = E_NONCONF;
10224 return NULL;
10225 }
10226
10227 n = A->rows;
10228 K = gretl_matrix_copy_tmp(B);
10229 tmp = gretl_matrix_alloc(n, n);
10230
10231 if (K == NULL || tmp == NULL) {
10232 *err = E_ALLOC;
10233 goto bailout;
10234 }
10235
10236 *err = gretl_matrix_cholesky_decomp(K);
10237 if (*err) {
10238 fputs("gretl_gensymm_eigenvals: matrix B not p.d.\n",
10239 stderr);
10240 *err = E_NONCONF;
10241 goto bailout;
10242 }
10243
10244 *err = gretl_invert_triangular_matrix(K, 'L');
10245 if (*err) {
10246 fputs("gretl_gensymm_eigenvals: matrix B only p.s.d.\n",
10247 stderr);
10248 *err = E_NONCONF;
10249 goto bailout;
10250 }
10251
10252 gretl_matrix_qform(K, GRETL_MOD_NONE, A, tmp, GRETL_MOD_NONE);
10253
10254 #if GSDEBUG
10255 gretl_matrix_print(tmp, "tmp");
10256 #endif
10257
10258 evals = gretl_symmetric_matrix_eigenvals(tmp, 1, err);
10259 if (*err) {
10260 goto bailout;
10261 }
10262
10263 if (V != NULL) {
10264 *err = gretl_matrix_multiply_mod(K, GRETL_MOD_TRANSPOSE,
10265 tmp, GRETL_MOD_NONE,
10266 V, GRETL_MOD_NONE);
10267 #if GSDEBUG
10268 gretl_matrix_print(V, "V");
10269 #endif
10270 }
10271
10272 bailout:
10273
10274 gretl_matrix_free(K);
10275 gretl_matrix_free(tmp);
10276
10277 if (*err && evals != NULL) {
10278 gretl_matrix_free(evals);
10279 evals = NULL;
10280 }
10281
10282 return evals;
10283 }
10284
10285 /* Compute SVD via eigen-decomposition for the case where
10286 @X is "tall": more rows than columns.
10287 */
10288
tall_SVD(const gretl_matrix * X,gretl_matrix ** pU,gretl_matrix ** psv,gretl_matrix ** pVt)10289 static int tall_SVD (const gretl_matrix *X,
10290 gretl_matrix **pU,
10291 gretl_matrix **psv,
10292 gretl_matrix **pVt)
10293 {
10294 gretl_matrix *XTX;
10295 gretl_matrix *sv;
10296 gretl_matrix *lam = NULL;
10297 gretl_matrix *U = NULL;
10298 gretl_matrix *Vt = NULL;
10299 gretl_matrix *Vl = NULL;
10300 double lj, vij;
10301 int vecs, c = X->cols;
10302 int i, j, jj;
10303 int err = 0;
10304
10305 XTX = gretl_matrix_alloc(c, c);
10306 sv = gretl_matrix_alloc(1, c);
10307 if (XTX == NULL || sv == NULL) {
10308 return E_ALLOC;
10309 }
10310
10311 vecs = pU != NULL || pVt != NULL;
10312
10313 gretl_matrix_multiply_mod(X, GRETL_MOD_TRANSPOSE,
10314 X, GRETL_MOD_NONE,
10315 XTX, GRETL_MOD_NONE);
10316
10317 lam = gretl_symmetric_matrix_eigenvals(XTX, vecs, &err);
10318 if (!err) {
10319 for (i=0; i<c; i++) {
10320 lj = lam->val[c-i-1];
10321 if (lj < 0) {
10322 err = E_SINGULAR;
10323 break;
10324 }
10325 sv->val[i] = sqrt(lj);
10326 }
10327 }
10328
10329 if (err) {
10330 gretl_matrix_free(XTX);
10331 gretl_matrix_free(sv);
10332 return err;
10333 }
10334
10335 if (pVt != NULL) {
10336 Vt = gretl_matrix_alloc(c, c);
10337 if (Vt == NULL) {
10338 err = E_ALLOC;
10339 } else {
10340 for (j=0; j<c; j++) {
10341 jj = c - j - 1;
10342 for (i=0; i<c; i++) {
10343 vij = gretl_matrix_get(XTX, i, j);
10344 gretl_matrix_set(Vt, jj, i, vij);
10345 }
10346 }
10347 }
10348 }
10349
10350 if (!err && pU != NULL) {
10351 U = gretl_matrix_alloc(X->rows, c);
10352 Vl = gretl_matrix_alloc(c, c);
10353 if (U == NULL || Vl == NULL) {
10354 err = E_ALLOC;
10355 } else {
10356 for (j=0; j<c; j++) {
10357 jj = c - j - 1;
10358 for (i=0; i<c; i++) {
10359 vij = gretl_matrix_get(XTX, i, jj);
10360 gretl_matrix_set(Vl, i, j, vij / sv->val[j]);
10361 }
10362 }
10363 gretl_matrix_multiply(X, Vl, U);
10364 }
10365 }
10366
10367 if (psv != NULL) {
10368 *psv = sv;
10369 sv = NULL;
10370 }
10371 if (pU != NULL) {
10372 *pU = U;
10373 U = NULL;
10374 }
10375 if (pVt != NULL) {
10376 *pVt = Vt;
10377 Vt = NULL;
10378 }
10379
10380 gretl_matrix_free(XTX);
10381 gretl_matrix_free(sv);
10382 gretl_matrix_free(lam);
10383 gretl_matrix_free(U);
10384 gretl_matrix_free(Vt);
10385 gretl_matrix_free(Vl);
10386
10387 return err;
10388 }
10389
real_gretl_matrix_SVD(const gretl_matrix * x,gretl_matrix ** pu,gretl_vector ** ps,gretl_matrix ** pvt,int full)10390 static int real_gretl_matrix_SVD (const gretl_matrix *x,
10391 gretl_matrix **pu,
10392 gretl_vector **ps,
10393 gretl_matrix **pvt,
10394 int full)
10395 {
10396 integer m, n, lda;
10397 integer ldu = 1, ldvt = 1;
10398 integer lwork = -1;
10399 integer *iwork = NULL;
10400 integer info;
10401 gretl_matrix *a = NULL;
10402 gretl_matrix *s = NULL;
10403 gretl_matrix *u = NULL;
10404 gretl_matrix *vt = NULL;
10405 char jobu = 'N', jobvt = 'N';
10406 char jobz = 'N';
10407 double xu, xvt;
10408 double *uval = &xu, *vtval = &xvt;
10409 double *work = NULL;
10410 int k, dnc;
10411 int err = 0;
10412
10413 a = gretl_matrix_copy_tmp(x);
10414 if (a == NULL) {
10415 return E_ALLOC;
10416 }
10417
10418 lda = m = x->rows;
10419 n = x->cols;
10420 k = (m < n)? m : n;
10421 dnc = k > 20;
10422
10423 s = gretl_vector_alloc(k);
10424 if (s == NULL) {
10425 err = E_ALLOC;
10426 goto bailout;
10427 }
10428
10429 if (dnc) {
10430 /* divide and conquer */
10431 if (pu != NULL || pvt != NULL) {
10432 int ucols = full ? m : k;
10433
10434 ldu = m;
10435 ldvt = full ? n : k;
10436 u = gretl_matrix_alloc(ldu, ucols);
10437 vt = gretl_matrix_alloc(ldvt, n);
10438 if (u == NULL || vt == NULL) {
10439 err = E_ALLOC;
10440 goto bailout;
10441 } else {
10442 uval = u->val;
10443 vtval = vt->val;
10444 jobz = full ? 'A' : 'S';
10445 }
10446 }
10447
10448 work = lapack_malloc(sizeof *work);
10449 iwork = malloc(8 * k * sizeof *iwork);
10450 if (work == NULL || iwork == NULL) {
10451 err = E_ALLOC;
10452 goto bailout;
10453 }
10454
10455 /* workspace query */
10456 dgesdd_(&jobz, &m, &n, a->val, &lda, s->val, uval, &ldu,
10457 vtval, &ldvt, work, &lwork, iwork, &info);
10458 } else {
10459 /* vanilla SVD computation */
10460 if (pu != NULL) {
10461 ldu = m;
10462 if (full) {
10463 u = gretl_matrix_alloc(ldu, m);
10464 } else {
10465 u = gretl_matrix_alloc(ldu, k);
10466 }
10467 if (u == NULL) {
10468 err = E_ALLOC;
10469 goto bailout;
10470 } else {
10471 uval = u->val;
10472 jobu = full ? 'A' : 'S';
10473 }
10474 }
10475 if (pvt != NULL) {
10476 ldvt = full ? n : k;
10477 vt = gretl_matrix_alloc(ldvt, n);
10478 if (vt == NULL) {
10479 err = E_ALLOC;
10480 goto bailout;
10481 } else {
10482 vtval = vt->val;
10483 jobvt = full ? 'A' : 'S';
10484 }
10485 }
10486
10487 work = lapack_malloc(sizeof *work);
10488 if (work == NULL) {
10489 err = E_ALLOC;
10490 goto bailout;
10491 }
10492
10493 /* workspace query */
10494 dgesvd_(&jobu, &jobvt, &m, &n, a->val, &lda, s->val, uval, &ldu,
10495 vtval, &ldvt, work, &lwork, &info);
10496 }
10497
10498 if (info != 0 || work[0] <= 0.0) {
10499 err = wspace_fail(info, work[0]);
10500 goto bailout;
10501 }
10502
10503 lwork = (integer) work[0];
10504 work = lapack_realloc(work, lwork * sizeof *work);
10505 if (work == NULL) {
10506 err = E_ALLOC;
10507 goto bailout;
10508 }
10509
10510 /* actual computation */
10511 if (dnc) {
10512 dgesdd_(&jobz, &m, &n, a->val, &lda, s->val, uval, &ldu,
10513 vtval, &ldvt, work, &lwork, iwork, &info);
10514 } else {
10515 dgesvd_(&jobu, &jobvt, &m, &n, a->val, &lda, s->val, uval, &ldu,
10516 vtval, &ldvt, work, &lwork, &info);
10517 }
10518
10519 if (info != 0) {
10520 fprintf(stderr, "gretl_matrix_SVD: info = %d\n", (int) info);
10521 err = E_DATA;
10522 goto bailout;
10523 }
10524
10525 if (ps != NULL) {
10526 *ps = s;
10527 s = NULL;
10528 }
10529 if (pu != NULL) {
10530 *pu = u;
10531 u = NULL;
10532 }
10533 if (pvt != NULL) {
10534 *pvt = vt;
10535 vt = NULL;
10536 }
10537
10538 bailout:
10539
10540 lapack_free(work);
10541 free(iwork);
10542 gretl_matrix_free(a);
10543 gretl_matrix_free(s);
10544 gretl_matrix_free(u);
10545 gretl_matrix_free(vt);
10546
10547 return err;
10548 }
10549
10550 /**
10551 * gretl_matrix_SVD:
10552 * @x: m x n matrix to decompose.
10553 * @pu: location for matrix U, or NULL if not wanted.
10554 * @ps: location for vector of singular values, or NULL if not wanted.
10555 * @pvt: location for matrix V (transposed), or NULL if not wanted.
10556 * @full: if U and/or V are to be computed, a non-zero value flags
10557 * production of "full-size" U (m x m) and/or V (n x n). Otherwise U
10558 * will be m x min(m,n) and and V' will be min(m,n) x n. Note that
10559 * this flag matters only if @x is not square.
10560 *
10561 * Computes SVD factorization of a general matrix using one of the
10562 * the lapack functions dgesvd() or dgesdd(). A = U * diag(s) * Vt.
10563 *
10564 * Returns: 0 on success; non-zero error code on failure.
10565 */
10566
gretl_matrix_SVD(const gretl_matrix * x,gretl_matrix ** pu,gretl_vector ** ps,gretl_matrix ** pvt,int full)10567 int gretl_matrix_SVD (const gretl_matrix *x, gretl_matrix **pu,
10568 gretl_vector **ps, gretl_matrix **pvt,
10569 int full)
10570 {
10571 int err = 0;
10572
10573 if (pu == NULL && ps == NULL && pvt == NULL) {
10574 /* no-op */
10575 return 0;
10576 } else if (gretl_is_null_matrix(x)) {
10577 return E_DATA;
10578 }
10579
10580 if (!full && x->rows > x->cols && getenv("GRETL_REAL_SVD") == NULL) {
10581 /* The "tall" variant is very fast, but not at all
10582 accurate for near-singular matrices. If @x is
10583 too close to singular this will be flagged by an
10584 error code of E_SINGULAR from tall_SVD(), in which
10585 case we'll proceed to try "real" SVD; any other
10586 error will be treated as fatal.
10587 */
10588 err = tall_SVD(x, pu, ps, pvt);
10589 if (err != E_SINGULAR) {
10590 /* either OK or fatal error */
10591 return err;
10592 }
10593 }
10594
10595 return real_gretl_matrix_SVD(x, pu, ps, pvt, full);
10596 }
10597
10598 /**
10599 * gretl_matrix_SVD_johansen_solve:
10600 * @R0: T x p matrix of residuals.
10601 * @R1: T x p1 matrix of residuals.
10602 * @evals: vector to receive eigenvals, or NULL if not wanted.
10603 * @B: matrix to hold \beta, or NULL if not wanted.
10604 * @A: matrix to hold \alpha, or NULL if not wanted.
10605 * @jrank: cointegration rank, <= p.
10606 *
10607 * Solves the Johansen generalized eigenvalue problem via
10608 * SVD decomposition. See J. A. Doornik and R. J. O'Brien,
10609 * "Numerically stable cointegration analysis", Computational
10610 * Statistics and Data Analysis, 41 (2002), pp. 185-193,
10611 * Algorithm 4.
10612 *
10613 * If @B is non-null it should be p1 x p on input; it will
10614 * be trimmed to p1 x @jrank on output if @jrank < p.
10615 * If @A is non-null it should be p x p on input; it will
10616 * be trimmed to p x @jrank on output if @jrank < p.
10617 * @evals should be a vector of length @jrank.
10618 *
10619 * Returns: 0 on success; non-zero error code on failure.
10620 */
10621
gretl_matrix_SVD_johansen_solve(const gretl_matrix * R0,const gretl_matrix * R1,gretl_matrix * evals,gretl_matrix * B,gretl_matrix * A,int jrank)10622 int gretl_matrix_SVD_johansen_solve (const gretl_matrix *R0,
10623 const gretl_matrix *R1,
10624 gretl_matrix *evals,
10625 gretl_matrix *B,
10626 gretl_matrix *A,
10627 int jrank)
10628 {
10629 gretl_matrix *U0 = NULL;
10630 gretl_matrix *U1 = NULL;
10631 gretl_matrix *Uz = NULL;
10632 gretl_matrix *S1 = NULL;
10633 gretl_matrix *Sz = NULL;
10634 gretl_matrix *V1 = NULL;
10635 gretl_matrix *Z = NULL;
10636 int T = R0->rows;
10637 int p = R0->cols;
10638 int p1 = R1->cols;
10639 int r, err;
10640
10641 if (evals == NULL && B == NULL && A == NULL) {
10642 /* no-op */
10643 return 0;
10644 }
10645
10646 r = (jrank == 0)? p : jrank;
10647
10648 if (r < 1 || r > p) {
10649 fprintf(stderr, "Johansen SVD: r is wrong (%d)\n", r);
10650 return E_NONCONF;
10651 }
10652
10653 if (evals != NULL && gretl_vector_get_length(evals) < r) {
10654 fprintf(stderr, "Johansen SVD: evals is too short\n");
10655 return E_NONCONF;
10656 }
10657
10658 if (B != NULL && (B->rows != p1 || B->cols != p)) {
10659 fprintf(stderr, "Johansen SVD: B is wrong size\n");
10660 return E_NONCONF;
10661 }
10662
10663 if (A != NULL && (A->rows != p || A->cols != p)) {
10664 fprintf(stderr, "Johansen SVD: A is wrong size\n");
10665 return E_NONCONF;
10666 }
10667
10668 err = real_gretl_matrix_SVD(R0, &U0, NULL, NULL, 0);
10669
10670 if (!err) {
10671 err = real_gretl_matrix_SVD(R1, &U1, &S1, &V1, 0);
10672 }
10673
10674 if (!err) {
10675 Z = gretl_matrix_alloc(p1, p);
10676 if (Z == NULL) {
10677 err = E_ALLOC;
10678 } else {
10679 err = gretl_matrix_multiply_mod(U1, GRETL_MOD_TRANSPOSE,
10680 U0, GRETL_MOD_NONE,
10681 Z, GRETL_MOD_NONE);
10682 }
10683 }
10684
10685 if (!err) {
10686 err = real_gretl_matrix_SVD(Z, &Uz, &Sz, NULL, 0);
10687 }
10688
10689 if (!err) {
10690 double x, si;
10691 int i, j;
10692
10693 if (evals != NULL) {
10694 for (i=0; i<r; i++) {
10695 evals->val[i] = Sz->val[i] * Sz->val[i];
10696 }
10697 }
10698
10699 if (B != NULL) {
10700 /* \hat{\beta} = T^{1/2} V_1 {\Sigma_1}^{-1} U_z */
10701
10702 for (i=0; i<p1; i++) {
10703 si = S1->val[i];
10704 for (j=0; j<p1; j++) {
10705 if (si > SVD_SMIN) {
10706 x = gretl_matrix_get(V1, i, j);
10707 gretl_matrix_set(V1, i, j, x / si);
10708 } else {
10709 gretl_matrix_set(V1, i, j, 0);
10710 }
10711 }
10712 }
10713
10714 gretl_matrix_multiply_mod(V1, GRETL_MOD_TRANSPOSE,
10715 Uz, GRETL_MOD_NONE,
10716 B, GRETL_MOD_NONE);
10717 gretl_matrix_multiply_by_scalar(B, sqrt((double) T));
10718 if (r < p) {
10719 gretl_matrix_reuse(B, -1, r);
10720 }
10721 }
10722
10723 if (A != NULL) {
10724 /* \hat{\alpha} = T^{-1/2} R_0' U_1 U_z */
10725
10726 gretl_matrix_reuse(Z, p, p1);
10727 gretl_matrix_multiply_mod(R0, GRETL_MOD_TRANSPOSE,
10728 U1, GRETL_MOD_NONE,
10729 Z, GRETL_MOD_NONE);
10730 gretl_matrix_multiply(Z, Uz, A);
10731 gretl_matrix_divide_by_scalar(A, sqrt((double) T));
10732 if (r < p) {
10733 gretl_matrix_reuse(A, -1, r);
10734 }
10735 }
10736 }
10737
10738 gretl_matrix_free(U0);
10739 gretl_matrix_free(U1);
10740 gretl_matrix_free(Uz);
10741 gretl_matrix_free(S1);
10742 gretl_matrix_free(Sz);
10743 gretl_matrix_free(V1);
10744 gretl_matrix_free(Z);
10745
10746 return err;
10747 }
10748
10749 /* return the row-index of the element in column col of
10750 matrix X that has the greatest absolute magnitude
10751 */
10752
max_abs_index(const gretl_matrix * X,int col)10753 static int max_abs_index (const gretl_matrix *X, int col)
10754 {
10755 double aij, tmp = 0.0;
10756 int i, idx = 0;
10757
10758 for (i=0; i<X->rows; i++) {
10759 aij = fabs(gretl_matrix_get(X, i, col));
10760 if (aij > tmp) {
10761 tmp = aij;
10762 idx = i;
10763 }
10764 }
10765
10766 return idx;
10767 }
10768
10769 #define NSMIN 1.0e-16
10770
normalize_nullspace(gretl_matrix * M)10771 static void normalize_nullspace (gretl_matrix *M)
10772 {
10773 int i, j, k, idx;
10774 double x, y;
10775
10776 /* FIXME? */
10777
10778 if (M->cols == 1) {
10779 j = 0;
10780 idx = max_abs_index(M, j);
10781 x = gretl_matrix_get(M, idx, j);
10782 for (i=0; i<M->rows; i++) {
10783 y = gretl_matrix_get(M, i, j);
10784 y /= x;
10785 if (fabs(y) < NSMIN) y = 0.0;
10786 gretl_matrix_set(M, i, j, y);
10787 }
10788 }
10789
10790 /* remove ugliness for printing */
10791 k = M->rows * M->cols;
10792 for (i=0; i<k; i++) {
10793 if (M->val[i] == -0) {
10794 M->val[i] = 0;
10795 }
10796 }
10797 }
10798
10799 /**
10800 * gretl_matrix_right_nullspace:
10801 * @M: matrix to operate on.
10802 * @err: location to receive error code.
10803 *
10804 * Given an m x n matrix @M, construct a conformable matrix
10805 * R such that MR = 0 (that is, all the columns of R are
10806 * orthogonal to the space spanned by the rows of @M).
10807 *
10808 * Returns: the allocated matrix R, or NULL on failure.
10809 */
10810
gretl_matrix_right_nullspace(const gretl_matrix * M,int * err)10811 gretl_matrix *gretl_matrix_right_nullspace (const gretl_matrix *M, int *err)
10812 {
10813 gretl_matrix *R = NULL;
10814 gretl_matrix *V = NULL;
10815 gretl_matrix *S = NULL;
10816 int i, j, k;
10817
10818 if (gretl_is_null_matrix(M)) {
10819 *err = E_DATA;
10820 return NULL;
10821 }
10822
10823 /* we'll need the full SVD here */
10824 *err = real_gretl_matrix_SVD(M, NULL, &S, &V, 1);
10825
10826 if (!*err) {
10827 char E = 'E';
10828 int m = M->rows;
10829 int n = M->cols;
10830 int r = MIN(m, n);
10831 int sz = MAX(m, n);
10832 double x, eps = dlamch_(&E);
10833 double smin = sz * S->val[0] * eps;
10834
10835 /* rank plus nullity = n */
10836 k = n;
10837 for (i=0; i<r; i++) {
10838 if (S->val[i] > smin) {
10839 k--;
10840 }
10841 }
10842
10843 if (k == 0) {
10844 R = gretl_null_matrix_new();
10845 } else {
10846 R = gretl_matrix_alloc(n, k);
10847 }
10848
10849 if (R == NULL) {
10850 *err = E_ALLOC;
10851 } else if (k > 0) {
10852 for (i=0; i<n; i++) {
10853 for (j=0; j<k; j++) {
10854 x = gretl_matrix_get(V, j + n - k, i);
10855 gretl_matrix_set(R, i, j, x);
10856 }
10857 }
10858 normalize_nullspace(R);
10859 }
10860 }
10861
10862 #if 0
10863 gretl_matrix_print(S, "S");
10864 gretl_matrix_print(V, "V'");
10865 gretl_matrix_print(R, "R");
10866 #endif
10867
10868 gretl_matrix_free(S);
10869 gretl_matrix_free(V);
10870
10871 return R;
10872 }
10873
10874 /**
10875 * gretl_matrix_left_nullspace:
10876 * @M: matrix to operate on.
10877 * @mod: %GRETL_MOD_NONE or %GRETL_MOD_TRANSPOSE
10878 * @err: location to receive error code.
10879 *
10880 * Given an m x n matrix @M, construct a conformable matrix
10881 * L such that LM = 0 (that is, all the columns of @M are
10882 * orthogonal to the space spanned by the rows of L).
10883 *
10884 * Returns: the allocated matrix L, or if @mod is
10885 * %GRETL_MOD_TRANSPOSE, L', or NULL on failure.
10886 */
10887
gretl_matrix_left_nullspace(const gretl_matrix * M,GretlMatrixMod mod,int * err)10888 gretl_matrix *gretl_matrix_left_nullspace (const gretl_matrix *M,
10889 GretlMatrixMod mod,
10890 int *err)
10891 {
10892 gretl_matrix *Tmp = NULL;
10893 gretl_matrix *L = NULL;
10894
10895 if (gretl_is_null_matrix(M)) {
10896 *err = E_DATA;
10897 return NULL;
10898 }
10899
10900 Tmp = gretl_matrix_copy_transpose(M);
10901 if (Tmp == NULL) {
10902 *err = E_ALLOC;
10903 return NULL;
10904 }
10905
10906 L = gretl_matrix_right_nullspace(Tmp, err);
10907 gretl_matrix_free(Tmp);
10908
10909 if (!*err && mod == GRETL_MOD_TRANSPOSE) {
10910 Tmp = gretl_matrix_copy_transpose(L);
10911 if (Tmp == NULL) {
10912 *err = E_ALLOC;
10913 } else {
10914 gretl_matrix_free(L);
10915 L = Tmp;
10916 }
10917 }
10918
10919 return L;
10920 }
10921
10922 #define true_null_matrix(a) (a->rows == 0 && a->cols == 0)
10923
10924 /**
10925 * gretl_matrix_row_concat:
10926 * @a: upper source matrix (m x n).
10927 * @b: lower source matrix (p x n).
10928 * @err: location to receive error code.
10929 *
10930 * Returns: newly allocated matrix ((m+p) x n) that results from
10931 * the row-wise concatenation of @a and @b, or NULL on failure.
10932 */
10933
10934 gretl_matrix *
gretl_matrix_row_concat(const gretl_matrix * a,const gretl_matrix * b,int * err)10935 gretl_matrix_row_concat (const gretl_matrix *a, const gretl_matrix *b,
10936 int *err)
10937 {
10938 gretl_matrix *c = NULL;
10939
10940 if (a == NULL || b == NULL) {
10941 *err = E_DATA;
10942 } else if (true_null_matrix(a)) {
10943 c = gretl_matrix_copy(b);
10944 goto finish;
10945 } else if (true_null_matrix(b)) {
10946 c = gretl_matrix_copy(a);
10947 goto finish;
10948 }
10949
10950 if (!*err) {
10951 int cmplx_a = a->is_complex;
10952 int cmplx_b = b->is_complex;
10953 int cmplx_c = cmplx_a || cmplx_b;
10954 int scalar_a = 0;
10955 int scalar_b = 0;
10956 double complex z;
10957 double x;
10958 int cr, cc;
10959 int i, j, k;
10960
10961 if (matrix_is_scalar(a) && b->cols != 1) {
10962 scalar_a = 1;
10963 cr = b->rows + 1;
10964 cc = b->cols;
10965 } else if (matrix_is_scalar(b) && a->cols != 1) {
10966 scalar_b = 1;
10967 cr = a->rows + 1;
10968 cc = a->cols;
10969 } else if (a->cols != b->cols) {
10970 *err = E_NONCONF;
10971 return NULL;
10972 } else if (a->rows + b->rows == 0 || a->cols == 0) {
10973 cr = cc = 0;
10974 } else {
10975 cr = a->rows + b->rows;
10976 cc = a->cols;
10977 }
10978
10979 if (cr == 0 && cc == 0) {
10980 c = gretl_null_matrix_new();
10981 } else if (cmplx_c) {
10982 c = gretl_cmatrix_new(cr, cc);
10983 } else {
10984 c = gretl_matrix_alloc(cr, cc);
10985 }
10986 if (c == NULL) {
10987 *err = E_ALLOC;
10988 return NULL;
10989 } else if (cr == 0) {
10990 return c;
10991 }
10992
10993 if (scalar_a) {
10994 for (j=0; j<b->cols; j++) {
10995 if (cmplx_c) {
10996 z = cmplx_a ? a->z[0] : a->val[0];
10997 gretl_cmatrix_set(c, 0, j, z);
10998 } else {
10999 gretl_matrix_set(c, 0, j, a->val[0]);
11000 }
11001 }
11002 } else {
11003 for (i=0; i<a->rows; i++) {
11004 for (j=0; j<a->cols; j++) {
11005 if (cmplx_c) {
11006 z = cmplx_a ? gretl_cmatrix_get(a, i, j) :
11007 gretl_matrix_get(a, i, j);
11008 gretl_cmatrix_set(c, i, j, z);
11009 } else {
11010 x = gretl_matrix_get(a, i, j);
11011 gretl_matrix_set(c, i, j, x);
11012 }
11013 }
11014 }
11015 }
11016
11017 k = a->rows;
11018 if (scalar_b) {
11019 for (j=0; j<a->cols; j++) {
11020 if (cmplx_c) {
11021 z = cmplx_b ? b->z[0] : b->val[0];
11022 gretl_cmatrix_set(c, k, j, z);
11023 } else {
11024 gretl_matrix_set(c, k, j, b->val[0]);
11025 }
11026 }
11027 } else {
11028 for (i=0; i<b->rows; i++) {
11029 for (j=0; j<b->cols; j++) {
11030 if (cmplx_c) {
11031 z = cmplx_b ? gretl_cmatrix_get(b, i, j) :
11032 gretl_matrix_get(b, i, j);
11033 gretl_cmatrix_set(c, k, j, z);
11034 } else {
11035 x = gretl_matrix_get(b, i, j);
11036 gretl_matrix_set(c, k, j, x);
11037 }
11038 }
11039 k++;
11040 }
11041 }
11042 }
11043
11044 finish:
11045
11046 if (!*err) {
11047 if (c == NULL) {
11048 *err = E_ALLOC;
11049 } else {
11050 maybe_preserve_names(c, a, COLNAMES, NULL);
11051 maybe_concat_names(c, a, b, ROWNAMES);
11052 }
11053 }
11054
11055 return c;
11056 }
11057
11058 /**
11059 * gretl_matrix_col_concat:
11060 * @a: left-hand source matrix (m x n).
11061 * @b: right-hand source matrix (m x p).
11062 * @err: location to receive error code.
11063 *
11064 * Returns: newly allocated matrix (m x (n+p)) that results from
11065 * the column-wise concatenation of @a and @b, or NULL on failure.
11066 */
11067
11068 gretl_matrix *
gretl_matrix_col_concat(const gretl_matrix * a,const gretl_matrix * b,int * err)11069 gretl_matrix_col_concat (const gretl_matrix *a, const gretl_matrix *b,
11070 int *err)
11071 {
11072 gretl_matrix *c = NULL;
11073
11074 if (a == NULL || b == NULL) {
11075 *err = E_DATA;
11076 } else if (true_null_matrix(a)) {
11077 c = gretl_matrix_copy(b);
11078 goto finish;
11079 } else if (true_null_matrix(b)) {
11080 c = gretl_matrix_copy(a);
11081 goto finish;
11082 }
11083
11084 if (!*err) {
11085 int cmplx_a = a->is_complex;
11086 int cmplx_b = b->is_complex;
11087 int cmplx_c = cmplx_a || cmplx_b;
11088 int scalar_a = 0;
11089 int scalar_b = 0;
11090 int n_a = a->rows * a->cols;
11091 int n_b = b->rows * b->cols;
11092 size_t xsize = sizeof(double);
11093 size_t zsize = sizeof(double complex);
11094 double complex z;
11095 int i, cr, cc;
11096
11097 if (matrix_is_scalar(a) && b->rows != 1) {
11098 scalar_a = 1;
11099 cr = b->rows;
11100 cc = b->cols + 1;
11101 } else if (matrix_is_scalar(b) && a->rows != 1) {
11102 scalar_b = 1;
11103 cr = a->rows;
11104 cc = a->cols + 1;
11105 } else if (a->rows != b->rows) {
11106 *err = E_NONCONF;
11107 return NULL;
11108 } else if (a->rows == 0 || a->cols + b->cols == 0) {
11109 cr = cc = 0;
11110 } else {
11111 cr = a->rows;
11112 cc = a->cols + b->cols;
11113 }
11114
11115 if (cr == 0 && cc == 0) {
11116 c = gretl_null_matrix_new();
11117 } else if (cmplx_c) {
11118 c = gretl_cmatrix_new(cr, cc);
11119 } else {
11120 c = gretl_matrix_alloc(cr, cc);
11121 }
11122 if (c == NULL) {
11123 *err = E_ALLOC;
11124 return NULL;
11125 } else if (cr == 0) {
11126 return c;
11127 }
11128
11129 if (scalar_a) {
11130 if (!cmplx_c) {
11131 memcpy(c->val + b->rows, b->val, n_b * xsize);
11132 } else if (cmplx_b) {
11133 memcpy(c->z + b->rows, b->z, n_b * zsize);
11134 } else {
11135 real_to_complex_fill(c, b, 0, 1);
11136 }
11137 for (i=0; i<b->rows; i++) {
11138 if (cmplx_c) {
11139 z = cmplx_a ? a->z[0] : a->val[0];
11140 gretl_cmatrix_set(c, i, 0, z);
11141 } else {
11142 gretl_matrix_set(c, i, 0, a->val[0]);
11143 }
11144 }
11145 } else if (scalar_b) {
11146 if (!cmplx_c) {
11147 memcpy(c->val, a->val, n_a * xsize);
11148 } else if (cmplx_a) {
11149 memcpy(c->z, a->z, n_a * zsize);
11150 } else {
11151 real_to_complex_fill(c, a, 0, 0);
11152 }
11153 for (i=0; i<a->rows; i++) {
11154 if (cmplx_c) {
11155 z = cmplx_b ? b->z[0] : b->val[0];
11156 gretl_cmatrix_set(c, i, a->cols, z);
11157 } else {
11158 gretl_matrix_set(c, i, a->cols, b->val[0]);
11159 }
11160 }
11161 } else {
11162 /* neither @a nor @b is scalar */
11163 if (!cmplx_c) {
11164 memcpy(c->val, a->val, n_a * xsize);
11165 memcpy(c->val + n_a, b->val, n_b * xsize);
11166 } else {
11167 if (cmplx_a) {
11168 memcpy(c->z, a->z, n_a * zsize);
11169 } else {
11170 real_to_complex_fill(c, a, 0, 0);
11171 }
11172 if (cmplx_b) {
11173 memcpy(c->z + n_a, b->z, n_b * zsize);
11174 } else {
11175 real_to_complex_fill(c, b, 0, a->cols);
11176 }
11177 }
11178 }
11179 }
11180
11181 finish:
11182
11183 if (!*err) {
11184 if (c == NULL) {
11185 *err = E_ALLOC;
11186 } else {
11187 maybe_preserve_names(c, a, ROWNAMES, NULL);
11188 maybe_concat_names(c, a, b, COLNAMES);
11189 }
11190 }
11191
11192 return c;
11193 }
11194
11195 /**
11196 * gretl_matrix_direct_sum:
11197 * @a: top left matrix.
11198 * @b: bottom right matrix.
11199 * @err: location to receive error code.
11200 *
11201 * Returns: a new matrix containing the direct sum of @a and
11202 * @b, or NULL on failure.
11203 */
11204
gretl_matrix_direct_sum(const gretl_matrix * a,const gretl_matrix * b,int * err)11205 gretl_matrix *gretl_matrix_direct_sum (const gretl_matrix *a,
11206 const gretl_matrix *b,
11207 int *err)
11208 {
11209 gretl_matrix *c = NULL;
11210
11211 if (gretl_is_null_matrix(a) && gretl_is_null_matrix(b)) {
11212 c = gretl_null_matrix_new();
11213 } else if (a->is_complex + b->is_complex == 1) {
11214 *err = E_MIXED;
11215 } else if (gretl_is_null_matrix(a)) {
11216 c = gretl_matrix_copy(b);
11217 } else if (gretl_is_null_matrix(b)) {
11218 c = gretl_matrix_copy(a);
11219 } else {
11220 int m = a->rows + b->rows;
11221 int n = a->cols + b->cols;
11222 int i, j, k;
11223 double complex z;
11224 double x;
11225
11226 if (a->is_complex) {
11227 c = gretl_cmatrix_new0(m, n);
11228 } else {
11229 c = gretl_zero_matrix_new(m, n);
11230 }
11231
11232 if (c != NULL) {
11233 for (i=0; i<a->rows; i++) {
11234 for (j=0; j<a->cols; j++) {
11235 if (a->is_complex) {
11236 z = gretl_cmatrix_get(a, i, j);
11237 gretl_cmatrix_set(c, i, j, z);
11238 } else {
11239 x = gretl_matrix_get(a, i, j);
11240 gretl_matrix_set(c, i, j, x);
11241 }
11242 }
11243 }
11244 for (i=0; i<b->rows; i++) {
11245 k = i + a->rows;
11246 for (j=0; j<b->cols; j++) {
11247 if (a->is_complex) {
11248 z = gretl_cmatrix_get(b, i, j);
11249 gretl_cmatrix_set(c, k, j + a->cols, z);
11250 } else {
11251 x = gretl_matrix_get(b, i, j);
11252 gretl_matrix_set(c, k, j + a->cols, x);
11253 }
11254 }
11255 }
11256 }
11257 }
11258
11259 if (!*err && c == NULL) {
11260 *err = E_ALLOC;
11261 }
11262
11263 return c;
11264 }
11265
11266 /**
11267 * gretl_matrix_inplace_colcat:
11268 * @a: matrix to be enlarged (m x n).
11269 * @b: matrix from which columns should be added (m x p).
11270 * @mask: char array, of length p, with 1s in positions
11271 * corresponding to columns of @b that are to be added
11272 * to @a, 0s elsewhere; or NULL to add all columns
11273 * of @b.
11274 *
11275 * Concatenates onto @a the selected columns of @b, if the
11276 * two matrices are conformable.
11277 *
11278 * Returns: 0 on success, non-zero code on error.
11279 */
11280
gretl_matrix_inplace_colcat(gretl_matrix * a,const gretl_matrix * b,const char * mask)11281 int gretl_matrix_inplace_colcat (gretl_matrix *a,
11282 const gretl_matrix *b,
11283 const char *mask)
11284 {
11285 double x;
11286 int addc;
11287 int i, j, k;
11288
11289 if (a == NULL || b == NULL) {
11290 return E_DATA;
11291 } else if (a->is_complex || b->is_complex) {
11292 fprintf(stderr, "E_CMPLX in gretl_matrix_inplace_colcat\n");
11293 return E_CMPLX;
11294 } else if (a->rows != b->rows) {
11295 return E_NONCONF;
11296 }
11297
11298 if (mask == NULL) {
11299 addc = b->cols;
11300 } else {
11301 addc = 0;
11302 for (j=0; j<b->cols; j++) {
11303 if (mask[j]) addc++;
11304 }
11305 if (addc == 0) {
11306 return 0;
11307 }
11308 }
11309
11310 k = a->cols;
11311
11312 if (gretl_matrix_realloc(a, a->rows, k + addc)) {
11313 return E_ALLOC;
11314 }
11315
11316 if (mask == NULL) {
11317 size_t bsize = b->rows * b->cols * sizeof *b->val;
11318
11319 memcpy(a->val + a->rows * k, b->val, bsize);
11320 } else {
11321 for (j=0; j<b->cols; j++) {
11322 if (mask[j]) {
11323 for (i=0; i<b->rows; i++) {
11324 x = gretl_matrix_get(b, i, j);
11325 gretl_matrix_set(a, i, k, x);
11326 }
11327 k++;
11328 }
11329 }
11330 }
11331
11332 return 0;
11333 }
11334
11335 /**
11336 * gretl_matrix_cumcol:
11337 * @m: source matrix.
11338 * @err: error code.
11339 *
11340 * Returns: a matrix of the same dimensions as @m, containing
11341 * the cumulated columns of @m.
11342 */
11343
gretl_matrix_cumcol(const gretl_matrix * m,int * err)11344 gretl_matrix *gretl_matrix_cumcol (const gretl_matrix *m, int *err)
11345 {
11346 gretl_matrix *a;
11347 int t, i;
11348
11349 *err = 0;
11350
11351 if (gretl_is_null_matrix(m)) {
11352 return NULL;
11353 }
11354
11355 a = gretl_matching_matrix_new(m->rows, m->cols, m);
11356
11357 if (a == NULL) {
11358 *err = E_ALLOC;
11359 } else if (a->is_complex) {
11360 double complex z;
11361
11362 for (i=0; i<m->cols; i++) {
11363 z = 0;
11364 for (t=0; t<m->rows; t++) {
11365 z += gretl_cmatrix_get(m, t, i);
11366 gretl_cmatrix_set(a, t, i, z);
11367 }
11368 }
11369 } else {
11370 double x;
11371
11372 for (i=0; i<m->cols; i++) {
11373 x = 0;
11374 for (t=0; t<m->rows; t++) {
11375 x += gretl_matrix_get(m, t, i);
11376 gretl_matrix_set(a, t, i, x);
11377 }
11378 }
11379 }
11380
11381 return a;
11382 }
11383
11384 /**
11385 * gretl_matrix_diffcol:
11386 * @m: source matrix.
11387 * @missval: value to represent missing observations.
11388 * @err: error code.
11389 *
11390 * Returns: a matrix of the same dimensions as @m, containing
11391 * @missval in the first row and the difference between consecutive
11392 * rows of @m afterwards.
11393 */
11394
gretl_matrix_diffcol(const gretl_matrix * m,double missval,int * err)11395 gretl_matrix *gretl_matrix_diffcol (const gretl_matrix *m,
11396 double missval, int *err)
11397 {
11398 gretl_matrix *a;
11399 int t, i;
11400
11401 *err = 0;
11402
11403 if (gretl_is_null_matrix(m)) {
11404 return NULL;
11405 }
11406
11407 a = gretl_matching_matrix_new(m->rows, m->cols, m);
11408
11409 if (a == NULL) {
11410 *err = E_ALLOC;
11411 } else if (a->is_complex) {
11412 double complex z, zlag;
11413
11414 for (i=0; i<m->cols; i++) {
11415 gretl_cmatrix_set(a, 0, i, missval);
11416 }
11417 for (i=0; i<m->cols; i++) {
11418 zlag = gretl_cmatrix_get(m, 0, i);
11419 for (t=1; t<m->rows; t++) {
11420 z = gretl_cmatrix_get(m, t, i);
11421 gretl_cmatrix_set(a, t, i, z - zlag);
11422 zlag = z;
11423 }
11424 }
11425 } else {
11426 double x, xlag;
11427
11428 for (i=0; i<m->cols; i++) {
11429 gretl_matrix_set(a, 0, i, missval);
11430 }
11431 for (i=0; i<m->cols; i++) {
11432 xlag = gretl_matrix_get(m, 0, i);
11433 for (t=1; t<m->rows; t++) {
11434 x = gretl_matrix_get(m, t, i);
11435 gretl_matrix_set(a, t, i, x - xlag);
11436 xlag = x;
11437 }
11438 }
11439 }
11440
11441 return a;
11442 }
11443
11444 /**
11445 * gretl_matrix_lag:
11446 * @m: source matrix.
11447 * @k: vector of lag orders (> 0 for lags, < 0 for leads).
11448 * @opt: use OPT_L to arrange multiple lags by lag rather than by variable.
11449 * @missval: value to represent missing observations.
11450 *
11451 * Returns: A matrix of the same dimensions as @m, containing lags
11452 * of the variables in the columns of @m, with missing values set
11453 * to @missval.
11454 */
11455
gretl_matrix_lag(const gretl_matrix * m,const gretl_vector * k,gretlopt opt,double missval)11456 gretl_matrix *gretl_matrix_lag (const gretl_matrix *m,
11457 const gretl_vector *k,
11458 gretlopt opt,
11459 double missval)
11460 {
11461 gretl_matrix *a;
11462 double x;
11463 int l = gretl_vector_get_length(k);
11464 int s, t, i, j, n, kj;
11465
11466 if (gretl_is_null_matrix(m) || l == 0 || m->is_complex) {
11467 return NULL;
11468 }
11469
11470 a = gretl_matrix_alloc(m->rows, m->cols * l);
11471 if (a == NULL) {
11472 return NULL;
11473 }
11474
11475 if (opt & OPT_L) {
11476 /* by lag */
11477 n = 0;
11478 for (j=0; j<l; j++) {
11479 kj = gretl_vector_get(k, j);
11480 for (t=0; t<m->rows; t++) {
11481 s = t - kj;
11482 if (s < 0 || s >= m->rows) {
11483 for (i=0; i<m->cols; i++) {
11484 gretl_matrix_set(a, t, n+i, missval);
11485 }
11486 } else {
11487 for (i=0; i<m->cols; i++) {
11488 x = gretl_matrix_get(m, s, i);
11489 gretl_matrix_set(a, t, n+i, x);
11490 }
11491 }
11492 }
11493 n += m->cols;
11494 }
11495 } else {
11496 /* by variable */
11497 n = 0;
11498 for (i=0; i<m->cols; i++) {
11499 for (j=0; j<l; j++) {
11500 kj = gretl_vector_get(k, j);
11501 for (t=0; t<m->rows; t++) {
11502 s = t - kj;
11503 if (s < 0 || s >= m->rows) {
11504 gretl_matrix_set(a, t, n+j, missval);
11505 } else {
11506 x = gretl_matrix_get(m, s, i);
11507 gretl_matrix_set(a, t, n+j, x);
11508 }
11509 }
11510 }
11511 n += l;
11512 }
11513 }
11514
11515 return a;
11516 }
11517
11518 /**
11519 * gretl_matrix_inplace_lag:
11520 * @targ: target matrix.
11521 * @src: source matrix.
11522 * @k: lag order (> 0 for lags, < 0 for leads).
11523 *
11524 * Fills out @targ (if it is of the correct dimensions),
11525 * with (columnwise) lags of @src, using 0 for missing
11526 * values.
11527 *
11528 * Returns: 0 on success, non-zero code otherwise.
11529 */
11530
gretl_matrix_inplace_lag(gretl_matrix * targ,const gretl_matrix * src,int k)11531 int gretl_matrix_inplace_lag (gretl_matrix *targ,
11532 const gretl_matrix *src,
11533 int k)
11534 {
11535 int m, n;
11536 double x;
11537 int s, t, i;
11538
11539 if (gretl_is_null_matrix(targ) || gretl_is_null_matrix(src)) {
11540 return E_DATA;
11541 }
11542
11543 m = src->rows;
11544 n = src->cols;
11545
11546 if (targ->rows != m || targ->cols != n) {
11547 return E_NONCONF;
11548 }
11549
11550 for (t=0; t<m; t++) {
11551 s = t - k;
11552 if (s < 0 || s >= m) {
11553 for (i=0; i<n; i++) {
11554 gretl_matrix_set(targ, t, i, 0.0);
11555 }
11556 } else {
11557 for (i=0; i<n; i++) {
11558 x = gretl_matrix_get(src, s, i);
11559 gretl_matrix_set(targ, t, i, x);
11560 }
11561 }
11562 }
11563
11564 return 0;
11565 }
11566
11567 /* the most common use-case here will be updating the t1 and t2
11568 members of targ's info based on src's info: this naturally
11569 arises when a new m x n matrix is generated and its content is
11570 assigned to an existing m x n matrix
11571 */
11572
gretl_matrix_copy_info(gretl_matrix * targ,const gretl_matrix * src)11573 static int gretl_matrix_copy_info (gretl_matrix *targ,
11574 const gretl_matrix *src)
11575 {
11576 int err = 0;
11577
11578 if (is_block_matrix(targ) || is_block_matrix(src)) {
11579 return E_DATA;
11580 }
11581
11582 if (src->info == NULL || src->is_complex) {
11583 if (targ->info != NULL) {
11584 gretl_matrix_destroy_info(targ);
11585 }
11586 return 0;
11587 }
11588
11589 if (targ->info == NULL) {
11590 targ->info = malloc(sizeof *targ->info);
11591 } else {
11592 strings_array_free(targ->info->colnames, targ->cols);
11593 strings_array_free(targ->info->rownames, targ->rows);
11594 }
11595
11596 if (targ->info == NULL) {
11597 err = E_ALLOC;
11598 } else {
11599 targ->info->t1 = src->info->t1;
11600 targ->info->t2 = src->info->t2;
11601 targ->info->colnames = NULL;
11602 targ->info->rownames = NULL;
11603 if (src->info->colnames != NULL) {
11604 targ->info->colnames = strings_array_dup(src->info->colnames,
11605 src->cols);
11606 if (targ->info->colnames == NULL) {
11607 err = E_ALLOC;
11608 }
11609 }
11610 if (!err && src->info->rownames != NULL) {
11611 targ->info->rownames = strings_array_dup(src->info->rownames,
11612 src->rows);
11613 if (targ->info->rownames == NULL) {
11614 err = E_ALLOC;
11615 }
11616 }
11617 }
11618
11619 return err;
11620 }
11621
gretl_matrix_add_info(gretl_matrix * m)11622 static int gretl_matrix_add_info (gretl_matrix *m)
11623 {
11624 m->info = malloc(sizeof *m->info);
11625
11626 if (m->info == NULL) {
11627 return E_ALLOC;
11628 } else {
11629 m->info->t1 = 0;
11630 m->info->t2 = 0;
11631 m->info->colnames = NULL;
11632 m->info->rownames = NULL;
11633 return 0;
11634 }
11635 }
11636
11637 /**
11638 * gretl_matrix_set_t1:
11639 * @m: matrix to operate on.
11640 * @t: integer value to set.
11641 *
11642 * Sets an integer value on @m, which can be retrieved using
11643 * gretl_matrix_get_t1().
11644 *
11645 * Returns: 0 on success, non-ero on error.
11646 */
11647
gretl_matrix_set_t1(gretl_matrix * m,int t)11648 int gretl_matrix_set_t1 (gretl_matrix *m, int t)
11649 {
11650 if (m == NULL) {
11651 return E_DATA;
11652 } else if (is_block_matrix(m)) {
11653 return matrix_block_error("gretl_matrix_set_t1");
11654 } else if (m->info == NULL && gretl_matrix_add_info(m)) {
11655 return E_ALLOC;
11656 }
11657
11658 m->info->t1 = t;
11659
11660 return 0;
11661 }
11662
11663 /**
11664 * gretl_matrix_set_t2:
11665 * @m: matrix to operate on.
11666 * @t: integer value to set.
11667 *
11668 * Sets an integer value on @m, which can be retrieved using
11669 * gretl_matrix_get_t2().
11670 *
11671 * Returns: 0 on success, non-ero on error.
11672 */
11673
gretl_matrix_set_t2(gretl_matrix * m,int t)11674 int gretl_matrix_set_t2 (gretl_matrix *m, int t)
11675 {
11676 if (m == NULL) {
11677 return E_DATA;
11678 } else if (is_block_matrix(m)) {
11679 return matrix_block_error("gretl_matrix_set_t2");
11680 } else if (m->info == NULL && gretl_matrix_add_info(m)) {
11681 return E_ALLOC;
11682 }
11683
11684 m->info->t2 = t;
11685
11686 return 0;
11687 }
11688
11689 /**
11690 * gretl_matrix_get_t1:
11691 * @m: matrix to read from.
11692 *
11693 * Returns: the integer that has been set on @m using
11694 * gretl_matrix_set_t1(), or zero if no such value has
11695 * been set.
11696 */
11697
gretl_matrix_get_t1(const gretl_matrix * m)11698 int gretl_matrix_get_t1 (const gretl_matrix *m)
11699 {
11700 if (m != NULL && !is_block_matrix(m) && m->info != NULL) {
11701 return m->info->t1;
11702 } else {
11703 return 0;
11704 }
11705 }
11706
11707 /**
11708 * gretl_matrix_get_t2:
11709 * @m: matrix to read from.
11710 *
11711 * Returns: the integer that has been set on @m using
11712 * gretl_matrix_set_t2(), or zero if no such value has
11713 * been set.
11714 */
11715
gretl_matrix_get_t2(const gretl_matrix * m)11716 int gretl_matrix_get_t2 (const gretl_matrix *m)
11717 {
11718 if (m != NULL && !is_block_matrix(m) && m->info != NULL) {
11719 return m->info->t2;
11720 } else {
11721 return 0;
11722 }
11723 }
11724
11725 /**
11726 * gretl_matrix_is_dated:
11727 * @m: matrix to examine.
11728 *
11729 * Returns: 1 if matrix @m has integer indices recorded
11730 * via gretl_matrix_set_t1() and gretl_matrix_set_t2(),
11731 * such that t1 >= 0 and t2 > t1, otherwise zero.
11732 */
11733
gretl_matrix_is_dated(const gretl_matrix * m)11734 int gretl_matrix_is_dated (const gretl_matrix *m)
11735 {
11736 if (m != NULL && !is_block_matrix(m) && m->info != NULL) {
11737 return (m->info->t1 >= 0 && (m->info->t2 > m->info->t1));
11738 } else {
11739 return 0;
11740 }
11741 }
11742
11743 static int
get_SVD_ols_vcv(const gretl_matrix * A,const gretl_matrix * B,const double * s,gretl_matrix * V,double * s2)11744 get_SVD_ols_vcv (const gretl_matrix *A, const gretl_matrix *B,
11745 const double *s, gretl_matrix *V, double *s2)
11746 {
11747 double aik, ajk, vij;
11748 int m = A->cols;
11749 int i, j, k;
11750
11751 /* Get X'X{-1}, based on the work done by the SV decomp:
11752 reciprocals of the squares of the (positive) singular values,
11753 premultiplied by V and postmultiplied by V-transpose
11754 */
11755 for (i=0; i<m; i++) {
11756 for (j=i; j<m; j++) {
11757 vij = 0.0;
11758 for (k=0; k<m; k++) {
11759 if (s[k] > 0.0) {
11760 aik = gretl_matrix_get(A, k, i);
11761 ajk = gretl_matrix_get(A, k, j);
11762 vij += aik * ajk / (s[k] * s[k]);
11763 }
11764 }
11765 gretl_matrix_set(V, i, j, vij);
11766 if (j != i) {
11767 gretl_matrix_set(V, j, i, vij);
11768 }
11769 }
11770 }
11771
11772 if (s2 != NULL) {
11773 double sigma2 = 0.0;
11774 int T = A->rows;
11775
11776 for (i=m; i<T; i++) {
11777 sigma2 += B->val[i] * B->val[i];
11778 }
11779 sigma2 /= T - m;
11780 gretl_matrix_multiply_by_scalar(V, sigma2);
11781 *s2 = sigma2;
11782 }
11783
11784 return 0;
11785 }
11786
11787 static double
get_ols_error_variance(const gretl_vector * y,const gretl_matrix * X,const gretl_vector * b,int nr)11788 get_ols_error_variance (const gretl_vector *y, const gretl_matrix *X,
11789 const gretl_vector *b, int nr)
11790 {
11791 double u, s2 = 0.0;
11792 int k = X->cols; /* number of regressors */
11793 int n = X->rows; /* number of observations */
11794 int i, j;
11795
11796 for (i=0; i<n; i++) {
11797 u = y->val[i];
11798 for (j=0; j<k; j++) {
11799 u -= gretl_matrix_get(X, i, j) * b->val[j];
11800 }
11801 s2 += u * u;
11802 }
11803
11804 s2 /= (n - k + nr); /* nr = number of restrictions */
11805
11806 return s2;
11807 }
11808
get_ols_vcv(gretl_matrix * V,double * s2)11809 static int get_ols_vcv (gretl_matrix *V, double *s2)
11810 {
11811 if (gretl_invert_general_matrix(V)) {
11812 gretl_matrix_print(V, "get_ols_vcv: inversion failed");
11813 return 1;
11814 }
11815
11816 if (s2 != NULL) {
11817 gretl_matrix_multiply_by_scalar(V, *s2);
11818 }
11819
11820 return 0;
11821 }
11822
11823 static void
get_ols_uhat(const gretl_vector * y,const gretl_matrix * X,const gretl_vector * b,gretl_vector * uhat)11824 get_ols_uhat (const gretl_vector *y, const gretl_matrix *X,
11825 const gretl_vector *b, gretl_vector *uhat)
11826 {
11827 int ncoeff = gretl_vector_get_length(b);
11828 int n = gretl_vector_get_length(uhat);
11829 int i, j;
11830 double uh;
11831
11832 for (i=0; i<n; i++) {
11833 uh = y->val[i];
11834 for (j=0; j<ncoeff; j++) {
11835 uh -= b->val[j] * gretl_matrix_get(X, i, j);
11836 }
11837 uhat->val[i] = uh;
11838 }
11839 }
11840
11841 #define PREFER_DGELSD 0
11842
svd_ols_work(gretl_matrix * A,gretl_matrix * B,double * s,int use_dc)11843 static int svd_ols_work (gretl_matrix *A,
11844 gretl_matrix *B,
11845 double *s,
11846 int use_dc)
11847 {
11848 double *work = NULL;
11849 double rcond = 0.0;
11850 integer m, n, nrhs;
11851 integer lda, ldb;
11852 integer lwork = -1;
11853 integer liwork = 0;
11854 integer rank;
11855 integer info;
11856 integer *iwork = NULL;
11857 int err = 0;
11858
11859 work = lapack_malloc(sizeof *work);
11860 if (work == NULL) {
11861 return E_ALLOC;
11862 }
11863
11864 lda = ldb = m = A->rows;
11865 n = A->cols;
11866 nrhs = B->cols;
11867
11868 /* workspace query */
11869 if (use_dc) {
11870 dgelsd_(&m, &n, &nrhs, A->val, &lda, B->val, &ldb, s, &rcond,
11871 &rank, work, &lwork, &liwork, &info);
11872 } else {
11873 dgelss_(&m, &n, &nrhs, A->val, &lda, B->val, &ldb, s, &rcond,
11874 &rank, work, &lwork, &info);
11875 }
11876
11877 if (info != 0 || work[0] <= 0.0) {
11878 return wspace_fail(info, work[0]);
11879 }
11880
11881 lwork = (integer) work[0];
11882 work = lapack_realloc(work, lwork * sizeof *work);
11883 if (work == NULL) {
11884 return E_ALLOC;
11885 }
11886
11887 if (use_dc) {
11888 iwork = malloc(liwork * sizeof *iwork);
11889 if (iwork == NULL) {
11890 return E_ALLOC;
11891 }
11892 }
11893
11894 /* get actual solution */
11895 if (use_dc) {
11896 dgelsd_(&m, &n, &nrhs, A->val, &lda, B->val, &ldb, s, &rcond,
11897 &rank, work, &lwork, iwork, &info);
11898 } else {
11899 dgelss_(&m, &n, &nrhs, A->val, &lda, B->val, &ldb, s, &rcond,
11900 &rank, work, &lwork, &info);
11901 }
11902
11903 if (info != 0) {
11904 fprintf(stderr, "svd_ols_work: got info = %d (with use_dc = %d)\n",
11905 info, use_dc);
11906 err = E_NOCONV;
11907 } else if (rank < n) {
11908 fprintf(stderr, "svd_ols_work:\n"
11909 " data matrix X (%d x %d) has column rank %d\n",
11910 m, n, (int) rank);
11911 }
11912
11913 lapack_free(work);
11914 free(iwork);
11915
11916 return err;
11917 }
11918
11919 /**
11920 * gretl_matrix_SVD_ols:
11921 * @y: dependent variable vector.
11922 * @X: matrix of independent variables.
11923 * @b: vector to hold coefficient estimates.
11924 * @vcv: matrix to hold the covariance matrix of the coefficients,
11925 * or NULL if this is not needed.
11926 * @uhat: vector to hold the regression residuals, or NULL if
11927 * these are not needed.
11928 * @s2: pointer to receive residual variance, or NULL. Note:
11929 * if @s2 is NULL, the vcv estimate will be plain (X'X)^{-1}.
11930 *
11931 * Computes OLS estimates using SVD decomposition, and puts the
11932 * coefficient estimates in @b. Optionally, calculates the
11933 * covariance matrix in @vcv and the residuals in @uhat.
11934 *
11935 * Returns: 0 on success, non-zero error code on failure.
11936 */
11937
gretl_matrix_SVD_ols(const gretl_vector * y,const gretl_matrix * X,gretl_vector * b,gretl_matrix * vcv,gretl_vector * uhat,double * s2)11938 int gretl_matrix_SVD_ols (const gretl_vector *y, const gretl_matrix *X,
11939 gretl_vector *b, gretl_matrix *vcv,
11940 gretl_vector *uhat, double *s2)
11941 {
11942 gretl_vector *A = NULL;
11943 gretl_matrix *B = NULL;
11944 double *s = NULL;
11945 int k, use_dc = 0;
11946 int err = 0;
11947
11948 if (gretl_is_null_matrix(y) ||
11949 gretl_is_null_matrix(X) ||
11950 gretl_is_null_matrix(b)) {
11951 return E_DATA;
11952 }
11953
11954 #if PREFER_DGELSD
11955 if (vcv == NULL) {
11956 /* we don't need the right singular vectors, and
11957 so can use the divide and conquer SVD variant
11958 */
11959 use_dc = 1;
11960 }
11961 #endif
11962
11963 k = X->cols;
11964
11965 if (gretl_vector_get_length(b) != k) {
11966 return E_NONCONF;
11967 }
11968
11969 A = gretl_matrix_copy_tmp(X);
11970 B = gretl_matrix_copy_tmp(y);
11971
11972 if (A == NULL || B == NULL) {
11973 err = E_ALLOC;
11974 goto bailout;
11975 }
11976
11977 /* for singular values of A */
11978 s = malloc(k * sizeof *s);
11979 if (s == NULL) {
11980 err = E_ALLOC;
11981 goto bailout;
11982 }
11983
11984 err = svd_ols_work(A, B, s, use_dc);
11985
11986 if (!err) {
11987 int i;
11988
11989 for (i=0; i<k; i++) {
11990 b->val[i] = B->val[i];
11991 }
11992 if (vcv != NULL) {
11993 err = get_SVD_ols_vcv(A, B, s, vcv, s2);
11994 }
11995 if (uhat != NULL) {
11996 get_ols_uhat(y, X, b, uhat);
11997 }
11998 }
11999
12000 bailout:
12001
12002 gretl_matrix_free(A);
12003 gretl_matrix_free(B);
12004 free(s);
12005
12006 return err;
12007 }
12008
12009 /**
12010 * gretl_matrix_multi_SVD_ols:
12011 * @y: T x g matrix of dependent variables.
12012 * @X: T x k matrix of independent variables.
12013 * @B: k x g matrix to hold coefficient estimates, or NULL.
12014 * @E: T x g matrix to hold the regression residuals, or NULL if these are
12015 * not needed.
12016 * @XTXi: location to receive (X'X)^{-1}, or NULL if this is not needed.
12017 *
12018 * Computes OLS estimates using SVD decomposition, and puts the
12019 * coefficient estimates in @B. Optionally, calculates the
12020 * residuals in @E, (X'X)^{-1} in @XTXi.
12021 *
12022 * Returns: 0 on success, non-zero error code on failure.
12023 */
12024
gretl_matrix_multi_SVD_ols(const gretl_matrix * Y,const gretl_matrix * X,gretl_matrix * B,gretl_matrix * E,gretl_matrix ** XTXi)12025 int gretl_matrix_multi_SVD_ols (const gretl_matrix *Y,
12026 const gretl_matrix *X,
12027 gretl_matrix *B,
12028 gretl_matrix *E,
12029 gretl_matrix **XTXi)
12030 {
12031 int g, k, T;
12032 gretl_matrix *A = NULL;
12033 gretl_matrix *C = NULL;
12034 double *s = NULL;
12035 int free_B = 0;
12036 int use_dc = 0;
12037 int err = 0;
12038
12039 if (gretl_is_null_matrix(Y) ||
12040 gretl_is_null_matrix(X)) {
12041 return E_DATA;
12042 }
12043
12044 #if PREFER_DGELSD
12045 if (XTXi == NULL) {
12046 /* we don't need the right singular vectors, and
12047 so can use the divide and conquer SVD variant
12048 */
12049 use_dc = 1;
12050 }
12051 #endif
12052
12053 g = Y->cols;
12054 k = X->cols;
12055 T = X->rows;
12056
12057 if (B == NULL) {
12058 B = gretl_matrix_alloc(k, g);
12059 if (B == NULL) {
12060 return E_ALLOC;
12061 }
12062 free_B = 1;
12063 }
12064
12065 if (B->rows != k || B->cols != g) {
12066 err = E_NONCONF;
12067 } else if (Y->rows != T) {
12068 err = E_NONCONF;
12069 } else if (E != NULL && (E->cols != g || E->rows != T)) {
12070 err = E_NONCONF;
12071 } else if (k > T) {
12072 err = E_DF;
12073 }
12074
12075 A = gretl_matrix_copy_tmp(X);
12076 C = gretl_matrix_copy_tmp(Y);
12077
12078 if (A == NULL || C == NULL) {
12079 err = E_ALLOC;
12080 goto bailout;
12081 }
12082
12083 /* for singular values of A */
12084 s = malloc(k * sizeof *s);
12085 if (s == NULL) {
12086 err = E_ALLOC;
12087 goto bailout;
12088 }
12089
12090 err = svd_ols_work(A, C, s, use_dc);
12091
12092 if (!err) {
12093 /* coeffs: extract the first k rows from @C */
12094 double bij;
12095 int i, j;
12096
12097 for (i=0; i<k; i++) {
12098 for (j=0; j<g; j++) {
12099 bij = gretl_matrix_get(C, i, j);
12100 gretl_matrix_set(B, i, j, bij);
12101 }
12102 }
12103 }
12104
12105 if (!err && E != NULL) {
12106 /* compute residuals, if wanted */
12107 int i, imax = E->rows * E->cols;
12108
12109 gretl_matrix_multiply(X, B, E);
12110 for (i=0; i<imax; i++) {
12111 E->val[i] = Y->val[i] - E->val[i];
12112 }
12113 }
12114
12115 if (!err && XTXi != NULL) {
12116 /* build (X'X)^{-1}, if wanted */
12117 *XTXi = gretl_matrix_alloc(k, k);
12118 if (*XTXi == NULL) {
12119 err = E_ALLOC;
12120 } else {
12121 err = get_SVD_ols_vcv(A, C, s, *XTXi, NULL);
12122 }
12123 }
12124
12125 bailout:
12126
12127 gretl_matrix_free(A);
12128 gretl_matrix_free(C);
12129 free(s);
12130
12131 if (free_B) {
12132 gretl_matrix_free(B);
12133 }
12134
12135 return err;
12136 }
12137
12138 /**
12139 * gretl_matrix_moore_penrose:
12140 * @a: m x n matrix.
12141 *
12142 * Computes the generalized inverse of matrix @a via its SVD
12143 * factorization, with the help of the lapack function
12144 * dgesvd. On exit the original matrix is overwritten by
12145 * the inverse.
12146 *
12147 * Returns: 0 on success; non-zero error code on failure.
12148 */
12149
gretl_matrix_moore_penrose(gretl_matrix * A)12150 int gretl_matrix_moore_penrose (gretl_matrix *A)
12151 {
12152 gretl_matrix *U = NULL;
12153 gretl_matrix *S = NULL;
12154 gretl_matrix *VT = NULL;
12155 int err = 0;
12156
12157 if (gretl_is_null_matrix(A)) {
12158 return E_DATA;
12159 }
12160
12161 err = real_gretl_matrix_SVD(A, &U, &S, &VT, 0);
12162
12163 if (!err) {
12164 gretl_matrix *Vsel = NULL;
12165 int nsv = MIN(A->rows, A->cols);
12166 int i, j, k = 0;
12167 double x;
12168
12169 for (i=0; i<nsv; i++) {
12170 if (S->val[i] > SVD_SMIN) {
12171 k++;
12172 }
12173 }
12174
12175 if (k < VT->rows) {
12176 Vsel = gretl_matrix_alloc(k, VT->cols);
12177 if (Vsel == NULL) {
12178 err = E_ALLOC;
12179 goto bailout;
12180 }
12181 for (j=0; j<VT->cols; j++) {
12182 for (i=0; i<k; i++) {
12183 x = gretl_matrix_get(VT, i, j);
12184 gretl_matrix_set(Vsel, i, j, x);
12185 }
12186 }
12187 }
12188
12189 /* U <- U .* S^{-1}, for S[j] > min */
12190 for (i=0; i<U->rows; i++) {
12191 for (j=0; j<k; j++) {
12192 x = gretl_matrix_get(U, i, j);
12193 gretl_matrix_set(U, i, j, x / S->val[j]);
12194 }
12195 }
12196 if (k < U->cols) {
12197 gretl_matrix_reuse(U, -1, k);
12198 }
12199
12200 err = gretl_matrix_multiply_mod(U, GRETL_MOD_NONE,
12201 Vsel != NULL ? Vsel : VT,
12202 GRETL_MOD_NONE,
12203 A, GRETL_MOD_NONE);
12204 if (!err) {
12205 gretl_matrix_transpose_in_place(A);
12206 }
12207 gretl_matrix_free(Vsel);
12208 }
12209
12210 bailout:
12211
12212 gretl_matrix_free(U);
12213 gretl_matrix_free(S);
12214 gretl_matrix_free(VT);
12215
12216 return err;
12217 }
12218
12219 /**
12220 * gretl_SVD_invert_matrix:
12221 * @a: n x n matrix to invert.
12222 *
12223 * Computes the inverse (or generalized inverse) of a general square
12224 * matrix using SVD factorization, with the help of the lapack function
12225 * dgesvd. If any of the singular values of @a are less than 1.0e-9
12226 * the Moore-Penrose generalized inverse is computed instead of the
12227 * standard inverse. On exit the original matrix is overwritten by
12228 * the inverse.
12229 *
12230 * Returns: 0 on success; non-zero error code on failure.
12231 */
12232
gretl_SVD_invert_matrix(gretl_matrix * a)12233 int gretl_SVD_invert_matrix (gretl_matrix *a)
12234 {
12235 gretl_matrix *u = NULL;
12236 gretl_matrix *s = NULL;
12237 gretl_matrix *vt = NULL;
12238 double x;
12239 int i, j, n;
12240 int rank = 0;
12241 int err = 0;
12242
12243 if (gretl_is_null_matrix(a)) {
12244 return E_DATA;
12245 }
12246
12247 if (a->rows != a->cols) {
12248 err = E_NONCONF;
12249 goto bailout;
12250 }
12251
12252 n = a->rows;
12253
12254 /* a = USV' ; a^{-1} = VWU' where W holds inverse of diag elements of S */
12255
12256 err = real_gretl_matrix_SVD(a, &u, &s, &vt, 0);
12257
12258 if (!err) {
12259 double smin = svd_smin(a, s->val[0]);
12260
12261 for (i=0; i<n; i++) {
12262 if (s->val[i] > smin) {
12263 rank++;
12264 } else {
12265 break;
12266 }
12267 }
12268
12269 if (rank < n) {
12270 gretl_matrix *vt2;
12271
12272 fprintf(stderr, "gretl_SVD_invert_matrix: rank = %d (dim = %d)\n",
12273 rank, n);
12274 fputs("Warning: computing Moore-Penrose generalized inverse\n", stderr);
12275
12276 vt2 = gretl_matrix_alloc(rank, n);
12277 if (vt2 == NULL) {
12278 err = E_ALLOC;
12279 goto bailout;
12280 }
12281 for (i=0; i<rank; i++) {
12282 for (j=0; j<n; j++) {
12283 x = gretl_matrix_get(vt, i, j);
12284 gretl_matrix_set(vt2, i, j, x);
12285 }
12286 }
12287 gretl_matrix_free(vt);
12288 vt = vt2;
12289 gretl_matrix_reuse(u, n, rank);
12290 }
12291 }
12292
12293 if (!err) {
12294 /* invert singular values */
12295 for (j=0; j<rank; j++) {
12296 for (i=0; i<n; i++) {
12297 x = gretl_matrix_get(u, i, j);
12298 gretl_matrix_set(u, i, j, x / s->val[j]);
12299 }
12300 }
12301 err = gretl_matrix_multiply_mod(vt, GRETL_MOD_TRANSPOSE,
12302 u, GRETL_MOD_TRANSPOSE,
12303 a, GRETL_MOD_NONE);
12304 }
12305
12306 bailout:
12307
12308 gretl_matrix_free(u);
12309 gretl_matrix_free(s);
12310 gretl_matrix_free(vt);
12311
12312 return err;
12313 }
12314
12315 /**
12316 * gretl_matrix_ols:
12317 * @y: dependent variable vector.
12318 * @X: matrix of independent variables.
12319 * @b: vector to hold coefficient estimates.
12320 * @vcv: matrix to hold the covariance matrix of the coefficients,
12321 * or NULL if this is not needed.
12322 * @uhat: vector to hold the regression residuals, or NULL if
12323 * these are not needed.
12324 * @s2: pointer to receive residual variance, or NULL. Note:
12325 * if @s2 is NULL, the "vcv" estimate will be plain (X'X)^{-1}.
12326 *
12327 * Computes OLS estimates using Cholesky factorization by default,
12328 * but with a fallback to QR decomposition if the data are highly
12329 * ill-conditioned, and puts the coefficient estimates in @b.
12330 * Optionally, calculates the covariance matrix in @vcv and the
12331 * residuals in @uhat.
12332 *
12333 * Returns: 0 on success, non-zero error code on failure.
12334 */
12335
gretl_matrix_ols(const gretl_vector * y,const gretl_matrix * X,gretl_vector * b,gretl_matrix * vcv,gretl_vector * uhat,double * s2)12336 int gretl_matrix_ols (const gretl_vector *y, const gretl_matrix *X,
12337 gretl_vector *b, gretl_matrix *vcv,
12338 gretl_vector *uhat, double *s2)
12339 {
12340 gretl_matrix *XTX = NULL;
12341 int use_lapack = 0;
12342 int try_QR = 0;
12343 int nasty = 0;
12344 int k, T, err = 0;
12345
12346 if (gretl_is_null_matrix(y) ||
12347 gretl_is_null_matrix(X) ||
12348 gretl_is_null_matrix(b)) {
12349 return E_DATA;
12350 }
12351
12352 if (libset_get_bool(USE_SVD)) {
12353 return gretl_matrix_SVD_ols(y, X, b, vcv, uhat, s2);
12354 }
12355
12356 k = X->cols;
12357 T = X->rows;
12358
12359 if (gretl_vector_get_length(b) != k ||
12360 gretl_vector_get_length(y) != T) {
12361 return E_NONCONF;
12362 }
12363
12364 if (T < k) {
12365 return E_DF;
12366 }
12367
12368 if (vcv != NULL && (vcv->rows != k || vcv->cols != k)) {
12369 return E_NONCONF;
12370 }
12371
12372 if (k >= 50 || (T >= 250 && k >= 30)) {
12373 /* this could maybe do with some more tuning? */
12374 use_lapack = 1;
12375 }
12376
12377 if (use_lapack) {
12378 XTX = gretl_matrix_XTX_new(X);
12379 } else {
12380 XTX = gretl_matrix_packed_XTX_new(X, &nasty);
12381 }
12382 if (XTX == NULL) {
12383 return E_ALLOC;
12384 }
12385
12386 if (use_lapack) {
12387 if (!err) {
12388 err = gretl_matrix_multiply_mod(X, GRETL_MOD_TRANSPOSE,
12389 y, GRETL_MOD_NONE,
12390 b, GRETL_MOD_NONE);
12391 }
12392 if (!err) {
12393 err = gretl_cholesky_decomp_solve(XTX, b);
12394 if (err) {
12395 try_QR = 1;
12396 }
12397 if (vcv != NULL) {
12398 gretl_matrix_copy_values(vcv, XTX);
12399 }
12400 }
12401 } else {
12402 if (!err && !nasty) {
12403 err = gretl_matrix_multiply_mod(X, GRETL_MOD_TRANSPOSE,
12404 y, GRETL_MOD_NONE,
12405 b, GRETL_MOD_NONE);
12406 }
12407 if (!err && vcv != NULL) {
12408 err = gretl_matrix_unvectorize_h(vcv, XTX);
12409 }
12410 if (!err) {
12411 if (!nasty) {
12412 err = native_cholesky_decomp_solve(XTX, b);
12413 }
12414 if (nasty || err == E_SINGULAR) {
12415 try_QR = 1;
12416 }
12417 }
12418 }
12419
12420 if (XTX != NULL) {
12421 gretl_matrix_free(XTX);
12422 }
12423
12424 if (try_QR) {
12425 fprintf(stderr, "gretl_matrix_ols: switching to QR decomp\n");
12426 err = gretl_matrix_QR_ols(y, X, b, NULL, NULL, NULL);
12427 }
12428
12429 if (!err) {
12430 if (s2 != NULL) {
12431 *s2 = get_ols_error_variance(y, X, b, 0);
12432 }
12433 if (vcv != NULL) {
12434 err = get_ols_vcv(vcv, s2);
12435 }
12436 if (uhat != NULL) {
12437 get_ols_uhat(y, X, b, uhat);
12438 }
12439 }
12440
12441 return err;
12442 }
12443
12444 /**
12445 * gretl_matrix_multi_ols:
12446 * @y: T x g matrix of dependent variables.
12447 * @X: T x k matrix of independent variables.
12448 * @B: k x g matrix to hold coefficient estimates, or NULL.
12449 * @E: T x g matrix to hold the regression residuals, or NULL if these are
12450 * not needed.
12451 * @XTXi: location to receive (X'X)^{-1} on output, or NULL if this is not
12452 * needed.
12453 *
12454 * Computes OLS estimates using Cholesky decomposition by default, but
12455 * with a fallback to QR decomposition if the data are highly
12456 * ill-conditioned, and puts the coefficient estimates in @B.
12457 * Optionally, calculates the residuals in @E.
12458 *
12459 * Returns: 0 on success, non-zero error code on failure.
12460 */
12461
gretl_matrix_multi_ols(const gretl_matrix * Y,const gretl_matrix * X,gretl_matrix * B,gretl_matrix * E,gretl_matrix ** XTXi)12462 int gretl_matrix_multi_ols (const gretl_matrix *Y,
12463 const gretl_matrix *X,
12464 gretl_matrix *B,
12465 gretl_matrix *E,
12466 gretl_matrix **XTXi)
12467 {
12468 gretl_matrix *XTX = NULL;
12469 int g, T, k;
12470 int free_B = 0;
12471 int nasty = 0;
12472 int err = 0;
12473
12474 if (libset_get_bool(USE_SVD)) {
12475 return gretl_matrix_multi_SVD_ols(Y, X, B, E, XTXi);
12476 }
12477
12478 if (gretl_is_null_matrix(Y) ||
12479 gretl_is_null_matrix(X)) {
12480 return E_DATA;
12481 }
12482
12483 g = Y->cols;
12484 T = X->rows;
12485 k = X->cols;
12486
12487 if (B == NULL) {
12488 /* create a throw-away B */
12489 B = gretl_matrix_alloc(k, g);
12490 if (B == NULL) {
12491 return E_ALLOC;
12492 }
12493 free_B = 1;
12494 }
12495
12496 if (B->rows != k || B->cols != g) {
12497 fprintf(stderr, "gretl_matrix_multi_ols: B is %d x %d, should be %d x %d\n",
12498 B->rows, B->cols, k, g);
12499 err = E_NONCONF;
12500 } else if (Y->rows != T) {
12501 fprintf(stderr, "gretl_matrix_multi_ols: Y has %d rows, should have %d\n",
12502 Y->rows, T);
12503 err = E_NONCONF;
12504 } else if (E != NULL && (E->rows != T || E->cols != g)) {
12505 fprintf(stderr, "gretl_matrix_multi_ols: E is %d x %d, should be %d x %d\n",
12506 E->rows, E->cols, T, g);
12507 err = E_NONCONF;
12508 } else if (k > T) {
12509 err = E_DF;
12510 }
12511
12512 if (!err) {
12513 XTX = gretl_matrix_XTX_new(X);
12514 if (XTX == NULL) {
12515 err = E_ALLOC;
12516 }
12517 }
12518
12519 if (!err) {
12520 err = gretl_matrix_multiply_mod(X, GRETL_MOD_TRANSPOSE,
12521 Y, GRETL_MOD_NONE,
12522 B, GRETL_MOD_NONE);
12523 }
12524
12525 if (!err) {
12526 err = nasty = gretl_cholesky_decomp_solve(XTX, B);
12527 if (err == E_SINGULAR) {
12528 fprintf(stderr, "gretl_matrix_multi_ols: switching to QR decomp\n");
12529 err = gretl_matrix_QR_ols(Y, X, B, E, XTXi, NULL);
12530 }
12531 }
12532
12533 if (!err && !nasty && E != NULL) {
12534 gretl_matrix_copy_values(E, Y);
12535 gretl_matrix_multiply_mod(X, GRETL_MOD_NONE,
12536 B, GRETL_MOD_NONE,
12537 E, GRETL_MOD_DECREMENT);
12538 }
12539
12540 if (!err && !nasty && XTXi != NULL) {
12541 integer info = 0, ik = k;
12542 char uplo = 'L';
12543
12544 dpotri_(&uplo, &ik, XTX->val, &ik, &info);
12545 gretl_matrix_mirror(XTX, uplo);
12546 *XTXi = XTX;
12547 } else {
12548 gretl_matrix_free(XTX);
12549 }
12550
12551 if (free_B) {
12552 gretl_matrix_free(B);
12553 }
12554
12555 return err;
12556 }
12557
12558 /* construct W = X'X augmented by R and R': we need this if we're
12559 calculating the covariance matrix for restricted least squares
12560 */
12561
build_augmented_XTX(const gretl_matrix * X,const gretl_matrix * R,int * err)12562 static gretl_matrix *build_augmented_XTX (const gretl_matrix *X,
12563 const gretl_matrix *R,
12564 int *err)
12565 {
12566 gretl_matrix *XTX, *W;
12567 int k = X->cols;
12568 int kW = k + R->rows;
12569
12570 XTX = gretl_matrix_XTX_new(X);
12571 W = gretl_zero_matrix_new(kW, kW);
12572
12573 if (XTX == NULL || W == NULL) {
12574 gretl_matrix_free(XTX);
12575 gretl_matrix_free(W);
12576 *err = E_ALLOC;
12577 return NULL;
12578 }
12579
12580 if (!*err) {
12581 double x;
12582 int i, j;
12583
12584 for (i=0; i<k; i++) {
12585 for (j=0; j<k; j++) {
12586 x = gretl_matrix_get(XTX, i, j);
12587 gretl_matrix_set(W, i, j, x);
12588 }
12589 }
12590 for (i=0; i<R->rows; i++) {
12591 for (j=0; j<R->cols; j++) {
12592 x = gretl_matrix_get(R, i, j);
12593 gretl_matrix_set(W, i+k, j, x);
12594 gretl_matrix_set(W, j, i+k, x);
12595 }
12596 }
12597 }
12598
12599 gretl_matrix_free(XTX);
12600
12601 return W;
12602 }
12603
12604 /* constrained least squares using lapack:
12605
12606 minimize || y - X*b ||_2 subject to R*b = q
12607 */
12608
gretl_matrix_gglse(const gretl_vector * y,const gretl_matrix * X,const gretl_matrix * R,const gretl_vector * q,gretl_vector * b)12609 static int gretl_matrix_gglse (const gretl_vector *y,
12610 const gretl_matrix *X,
12611 const gretl_matrix *R,
12612 const gretl_vector *q,
12613 gretl_vector *b)
12614 {
12615 gretl_matrix *A, *B, *c, *d;
12616 integer info;
12617 integer m = X->rows;
12618 integer n = X->cols;
12619 integer p = R->rows;
12620 integer lwork = -1;
12621 double *work;
12622 int err = 0;
12623
12624 /* note: all the input matrices get overwritten */
12625 A = gretl_matrix_copy(X);
12626 B = gretl_matrix_copy(R);
12627 c = gretl_matrix_copy(y);
12628
12629 if (q != NULL) {
12630 d = gretl_matrix_copy(q);
12631 } else {
12632 d = gretl_zero_matrix_new(p, 1);
12633 }
12634
12635 work = lapack_malloc(sizeof *work);
12636
12637 if (A == NULL || B == NULL || c == NULL ||
12638 d == NULL || work == NULL) {
12639 err = E_ALLOC;
12640 goto bailout;
12641 }
12642
12643 /* determine optimal workspace */
12644 dgglse_(&m, &n, &p, A->val, &m, B->val, &p, c->val,
12645 d->val, b->val, work, &lwork, &info);
12646
12647 if (info != 0) {
12648 err = wspace_fail(info, work[0]);
12649 } else {
12650 lwork = (integer) work[0];
12651 work = lapack_realloc(work, lwork * sizeof *work);
12652 if (work == NULL) {
12653 err = E_ALLOC;
12654 }
12655 }
12656
12657 if (!err) {
12658 /* do constrained calculation */
12659 dgglse_(&m, &n, &p, A->val, &m, B->val, &p, c->val,
12660 d->val, b->val, work, &lwork, &info);
12661 if (info != 0) {
12662 fprintf(stderr, "dgglse gave info = %d\n", (int) info);
12663 err = (info < 0)? E_DATA : E_SINGULAR;
12664 }
12665 }
12666
12667 lapack_free(work);
12668
12669 bailout:
12670
12671 gretl_matrix_free(A);
12672 gretl_matrix_free(B);
12673 gretl_matrix_free(c);
12674 gretl_matrix_free(d);
12675
12676 return err;
12677 }
12678
12679 /* get_exact_list: constructs a list of the parameter positions
12680 (columns of the @R matrix) corresponding to unitary restrictions --
12681 that is, restrictions that stipulate a definite numerical value for
12682 a given parameter. We want this so that we can set the variance of
12683 such parameters (and also their covariances with other parameter
12684 estimates) to exactly zero.
12685 */
12686
get_exact_list(const gretl_matrix * R)12687 static int *get_exact_list (const gretl_matrix *R)
12688 {
12689 int *list = NULL;
12690 int n, n_exact = 0;
12691 int i, j;
12692
12693 for (i=0; i<R->rows; i++) {
12694 n = 0;
12695 for (j=0; j<R->cols && n<2; j++) {
12696 if (gretl_matrix_get(R, i, j) != 0.0) {
12697 n++;
12698 }
12699 }
12700 if (n == 1) {
12701 n_exact++;
12702 }
12703 }
12704
12705 if (n_exact > 0) {
12706 list = gretl_list_new(n_exact);
12707 }
12708
12709 if (list != NULL) {
12710 int col = 0, k = 1;
12711
12712 for (i=0; i<R->rows && k<=n_exact; i++) {
12713 n = 0;
12714 for (j=0; j<R->cols && n<2; j++) {
12715 if (gretl_matrix_get(R, i, j) != 0.0) {
12716 col = j;
12717 n++;
12718 }
12719 }
12720 if (n == 1) {
12721 list[k++] = col;
12722 }
12723 }
12724 }
12725
12726 return list;
12727 }
12728
12729 /**
12730 * gretl_matrix_restricted_ols:
12731 * @y: dependent variable vector.
12732 * @X: matrix of independent variables.
12733 * @R: left-hand restriction matrix, as in Rb = q.
12734 * @q: right-hand restriction vector or NULL.
12735 * @b: vector to hold coefficient estimates.
12736 * @vcv: matrix to hold the covariance matrix of the coefficients,
12737 * or NULL if this is not needed.
12738 * @uhat: vector to hold residuals, if wanted.
12739 * @s2: pointer to receive residual variance, or NULL. If vcv is non-NULL
12740 * and s2 is NULL, the vcv estimate is just W^{-1}.
12741 *
12742 * Computes OLS estimates restricted by R and q, using the lapack
12743 * function dgglse(), and puts the coefficient estimates in @b.
12744 * Optionally, calculates the covariance matrix in @vcv. If @q is
12745 * NULL this is taken as equivalent to a zero vector.
12746 *
12747 * Returns: 0 on success, non-zero error code on failure.
12748 */
12749
12750 int
gretl_matrix_restricted_ols(const gretl_vector * y,const gretl_matrix * X,const gretl_matrix * R,const gretl_vector * q,gretl_vector * b,gretl_matrix * vcv,gretl_vector * uhat,double * s2)12751 gretl_matrix_restricted_ols (const gretl_vector *y, const gretl_matrix *X,
12752 const gretl_matrix *R, const gretl_vector *q,
12753 gretl_vector *b, gretl_matrix *vcv,
12754 gretl_vector *uhat, double *s2)
12755 {
12756 gretl_matrix *W = NULL;
12757 double x;
12758 int k = X->cols;
12759 int nr = R->rows;
12760 int i, j, err = 0;
12761
12762 if (gretl_vector_get_length(b) != k) {
12763 fprintf(stderr, "gretl_matrix_restricted_ols: "
12764 "b should be a %d-vector\n", k);
12765 err = E_NONCONF;
12766 }
12767
12768 if (!err && vcv != NULL) {
12769 W = build_augmented_XTX(X, R, &err);
12770 }
12771
12772 if (!err) {
12773 err = gretl_matrix_gglse(y, X, R, q, b);
12774 }
12775
12776 if (!err) {
12777 if (s2 != NULL) {
12778 *s2 = get_ols_error_variance(y, X, b, nr);
12779 }
12780
12781 if (W != NULL) {
12782 int *exlist = NULL;
12783
12784 err = get_ols_vcv(W, s2);
12785
12786 if (!err) {
12787 for (i=0; i<k; i++) {
12788 for (j=0; j<k; j++) {
12789 x = gretl_matrix_get(W, i, j);
12790 gretl_matrix_set(vcv, i, j, x);
12791 }
12792 }
12793 exlist = get_exact_list(R);
12794 }
12795
12796 if (exlist != NULL) {
12797 int p;
12798
12799 for (p=0; p<k; p++) {
12800 if (in_gretl_list(exlist, p)) {
12801 for (i=0; i<k; i++) {
12802 gretl_matrix_set(vcv, i, p, 0.0);
12803 }
12804 for (j=0; j<k; j++) {
12805 gretl_matrix_set(vcv, p, j, 0.0);
12806 }
12807 }
12808 }
12809 free(exlist);
12810 }
12811 }
12812
12813 if (uhat != NULL) {
12814 get_ols_uhat(y, X, b, uhat);
12815 }
12816 }
12817
12818 if (W != NULL) {
12819 gretl_matrix_free(W);
12820 }
12821
12822 return err;
12823 }
12824
12825 /**
12826 * gretl_matrix_restricted_multi_ols:
12827 * @Y: dependent variable matrix, T x g.
12828 * @X: matrix of independent variables, T x k.
12829 * @R: left-hand restriction matrix, as in RB = q.
12830 * @q: right-hand restriction matrix.
12831 * @B: matrix to hold coefficient estimates, k x g.
12832 * @U: matrix to hold residuals (T x g), if wanted.
12833 * @pW: pointer to matrix to hold the RLS counterpart to (X'X)^{-1},
12834 * if wanted.
12835 *
12836 * Computes LS estimates restricted by @R and @q, putting the
12837 * coefficient estimates into @B. The @R matrix must have
12838 * g*k columns; each row represents a linear restriction;
12839 * @q must be a column vector of length equal to the
12840 * number of rows of @R.
12841 *
12842 * Returns: 0 on success, non-zero error code on failure.
12843 */
12844
12845 int
gretl_matrix_restricted_multi_ols(const gretl_matrix * Y,const gretl_matrix * X,const gretl_matrix * R,const gretl_matrix * q,gretl_matrix * B,gretl_matrix * U,gretl_matrix ** pW)12846 gretl_matrix_restricted_multi_ols (const gretl_matrix *Y,
12847 const gretl_matrix *X,
12848 const gretl_matrix *R,
12849 const gretl_matrix *q,
12850 gretl_matrix *B,
12851 gretl_matrix *U,
12852 gretl_matrix **pW)
12853 {
12854 gretl_matrix_block *M;
12855 gretl_matrix *XTX, *RXR, *XYq;
12856 gretl_matrix *Yi, *XYi;
12857 gretl_matrix *V = NULL;
12858 int T = Y->rows; /* sample length */
12859 int k = X->cols; /* number of regressors */
12860 int g = Y->cols; /* number of dependent vars */
12861 int nc = g * k; /* total coefficients */
12862 int nr = R->rows; /* number of restrictions */
12863 int p = nc + nr; /* coeffs plus restrictions */
12864 int dsize, offset;
12865 int i, r, err = 0;
12866
12867 if (X->rows != T) {
12868 return E_NONCONF;
12869 } else if (B->rows != k || B->cols != g) {
12870 return E_NONCONF;
12871 } else if (R->cols != nc || q->rows != nr || q->cols != 1) {
12872 return E_NONCONF;
12873 } else if (U != NULL && (U->rows != T || U->cols != g)) {
12874 return E_NONCONF;
12875 }
12876
12877 M = gretl_matrix_block_new(&XTX, k, k,
12878 &RXR, p, p,
12879 &XYq, p, 1,
12880 &Yi, T, 1,
12881 &XYi, k, 1,
12882 NULL);
12883 if (M == NULL) {
12884 return E_ALLOC;
12885 }
12886
12887 gretl_matrix_multiply_mod(X, GRETL_MOD_TRANSPOSE,
12888 X, GRETL_MOD_NONE,
12889 XTX, GRETL_MOD_NONE);
12890
12891 gretl_matrix_zero(RXR);
12892
12893 dsize = T * sizeof(double);
12894 offset = r = 0;
12895
12896 /* Form the "big" X'X and X'y matrices, bordered by the
12897 restriction:
12898
12899 "RXR" = [(I_g ** X'X) ~ R'] | (R ~ 0)
12900 "XYq" = vec(X'Y) | q
12901 */
12902
12903 for (i=0; i<g; i++) {
12904 gretl_matrix_inscribe_matrix(RXR, XTX, r, r,
12905 GRETL_MOD_NONE);
12906 memcpy(Yi->val, Y->val + offset, dsize);
12907 gretl_matrix_multiply_mod(X, GRETL_MOD_TRANSPOSE,
12908 Yi, GRETL_MOD_NONE,
12909 XYi, GRETL_MOD_NONE);
12910 gretl_matrix_inscribe_matrix(XYq, XYi, r, 0,
12911 GRETL_MOD_NONE);
12912 r += k;
12913 offset += T;
12914 }
12915
12916 gretl_matrix_inscribe_matrix(RXR, R, r, 0, GRETL_MOD_NONE);
12917 gretl_matrix_inscribe_matrix(RXR, R, 0, nc, GRETL_MOD_TRANSPOSE);
12918 gretl_matrix_inscribe_matrix(XYq, q, nc, 0, GRETL_MOD_NONE);
12919
12920 if (pW != NULL) {
12921 /* keep a copy of @V for inversion */
12922 V = gretl_matrix_copy(RXR);
12923 if (V == NULL) {
12924 err = E_ALLOC;
12925 }
12926 }
12927
12928 if (!err) {
12929 /* solve for stacked coeff vector in XYq */
12930 err = gretl_LU_solve(RXR, XYq);
12931 if (!err) {
12932 /* transcribe to B */
12933 dsize = nc * sizeof(double);
12934 memcpy(B->val, XYq->val, dsize);
12935 }
12936 }
12937
12938 if (!err && U != NULL) {
12939 /* compute residuals */
12940 gretl_matrix_copy_values(U, Y);
12941 gretl_matrix_multiply_mod(X, GRETL_MOD_NONE,
12942 B, GRETL_MOD_NONE,
12943 U, GRETL_MOD_DECREMENT);
12944 }
12945
12946 if (!err && pW != NULL) {
12947 /* compute variance-related matrix */
12948 err = gretl_invert_general_matrix(V);
12949 if (!err) {
12950 *pW = gretl_matrix_alloc(nc, nc);
12951 if (*pW == NULL) {
12952 err = E_ALLOC;
12953 } else {
12954 double wij;
12955 int j;
12956
12957 for (j=0; j<nc; j++) {
12958 for (i=0; i<nc; i++) {
12959 wij = gretl_matrix_get(V, i, j);
12960 gretl_matrix_set(*pW, i, j, wij);
12961 }
12962 }
12963 }
12964 }
12965 }
12966
12967 gretl_matrix_block_destroy(M);
12968 gretl_matrix_free(V);
12969
12970 return err;
12971 }
12972
QR_OLS_work(gretl_matrix * Q,gretl_matrix * R)12973 static int QR_OLS_work (gretl_matrix *Q, gretl_matrix *R)
12974 {
12975 integer k = gretl_matrix_rows(R);
12976 int r, err;
12977
12978 /* basic decomposition */
12979 err = gretl_matrix_QR_decomp(Q, R);
12980 if (err) {
12981 return err;
12982 }
12983
12984 /* check rank of QR */
12985 r = gretl_check_QR_rank(R, &err, NULL);
12986 if (err) {
12987 return err;
12988 }
12989
12990 if (r < k) {
12991 err = E_SINGULAR;
12992 } else {
12993 /* invert R */
12994 char uplo = 'U';
12995 char diag = 'N';
12996 integer info = 0;
12997
12998 dtrtri_(&uplo, &diag, &k, R->val, &k, &info);
12999 if (info != 0) {
13000 fprintf(stderr, "dtrtri: info = %d\n", (int) info);
13001 err = 1;
13002 }
13003 }
13004
13005 return err;
13006 }
13007
13008 /**
13009 * gretl_matrix_QR_ols:
13010 * @y: T x g matrix of dependent variables.
13011 * @X: T x k matrix of independent variables.
13012 * @B: k x g matrix to hold coefficient estimates.
13013 * @E: T x g matrix to hold the regression residuals, or NULL if these are
13014 * not needed.
13015 * @XTXi: location to receive (X'X)^{-1}, or NULL if this is not needed.
13016 * @Qout: location to receive Q on output, or NULL.
13017 *
13018 * Computes OLS estimates using QR decomposition, and puts the
13019 * coefficient estimates in @B. Optionally, calculates the
13020 * residuals in @E, (X'X)^{-1} in @XTXi, and/or the matrix Q
13021 * in @Qout.
13022 *
13023 * Returns: 0 on success, non-zero error code on failure.
13024 */
13025
gretl_matrix_QR_ols(const gretl_matrix * Y,const gretl_matrix * X,gretl_matrix * B,gretl_matrix * E,gretl_matrix ** XTXi,gretl_matrix ** Qout)13026 int gretl_matrix_QR_ols (const gretl_matrix *Y,
13027 const gretl_matrix *X,
13028 gretl_matrix *B,
13029 gretl_matrix *E,
13030 gretl_matrix **XTXi,
13031 gretl_matrix **Qout)
13032 {
13033 int g = Y->cols;
13034 int k = X->cols;
13035 int T = X->rows;
13036 gretl_matrix *Q = NULL;
13037 gretl_matrix *R = NULL;
13038 gretl_matrix *G = NULL;
13039 int err = 0;
13040
13041 if (B->rows != k || B->cols != g) {
13042 err = E_NONCONF;
13043 } else if (Y->rows != T) {
13044 err = E_NONCONF;
13045 } else if (E != NULL && (E->cols != g || E->rows != T)) {
13046 err = E_NONCONF;
13047 } else if (k > T) {
13048 err = E_DF;
13049 }
13050
13051 if (!err) {
13052 Q = gretl_matrix_copy(X);
13053 R = gretl_matrix_alloc(k, k);
13054 G = gretl_matrix_alloc(k, g);
13055 if (Q == NULL || R == NULL || G == NULL) {
13056 err = E_ALLOC;
13057 }
13058 }
13059
13060 if (!err) {
13061 err = QR_OLS_work(Q, R);
13062 }
13063
13064 if (!err) {
13065 /* make "G" into gamma-hat */
13066 gretl_matrix_multiply_mod(Q, GRETL_MOD_TRANSPOSE,
13067 Y, GRETL_MOD_NONE,
13068 G, GRETL_MOD_NONE);
13069 }
13070
13071 if (!err) {
13072 /* OLS coefficients */
13073 gretl_matrix_multiply(R, G, B);
13074 }
13075
13076 if (!err && E != NULL) {
13077 /* compute residuals */
13078 int i, imax = E->rows * E->cols;
13079
13080 gretl_matrix_multiply(X, B, E);
13081 for (i=0; i<imax; i++) {
13082 E->val[i] = Y->val[i] - E->val[i];
13083 }
13084 }
13085
13086 /* create (X'X)^{-1} = RR' */
13087 if (!err && XTXi != NULL) {
13088 *XTXi = gretl_matrix_alloc(k, k);
13089 if (*XTXi == NULL) {
13090 err = E_ALLOC;
13091 } else {
13092 gretl_matrix_multiply_mod(R, GRETL_MOD_NONE,
13093 R, GRETL_MOD_TRANSPOSE,
13094 *XTXi, GRETL_MOD_NONE);
13095 }
13096 }
13097
13098 if (!err && Qout != NULL) {
13099 *Qout = Q;
13100 } else {
13101 gretl_matrix_free(Q);
13102 }
13103
13104 gretl_matrix_free(R);
13105 gretl_matrix_free(G);
13106
13107 return err;
13108 }
13109
13110 /**
13111 * gretl_matrix_r_squared:
13112 * @y: dependent variable, T-vector.
13113 * @X: independent variables matrix, T x k.
13114 * @b: coefficients, k-vector.
13115 * @err: location to receive error code.
13116 *
13117 * Returns: the unadjusted R-squared, based on the regression
13118 * represented by @y, @X and @b, or #NADBL on failure.
13119 */
13120
gretl_matrix_r_squared(const gretl_matrix * y,const gretl_matrix * X,const gretl_matrix * b,int * err)13121 double gretl_matrix_r_squared (const gretl_matrix *y,
13122 const gretl_matrix *X,
13123 const gretl_matrix *b,
13124 int *err)
13125 {
13126 double ess = 0.0, tss = 0.0;
13127 double xx, ybar;
13128 int i, j;
13129
13130 if (gretl_vector_get_length(y) != X->rows ||
13131 gretl_vector_get_length(b) != X->cols) {
13132 *err = E_NONCONF;
13133 return NADBL;
13134 }
13135
13136 ybar = gretl_vector_mean(y);
13137
13138 for (i=0; i<X->rows; i++) {
13139 xx = y->val[i];
13140 for (j=0; j<X->cols; j++) {
13141 xx -= b->val[j] * gretl_matrix_get(X, i, j);
13142 }
13143 ess += xx * xx;
13144 xx = y->val[i] - ybar;
13145 tss += xx * xx;
13146 }
13147
13148 return 1.0 - ess / tss;
13149 }
13150
13151 /**
13152 * gretl_matrix_columwise_product:
13153 * @A: T x k matrix.
13154 * @B: T x n matrix.
13155 * @S: k x n selection matrix, or NULL.
13156 * @C: T x (k*n) matrix to hold the product (but see below).
13157 *
13158 * If @S is NULL, computes a columnwise product in k blocks, each
13159 * of n columns. The first block consists of the Hadamard product
13160 * of the first column of @A and the matrix @B, the second block
13161 * holds the Hadamard product of the second column of @A and
13162 * matrix @B, and so on.
13163 *
13164 * A non-NULL @S matrix may be used to filter the column-pairs for
13165 * multiplication: @C will include the product of column i of @A
13166 * and column j of @B if and only if the i, j element of @S is
13167 * non-zero. In this case @C should have a number of columns
13168 * equal to the number of non-zero elements of @S.
13169 *
13170 * Returns: 0 on success; non-zero error code on failure.
13171 */
13172
gretl_matrix_columnwise_product(const gretl_matrix * A,const gretl_matrix * B,const gretl_matrix * S,gretl_matrix * C)13173 int gretl_matrix_columnwise_product (const gretl_matrix *A,
13174 const gretl_matrix *B,
13175 const gretl_matrix *S,
13176 gretl_matrix *C)
13177 {
13178 int k, n, T;
13179 double x, y;
13180 int i, j, t, p;
13181
13182 if (gretl_is_null_matrix(A) ||
13183 gretl_is_null_matrix(B) ||
13184 gretl_is_null_matrix(C)) {
13185 return E_DATA;
13186 }
13187
13188 k = A->cols;
13189 n = B->cols;
13190 T = A->rows;
13191
13192 if (B->rows != T || C->rows != T) {
13193 return E_NONCONF;
13194 }
13195
13196 if (S != NULL) {
13197 if (S->rows != k || S->cols != n) {
13198 return E_NONCONF;
13199 } else {
13200 int c = 0;
13201
13202 for (i=0; i<k*n; i++) {
13203 if (S->val[i] != 0) {
13204 c++;
13205 }
13206 }
13207 if (C->cols != c) {
13208 return E_NONCONF;
13209 }
13210 }
13211 } else if (C->cols != k * n) {
13212 return E_NONCONF;
13213 }
13214
13215 p = 0;
13216 for (i=0; i<k; i++) {
13217 for (j=0; j<n; j++) {
13218 if (S == NULL || gretl_matrix_get(S, i, j) != 0) {
13219 for (t=0; t<T; t++) {
13220 x = gretl_matrix_get(A, t, i);
13221 y = gretl_matrix_get(B, t, j);
13222 gretl_matrix_set(C, t, p, x * y);
13223 }
13224 p++;
13225 }
13226 }
13227 }
13228
13229 return 0;
13230 }
13231
alt_qform(const gretl_matrix * A,GretlMatrixMod amod,const gretl_matrix * X,gretl_matrix * C,GretlMatrixMod cmod,int r)13232 static int alt_qform (const gretl_matrix *A, GretlMatrixMod amod,
13233 const gretl_matrix *X, gretl_matrix *C,
13234 GretlMatrixMod cmod, int r)
13235 {
13236 gretl_matrix *Tmp;
13237
13238 Tmp = gretl_matrix_alloc(r, X->cols);
13239 if (Tmp == NULL) {
13240 return E_ALLOC;
13241 }
13242
13243 if (amod == GRETL_MOD_TRANSPOSE) {
13244 /* A' * X * A */
13245 gretl_matrix_multiply_mod(A, GRETL_MOD_TRANSPOSE,
13246 X, GRETL_MOD_NONE,
13247 Tmp, GRETL_MOD_NONE);
13248 gretl_matrix_multiply_mod(Tmp, GRETL_MOD_NONE,
13249 A, GRETL_MOD_NONE,
13250 C, cmod);
13251 } else {
13252 /* A * X * A' */
13253 gretl_matrix_multiply(A, X, Tmp);
13254 gretl_matrix_multiply_mod(Tmp, GRETL_MOD_NONE,
13255 A, GRETL_MOD_TRANSPOSE,
13256 C, cmod);
13257 }
13258
13259 gretl_matrix_xtr_symmetric(C);
13260 gretl_matrix_free(Tmp);
13261
13262 return 0;
13263 }
13264
13265 /**
13266 * gretl_matrix_qform:
13267 * @A: m * k matrix or k * m matrix, depending on @amod.
13268 * @amod: %GRETL_MOD_NONE or %GRETL_MOD_TRANSPOSE: in the first
13269 * case @A should be m * k; in the second, k * m;
13270 * @X: symmetric k * k matrix.
13271 * @C: matrix to hold the product.
13272 * @cmod: modifier: %GRETL_MOD_NONE or %GRETL_MOD_CUMULATE to
13273 * add the result to the existing value of @C.
13274 *
13275 * Computes either A * X * A' (if amod = %GRETL_MOD_NONE) or
13276 * A' * X * A (if amod = %GRETL_MOD_TRANSPOSE), with the result
13277 * written into @C. The matrix @X must be symmetric, but this
13278 * is not checked, to save time. If you are in doubt on this
13279 * point you can call gretl_matrix_is_symmetric() first.
13280 *
13281 * Returns: 0 on success; non-zero error code on failure.
13282 */
13283
13284 #define QFORM_SMALL 1.0e-20
13285
gretl_matrix_qform(const gretl_matrix * A,GretlMatrixMod amod,const gretl_matrix * X,gretl_matrix * C,GretlMatrixMod cmod)13286 int gretl_matrix_qform (const gretl_matrix *A, GretlMatrixMod amod,
13287 const gretl_matrix *X, gretl_matrix *C,
13288 GretlMatrixMod cmod)
13289 {
13290 register int i, j, ii, jj;
13291 double xi, xj, xij, xx;
13292 int m, k;
13293 guint64 N;
13294
13295 if (gretl_is_null_matrix(A) ||
13296 gretl_is_null_matrix(X) ||
13297 gretl_is_null_matrix(C)) {
13298 return E_DATA;
13299 } else if (A->is_complex || X->is_complex) {
13300 fprintf(stderr, "E_CMPLX in gretl_matrix_qform\n");
13301 if (A->is_complex) fprintf(stderr, "\touter is complex\n");
13302 if (X->is_complex) fprintf(stderr, "\tinner is complex\n");
13303 return E_CMPLX;
13304 }
13305
13306 m = (amod)? A->cols : A->rows;
13307 k = (amod)? A->rows : A->cols;
13308
13309 if (k != X->rows) {
13310 fprintf(stderr, "gretl_matrix_qform: %s is (%d x %d) but X is (%d x %d)\n",
13311 (amod)? "A'" : "A", m, k, X->rows, X->cols);
13312 return E_NONCONF;
13313 }
13314
13315 if (C->rows != m || C->cols != m) {
13316 fputs("gretl_matrix_qform: destination matrix not conformable\n", stderr);
13317 return E_NONCONF;
13318 }
13319
13320 N = m * m * k * k;
13321
13322 if (N > 100000) {
13323 /* take advantage of optimized matrix multiplication */
13324 return alt_qform(A, amod, X, C, cmod, m);
13325 }
13326
13327 if (amod) {
13328 for (i=0; i<m; i++) {
13329 for (j=i; j<m; j++) {
13330 xx = 0.0;
13331 for (ii=0; ii<k; ii++) {
13332 xi = gretl_matrix_get(A,ii,i);
13333 if (fabs(xi) > QFORM_SMALL) {
13334 for (jj=0; jj<k; jj++) {
13335 xj = gretl_matrix_get(A,jj,j);
13336 xij = gretl_matrix_get(X,ii,jj);
13337 xx += xij * xi * xj;
13338 }
13339 }
13340 }
13341 if (cmod == GRETL_MOD_CUMULATE) {
13342 xx += gretl_matrix_get(C, i, j);
13343 } else if (cmod == GRETL_MOD_DECREMENT) {
13344 xx = gretl_matrix_get(C, i, j) - xx;
13345 }
13346 gretl_matrix_set(C, i, j, xx);
13347 gretl_matrix_set(C, j, i, xx);
13348 }
13349 }
13350 } else {
13351 for (i=0; i<m; i++) {
13352 for (j=i; j<m; j++) {
13353 xx = 0.0;
13354 for (ii=0; ii<k; ii++) {
13355 xi = gretl_matrix_get(A,i,ii);
13356 if (fabs(xi) > QFORM_SMALL) {
13357 for (jj=0; jj<k; jj++) {
13358 xj = gretl_matrix_get(A,j,jj);
13359 xij = gretl_matrix_get(X,ii,jj);
13360 xx += xij * xi * xj;
13361 }
13362 }
13363 }
13364 if (cmod == GRETL_MOD_CUMULATE) {
13365 xx += gretl_matrix_get(C, i, j);
13366 } else if (cmod == GRETL_MOD_DECREMENT) {
13367 xx = gretl_matrix_get(C, i, j) - xx;
13368 }
13369 gretl_matrix_set(C, i, j, xx);
13370 gretl_matrix_set(C, j, i, xx);
13371 }
13372 }
13373 }
13374
13375 return 0;
13376 }
13377
13378 /**
13379 * gretl_scalar_qform:
13380 * @b: k-vector.
13381 * @X: symmetric k x k matrix.
13382 * @err: pointer to receive error code.
13383 *
13384 * Computes the scalar product bXb', or b'Xb if @b is a column
13385 * vector. The content of @err is set to a non-zero code on
13386 * failure.
13387 *
13388 * Returns: the scalar product, or #NADBL on failure.
13389 */
13390
gretl_scalar_qform(const gretl_vector * b,const gretl_matrix * X,int * err)13391 double gretl_scalar_qform (const gretl_vector *b,
13392 const gretl_matrix *X,
13393 int *err)
13394 {
13395 double tmp, ret = 0.0;
13396 int i, j, k, p;
13397
13398 if (gretl_is_null_matrix(b) || gretl_is_null_matrix(X)) {
13399 *err = E_DATA;
13400 return NADBL;
13401 }
13402
13403 k = gretl_vector_get_length(b);
13404
13405 if (k == 0 || X->rows != k || X->cols != k) {
13406 *err = E_NONCONF;
13407 return NADBL;
13408 }
13409
13410 p = 0;
13411 for (j=0; j<k; j++) {
13412 tmp = 0.0;
13413 for (i=0; i<k; i++) {
13414 tmp += b->val[i] * X->val[p++];
13415 }
13416 ret += tmp * b->val[j];
13417 }
13418
13419 return ret;
13420 }
13421
13422 /**
13423 * gretl_matrix_diagonal_sandwich:
13424 * @d: k-vector.
13425 * @X: k * k matrix.
13426 * @DXD: target k * k matrix.
13427 *
13428 * Computes in @DXD (which must be pre-allocated), the matrix
13429 * product D * X * D, where D is a diagonal matrix with elements
13430 * given by the vector @d.
13431 *
13432 * Returns: 0 on success, non-zero code on error.
13433 */
13434
13435 int
gretl_matrix_diagonal_sandwich(const gretl_vector * d,const gretl_matrix * X,gretl_matrix * DXD)13436 gretl_matrix_diagonal_sandwich (const gretl_vector *d, const gretl_matrix *X,
13437 gretl_matrix *DXD)
13438 {
13439 int dim = (d->rows == 1)? d->cols : d->rows;
13440 double x, xij;
13441 int i, j, err = 0;
13442
13443 if (dim != X->rows || dim != X->cols ||
13444 dim != DXD->rows || dim != DXD->cols) {
13445 err = E_NONCONF;
13446 } else {
13447 for (i=0; i<dim; i++) {
13448 for (j=0; j<dim; j++) {
13449 xij = gretl_matrix_get(X, i, j);
13450 x = xij * d->val[i] * d->val[j];
13451 gretl_matrix_set(DXD, i, j, x);
13452 }
13453 }
13454 }
13455
13456 return err;
13457 }
13458
13459 /**
13460 * gretl_is_identity_matrix:
13461 * @m: matrix to examine.
13462 *
13463 * Returns: 1 if @m is an identity matrix, 0 otherwise.
13464 */
13465
gretl_is_identity_matrix(const gretl_matrix * m)13466 int gretl_is_identity_matrix (const gretl_matrix *m)
13467 {
13468 double x;
13469 int i, j;
13470
13471 if (gretl_is_null_matrix(m)) {
13472 return 0;
13473 } else if (m->rows != m->cols) {
13474 return 0;
13475 }
13476
13477 for (j=0; j<m->cols; j++) {
13478 for (i=0; i<m->rows; i++) {
13479 x = gretl_matrix_get(m, i, j);
13480 if (i == j && x != 1.0) return 0;
13481 if (i != j && x != 0.0) return 0;
13482 }
13483 }
13484
13485 return 1;
13486 }
13487
13488 /**
13489 * gretl_is_zero_matrix:
13490 * @m: matrix to examine.
13491 *
13492 * Returns: 1 if @m is a zero matrix, 0 otherwise.
13493 */
13494
gretl_is_zero_matrix(const gretl_matrix * m)13495 int gretl_is_zero_matrix (const gretl_matrix *m)
13496 {
13497 int i, n;
13498
13499 if (gretl_is_null_matrix(m)) {
13500 return 0;
13501 }
13502
13503 n = m->rows * m->cols;
13504
13505 for (i=0; i<n; i++) {
13506 if (m->val[i] != 0.0) {
13507 return 0;
13508 }
13509 }
13510
13511 return 1;
13512 }
13513
13514 /**
13515 * gretl_matrix_isfinite:
13516 * @m: matrix to examine.
13517 * @err: location to receive error code.
13518 *
13519 * Returns: a matrix with 1s in positions corresponding to
13520 * finite elements of @m, zeros otherwise.
13521 */
13522
gretl_matrix_isfinite(const gretl_matrix * m,int * err)13523 gretl_matrix *gretl_matrix_isfinite (const gretl_matrix *m, int *err)
13524 {
13525 gretl_matrix *f;
13526
13527 if (m == NULL) {
13528 *err = E_DATA;
13529 return NULL;
13530 }
13531
13532 f = gretl_matrix_alloc(m->rows, m->cols);
13533
13534 if (f == NULL) {
13535 *err = E_ALLOC;
13536 } else {
13537 int i, n = m->rows * m->cols;
13538
13539 for (i=0; i<n; i++) {
13540 f->val[i] = (na(m->val[i]))? 0 : 1;
13541 }
13542 }
13543
13544 return f;
13545 }
13546
13547 /**
13548 * gretl_matrices_are_equal:
13549 * @a: first matrix in comparison.
13550 * @b: second matrix in comparison.
13551 * @tol: numerical tolerance.
13552 * @err: location to receive error code.
13553 *
13554 * Returns: 1 if the matrices @a and @b compare equal, 0 if they
13555 * differ, and -1 if the comparison is invalid, in which case
13556 * %E_NONCONF is written to @err.
13557 */
13558
gretl_matrices_are_equal(const gretl_matrix * a,const gretl_matrix * b,double tol,int * err)13559 int gretl_matrices_are_equal (const gretl_matrix *a,
13560 const gretl_matrix *b,
13561 double tol, int *err)
13562 {
13563 double ax, bx;
13564 int i, j;
13565
13566 if (a == NULL || b == NULL) {
13567 *err = E_DATA;
13568 return -1;
13569 }
13570
13571 if (a->rows != b->rows || a->cols != b->cols) {
13572 *err = E_NONCONF;
13573 return -1;
13574 }
13575
13576 for (i=0; i<a->rows; i++) {
13577 for (j=0; j<a->cols; j++) {
13578 ax = gretl_matrix_get(a, i, j);
13579 bx = gretl_matrix_get(b, i, j);
13580 if (fabs(ax - bx) > tol) {
13581 fprintf(stderr, "gretl_matrices_are_equal:\n "
13582 "a(%d,%d) = %.15g but b(%d,%d) = %.15g\n",
13583 i, j, ax, i, j, bx);
13584 return 0;
13585 }
13586 }
13587 }
13588
13589 return 1;
13590 }
13591
13592 /**
13593 * gretl_covariance_matrix:
13594 * @m: (x x n) matrix containing n observations on each of k
13595 * variables.
13596 * @corr: flag for computing correlations.
13597 * @dfc: degrees of freedom correction: use 1 for sample
13598 * variance, 0 for MLE.
13599 * @err: pointer to receive non-zero error code in case of
13600 * failure, or NULL.
13601 *
13602 * Returns: the covariance matrix of variables in the columns of
13603 * @m, or the correlation matrix if @corr is non-zero.
13604 */
13605
gretl_covariance_matrix(const gretl_matrix * m,int corr,int dfc,int * err)13606 gretl_matrix *gretl_covariance_matrix (const gretl_matrix *m,
13607 int corr, int dfc,
13608 int *err)
13609 {
13610 gretl_matrix *D = NULL;
13611 gretl_matrix *V = NULL;
13612
13613 if (gretl_is_null_matrix(m) || dfc < 0 || dfc >= m->rows) {
13614 *err = E_INVARG;
13615 return NULL;
13616 }
13617
13618 if (m->rows < 2) {
13619 *err = E_TOOFEW;
13620 return NULL;
13621 }
13622
13623 D = gretl_matrix_copy(m);
13624 if (D == NULL) {
13625 *err = E_ALLOC;
13626 return NULL;
13627 }
13628
13629 if (corr) {
13630 gretl_matrix_standardize(D, dfc);
13631 } else {
13632 gretl_matrix_center(D);
13633 }
13634
13635 V = gretl_matrix_XTX_new(D);
13636 if (V == NULL) {
13637 *err = E_ALLOC;
13638 } else {
13639 gretl_matrix_divide_by_scalar(V, m->rows - dfc);
13640 }
13641
13642 gretl_matrix_free(D);
13643
13644 return V;
13645 }
13646
13647 /**
13648 * gretl_matrix_array_new:
13649 * @n: number of matrices.
13650 *
13651 * Allocates an array of @n gretl matrix pointers. On successful
13652 * allocation of the array, each element is initialized to NULL.
13653 *
13654 * Returns: pointer on sucess, NULL on failure.
13655 */
13656
gretl_matrix_array_new(int n)13657 gretl_matrix **gretl_matrix_array_new (int n)
13658 {
13659 gretl_matrix **A = malloc(n * sizeof *A);
13660 int i;
13661
13662 if (A != NULL) {
13663 for (i=0; i<n; i++) {
13664 A[i] = NULL;
13665 }
13666 }
13667
13668 return A;
13669 }
13670
13671 /**
13672 * gretl_matrix_array_new_with_size:
13673 * @n: number of matrices.
13674 * @rows: number of rows in each matrix.
13675 * @cols: number of columns in each matrix.
13676 *
13677 * Allocates an array of @n gretl matrix pointers, each one
13678 * with size @rows * @cols.
13679 *
13680 * Returns: pointer on sucess, NULL on failure.
13681 */
13682
13683 gretl_matrix **
gretl_matrix_array_new_with_size(int n,int rows,int cols)13684 gretl_matrix_array_new_with_size (int n, int rows, int cols)
13685 {
13686 gretl_matrix **A = malloc(n * sizeof *A);
13687 int i, j;
13688
13689 if (A != NULL) {
13690 for (i=0; i<n; i++) {
13691 A[i] = gretl_matrix_alloc(rows, cols);
13692 if (A[i] == NULL) {
13693 for (j=0; j<i; j++) {
13694 gretl_matrix_free(A[i]);
13695 }
13696 free(A);
13697 A = NULL;
13698 break;
13699 }
13700 }
13701 }
13702
13703 return A;
13704 }
13705
13706 /**
13707 * gretl_matrix_array_free:
13708 * @A: dyamically allocated array of gretl matrices.
13709 * @n: number of matrices in array.
13710 *
13711 * Frees each of the @n gretl matrices in the array @A, and
13712 * the array itself. See also gretl_matrix_array_alloc().
13713 */
13714
gretl_matrix_array_free(gretl_matrix ** A,int n)13715 void gretl_matrix_array_free (gretl_matrix **A, int n)
13716 {
13717 int i;
13718
13719 if (A != NULL) {
13720 for (i=0; i<n; i++) {
13721 gretl_matrix_free(A[i]);
13722 }
13723 free(A);
13724 }
13725 }
13726
13727 /**
13728 * gretl_matrix_values:
13729 * @x: array to process.
13730 * @n: length of array.
13731 * @opt: if OPT_S the array of values will be sorted, otherwise
13732 * given in order of occurrence.
13733 * @err: location to receive error code.
13734 *
13735 * Returns: an allocated matrix containing the distinct
13736 * values in array @x, or NULL on failure.
13737 */
13738
gretl_matrix_values(const double * x,int n,gretlopt opt,int * err)13739 gretl_matrix *gretl_matrix_values (const double *x, int n,
13740 gretlopt opt, int *err)
13741 {
13742 gretl_matrix *v = NULL;
13743 double *sorted = NULL;
13744 double last;
13745 int i, k, m;
13746
13747 sorted = malloc(n * sizeof *sorted);
13748 if (sorted == NULL) {
13749 *err = E_ALLOC;
13750 return NULL;
13751 }
13752
13753 k = 0;
13754 for (i=0; i<n; i++) {
13755 if (!na(x[i])) {
13756 sorted[k++] = x[i];
13757 }
13758 }
13759
13760 if (k == 0) {
13761 v = gretl_null_matrix_new();
13762 *err = v == NULL ? E_ALLOC : 0;
13763 goto bailout;
13764 }
13765
13766 qsort(sorted, k, sizeof *sorted, gretl_compare_doubles);
13767 m = count_distinct_values(sorted, k);
13768
13769 v = gretl_column_vector_alloc(m);
13770 if (v == NULL) {
13771 *err = E_ALLOC;
13772 goto bailout;
13773 }
13774
13775 if (opt & OPT_S) {
13776 /* sorted */
13777 v->val[0] = last = sorted[0];
13778 m = 1;
13779 for (i=1; i<k; i++) {
13780 if (sorted[i] != last) {
13781 last = sorted[i];
13782 v->val[m++] = sorted[i];
13783 }
13784 }
13785 } else {
13786 /* unsorted */
13787 int j, add;
13788
13789 m = 0;
13790 for (i=0; i<n; i++) {
13791 if (!na(x[i])) {
13792 add = 1;
13793 for (j=0; j<m; j++) {
13794 if (v->val[j] == x[i]) {
13795 add = 0;
13796 break;
13797 }
13798 }
13799 if (add) {
13800 v->val[m++] = x[i];
13801 }
13802 }
13803 }
13804 }
13805
13806 bailout:
13807
13808 free(sorted);
13809
13810 return v;
13811 }
13812
13813 /**
13814 * gretl_matrix_shape:
13815 * @A: array to process.
13816 * @r: rows of target matrix.
13817 * @c: columns of target matrix.
13818 *
13819 * Creates an (r x c) matrix containing the re-arranged
13820 * values of A. Elements are read from A by column and
13821 * written into the target, also by column. If A contains
13822 * less elements than n = r*c, they are repeated cyclically;
13823 * if A has more elements, only the first n are used.
13824 *
13825 * Returns: the generated matrix, or NULL on failure.
13826 */
13827
gretl_matrix_shape(const gretl_matrix * A,int r,int c,int * err)13828 gretl_matrix *gretl_matrix_shape (const gretl_matrix *A,
13829 int r, int c, int *err)
13830 {
13831 gretl_matrix *B = NULL;
13832
13833 if (gretl_is_null_matrix(A) || r < 0 || c < 0) {
13834 *err = E_INVARG;
13835 return NULL;
13836 }
13837
13838 if (r == 0 && c == 0) {
13839 return gretl_null_matrix_new();
13840 }
13841
13842 if (A->is_complex) {
13843 B = gretl_cmatrix_new(r, c);
13844 } else {
13845 B = gretl_matrix_alloc(r, c);
13846 }
13847
13848 if (B == NULL) {
13849 *err = E_ALLOC;
13850 } else {
13851 int nA = A->rows * A->cols;
13852 int nB = r * c;
13853 int i, k = 0;
13854
13855 if (A->is_complex) {
13856 nA *= 2;
13857 nB *= 2;
13858 }
13859
13860 k = 0;
13861 for (i=0; i<nB; i++) {
13862 B->val[i] = A->val[k++];
13863 if (k == nA) {
13864 k = 0;
13865 }
13866 }
13867 }
13868
13869 return B;
13870 }
13871
13872 /**
13873 * gretl_matrix_trim_rows:
13874 * @A: array to process.
13875 * @ttop: rows to trim at top.
13876 * @tbot: rows to trim at bottom.
13877 * @err: location to receive error code.
13878 *
13879 * Creates a new matrix which is a copy of @A with @ttop rows
13880 * trimmed from the top and @tbot rows trimmed from the
13881 * bottom.
13882 *
13883 * Returns: the generated matrix, or NULL on failure.
13884 */
13885
gretl_matrix_trim_rows(const gretl_matrix * A,int ttop,int tbot,int * err)13886 gretl_matrix *gretl_matrix_trim_rows (const gretl_matrix *A,
13887 int ttop, int tbot,
13888 int *err)
13889 {
13890 gretl_matrix *B;
13891 double complex z;
13892 double x;
13893 int i, j, m;
13894
13895 if (gretl_is_null_matrix(A)) {
13896 *err = E_DATA;
13897 return NULL;
13898 }
13899
13900 m = A->rows - (ttop + tbot);
13901
13902 if (ttop < 0 || tbot < 0 || m <= 0) {
13903 *err = E_DATA;
13904 return NULL;
13905 }
13906
13907 B = gretl_matching_matrix_new(m, A->cols, A);
13908
13909 if (B == NULL) {
13910 *err = E_ALLOC;
13911 } else {
13912 for (j=0; j<A->cols; j++) {
13913 for (i=0; i<m; i++) {
13914 if (A->is_complex) {
13915 z = gretl_cmatrix_get(A, i + ttop, j);
13916 gretl_cmatrix_set(B, i, j, z);
13917 } else {
13918 x = gretl_matrix_get(A, i + ttop, j);
13919 gretl_matrix_set(B, i, j, x);
13920 }
13921 }
13922 }
13923 }
13924
13925 return B;
13926 }
13927
13928 /**
13929 * gretl_matrix_minmax:
13930 * @A: m x n matrix to examine.
13931 * @mm: 0 for minimum, 1 for maximum.
13932 * @rc: 0 for row, 1 for column.
13933 * @idx: 0 for values, 1 for indices.
13934 * @err: location to receive error code.
13935 *
13936 * Creates a matrix holding the row or column mimima or
13937 * maxima from @A, either as values or as location indices.
13938 * For example, if @mm = 0, @rc = 0, and @idx = 0, the
13939 * created matrix is m x 1 and holds the values of the row
13940 * minima.
13941 *
13942 * Returns: the generated matrix, or NULL on failure.
13943 */
13944
gretl_matrix_minmax(const gretl_matrix * A,int mm,int rc,int idx,int * err)13945 gretl_matrix *gretl_matrix_minmax (const gretl_matrix *A,
13946 int mm, int rc, int idx,
13947 int *err)
13948 {
13949 gretl_matrix *B;
13950 double d, x;
13951 int i, j, k;
13952
13953 if (gretl_is_null_matrix(A)) {
13954 *err = E_DATA;
13955 return NULL;
13956 }
13957
13958 if (rc == 0) {
13959 B = gretl_matrix_alloc(A->rows, 1);
13960 } else {
13961 B = gretl_matrix_alloc(1, A->cols);
13962 }
13963
13964 if (B == NULL) {
13965 *err = E_ALLOC;
13966 return NULL;
13967 }
13968
13969 if (rc == 0) {
13970 /* going by rows */
13971 for (i=0; i<A->rows; i++) {
13972 d = gretl_matrix_get(A, i, 0);
13973 k = 0;
13974 for (j=1; j<A->cols; j++) {
13975 x = gretl_matrix_get(A, i, j);
13976 if (mm > 0) {
13977 /* looking for max */
13978 if (x > d) {
13979 d = x;
13980 k = j;
13981 }
13982 } else {
13983 /* looking for min */
13984 if (x < d) {
13985 d = x;
13986 k = j;
13987 }
13988 }
13989 }
13990 B->val[i] = idx ? (double) k + 1 : d;
13991 }
13992 } else {
13993 /* going by columns */
13994 for (j=0; j<A->cols; j++) {
13995 d = gretl_matrix_get(A, 0, j);
13996 k = 0;
13997 for (i=1; i<A->rows; i++) {
13998 x = gretl_matrix_get(A, i, j);
13999 if (mm > 0) {
14000 /* looking for max */
14001 if (x > d) {
14002 d = x;
14003 k = i;
14004 }
14005 } else {
14006 /* looking for min */
14007 if (x < d) {
14008 d = x;
14009 k = i;
14010 }
14011 }
14012 }
14013 B->val[j] = idx ? (double) k + 1 : d;
14014 }
14015 }
14016
14017 return B;
14018 }
14019
14020 /**
14021 * gretl_matrix_global_minmax:
14022 * @A: matrix to examine.
14023 * @mm: 0 for minimum, 1 for maximum.
14024 * @err: location to receive error code.
14025 *
14026 * Returns: the smallest or greatest element of @A,
14027 * ignoring NaNs but not infinities (?), or #NADBL on
14028 * failure.
14029 */
14030
gretl_matrix_global_minmax(const gretl_matrix * A,int mm,int * err)14031 double gretl_matrix_global_minmax (const gretl_matrix *A,
14032 int mm, int *err)
14033 {
14034 double x, ret = NADBL;
14035 int i, n, started = 0;
14036
14037 if (gretl_is_null_matrix(A)) {
14038 *err = E_DATA;
14039 return NADBL;
14040 }
14041
14042 n = A->rows * A->cols;
14043
14044 for (i=0; i<n; i++) {
14045 x = A->val[i];
14046 if (isnan(x)) {
14047 ; /* skip? */
14048 } else {
14049 if (!started) {
14050 ret = x;
14051 started = 1;
14052 } else if ((mm == 0 && x < ret) ||
14053 (mm == 1 && x > ret)) {
14054 ret = x;
14055 }
14056 }
14057 }
14058
14059 return ret;
14060 }
14061
14062 /**
14063 * gretl_matrix_global_sum:
14064 * @A: matrix to examine.
14065 * @err: location to receive error code.
14066 *
14067 * Returns: the sum of the elements of @A,
14068 * or #NADBL on failure.
14069 */
14070
gretl_matrix_global_sum(const gretl_matrix * A,int * err)14071 double gretl_matrix_global_sum (const gretl_matrix *A,
14072 int *err)
14073 {
14074 double ret = 0.0;
14075 int i, n;
14076
14077 if (gretl_is_null_matrix(A)) {
14078 *err = E_DATA;
14079 return NADBL;
14080 }
14081
14082 n = A->rows * A->cols;
14083
14084 for (i=0; i<n; i++) {
14085 ret += A->val[i];
14086 if (isnan(ret)) {
14087 break;
14088 }
14089 }
14090
14091 return ret;
14092 }
14093
14094 /**
14095 * gretl_matrix_pca:
14096 * @X: T x m data matrix.
14097 * @p: number of principal components to return: 0 < p <= m.
14098 * @opt: if OPT_V, use the covariance matrix rather than the
14099 * correlation matrix as basis.
14100 * @err: location to receive error code.
14101 *
14102 * Carries out a Principal Components analysis of @X and
14103 * returns the first @p components: the component corresponding
14104 * to the largest eigenvalue of the correlation matrix of @X
14105 * is placed in column 1, and so on.
14106 *
14107 * Returns: the generated matrix, or NULL on failure.
14108 */
14109
gretl_matrix_pca(const gretl_matrix * X,int p,gretlopt opt,int * err)14110 gretl_matrix *gretl_matrix_pca (const gretl_matrix *X, int p,
14111 gretlopt opt, int *err)
14112 {
14113 gretl_matrix *D = NULL;
14114 gretl_matrix *V = NULL;
14115 gretl_matrix *P = NULL;
14116 gretl_matrix *e;
14117
14118 if (gretl_is_null_matrix(X)) {
14119 *err = E_DATA;
14120 return NULL;
14121 }
14122
14123 if (p <= 0 || p > X->cols) {
14124 *err = E_INVARG;
14125 return NULL;
14126 } else if (X->rows < 2) {
14127 *err = E_TOOFEW;
14128 return NULL;
14129 } else if (X->is_complex) {
14130 *err = E_CMPLX;
14131 return NULL;
14132 }
14133
14134 D = gretl_matrix_copy(X);
14135 if (D == NULL) {
14136 *err = E_ALLOC;
14137 return NULL;
14138 }
14139
14140 if (opt & OPT_V) {
14141 /* use covariance matrix */
14142 gretl_matrix_center(D);
14143 } else {
14144 /* use correlation matrix */
14145 gretl_matrix_standardize(D, 1);
14146 }
14147
14148 V = gretl_matrix_XTX_new(D);
14149 if (V == NULL) {
14150 *err = E_ALLOC;
14151 } else {
14152 /* note: we don't need the eigenvalues of V, but if we
14153 don't grab and then free the return value below,
14154 we'll leak a gretl_matrix
14155 */
14156 e = real_symm_eigenvals_descending(V, 1, p, err);
14157 gretl_matrix_free(e);
14158 }
14159
14160 if (!*err) {
14161 P = gretl_matrix_multiply_new(D, V, err);
14162 }
14163
14164 gretl_matrix_free(D);
14165 gretl_matrix_free(V);
14166
14167 return P;
14168 }
14169
14170 #define complete_obs(x,y,t) (!na(x[t]) && !na(y[t]))
14171
ok_xy_count(int t1,int t2,const double * x,const double * y)14172 static int ok_xy_count (int t1, int t2, const double *x, const double *y)
14173 {
14174 int t, n = 0;
14175
14176 for (t=t1; t<=t2; t++) {
14177 if (complete_obs(x, y, t)) {
14178 n++;
14179 }
14180 }
14181
14182 return n;
14183 }
14184
make_matrix_xtab(double ** X,int n,const gretl_matrix * vx,const gretl_matrix * vy,gretl_matrix * tab)14185 static void make_matrix_xtab (double **X, int n,
14186 const gretl_matrix *vx,
14187 const gretl_matrix *vy,
14188 gretl_matrix *tab)
14189 {
14190 int xr, xc, rndx, cndx;
14191 int counter, i;
14192
14193 qsort(X, n, sizeof *X, compare_xtab_rows);
14194
14195 /* compute frequencies by going through sorted X */
14196
14197 counter = rndx = cndx = 0;
14198 xr = (int) gretl_vector_get(vx, 0);
14199 xc = (int) gretl_vector_get(vy, 0);
14200
14201 for (i=0; i<n; i++) {
14202 while (X[i][0] > xr) {
14203 /* skip row */
14204 gretl_matrix_set(tab, rndx, cndx, counter);
14205 counter = 0;
14206 xr = gretl_vector_get(vx, ++rndx);
14207 cndx = 0;
14208 xc = gretl_vector_get(vy, 0);
14209 }
14210 while (X[i][1] > xc) {
14211 /* skip column */
14212 gretl_matrix_set(tab, rndx, cndx, counter);
14213 counter = 0;
14214 xc = gretl_vector_get(vy, ++cndx);
14215 }
14216 counter++;
14217 }
14218 gretl_matrix_set(tab, rndx, cndx, counter);
14219 }
14220
14221 /**
14222 * matrix_matrix_xtab:
14223 * @x: data vector
14224 * @y: data vector
14225 * @err: error code
14226 *
14227 * Computes the cross tabulation of the values contained in the
14228 * vectors x (by row) and y (by column). These must be integer values.
14229 *
14230 * Returns: the generated matrix, or NULL on failure.
14231 */
14232
matrix_matrix_xtab(const gretl_matrix * x,const gretl_matrix * y,int * err)14233 gretl_matrix *matrix_matrix_xtab (const gretl_matrix *x,
14234 const gretl_matrix *y,
14235 int *err)
14236 {
14237 gretl_matrix *tab = NULL;
14238 gretl_matrix *vx = NULL;
14239 gretl_matrix *vy = NULL;
14240 double **X = NULL;
14241 int i, nx, ny;
14242
14243 *err = 0;
14244
14245 nx = gretl_vector_get_length(x);
14246 ny = gretl_vector_get_length(y);
14247
14248 if (nx < 2 || ny != nx) {
14249 *err = E_NONCONF;
14250 return NULL;
14251 }
14252
14253 vx = gretl_matrix_values(x->val, nx, OPT_S, err);
14254 if (*err) {
14255 return NULL;
14256 }
14257
14258 vy = gretl_matrix_values(y->val, ny, OPT_S, err);
14259 if (*err) {
14260 goto bailout;
14261 }
14262
14263 tab = gretl_zero_matrix_new(vx->rows, vy->rows);
14264 if (tab == NULL) {
14265 *err = E_ALLOC;
14266 goto bailout;
14267 }
14268
14269 X = doubles_array_new(nx, 2);
14270 if (X == NULL) {
14271 *err = E_ALLOC;
14272 goto bailout;
14273 }
14274
14275 for (i=0; i<nx; i++) {
14276 X[i][0] = (int) x->val[i];
14277 X[i][1] = (int) y->val[i];
14278 }
14279
14280 make_matrix_xtab(X, nx, vx, vy, tab);
14281
14282 bailout:
14283
14284 gretl_matrix_free(vx);
14285 gretl_matrix_free(vy);
14286 doubles_array_free(X, nx);
14287
14288 return tab;
14289 }
14290
14291 /**
14292 * gretl_matrix_xtab:
14293 * @x: data vector
14294 * @y: data vector
14295 * @t1: start
14296 * @t2: end
14297 * @err: error code
14298 *
14299 * Computes the cross tabulation of the values contained in the
14300 * vectors x (by row) and y (by column). These must be integer values.
14301 *
14302 * Returns: the generated matrix, or NULL on failure.
14303 */
14304
gretl_matrix_xtab(int t1,int t2,const double * x,const double * y,int * err)14305 gretl_matrix *gretl_matrix_xtab (int t1, int t2, const double *x,
14306 const double *y, int *err)
14307 {
14308 gretl_matrix *tab = NULL;
14309 gretl_matrix *vx = NULL;
14310 gretl_matrix *vy = NULL;
14311 double *tmp = NULL;
14312 double **X = NULL;
14313 int i, t, nmax = t2 - t1 + 1;
14314
14315 *err = 0;
14316
14317 nmax = ok_xy_count(t1, t2, x, y);
14318 if (nmax < 2) {
14319 *err = E_MISSDATA;
14320 return NULL;
14321 }
14322
14323 tmp = malloc(nmax * sizeof *tmp);
14324 if (tmp == NULL) {
14325 *err = E_ALLOC;
14326 return NULL;
14327 }
14328
14329 i = 0;
14330 for (t=t1; t<=t2; t++) {
14331 if (complete_obs(x, y, t)) {
14332 tmp[i++] = x[t];
14333 }
14334 }
14335
14336 vx = gretl_matrix_values(tmp, nmax, OPT_S, err);
14337 if (*err) {
14338 free(tmp);
14339 return NULL;
14340 }
14341
14342 i = 0;
14343 for (t=t1; t<=t2; t++) {
14344 if (complete_obs(x, y, t)) {
14345 tmp[i++] = y[t];
14346 }
14347 }
14348
14349 vy = gretl_matrix_values(tmp, nmax, OPT_S, err);
14350 if (*err) {
14351 goto bailout;
14352 }
14353
14354 tab = gretl_zero_matrix_new(gretl_matrix_rows(vx),
14355 gretl_matrix_rows(vy));
14356 if (tab == NULL) {
14357 *err = E_ALLOC;
14358 goto bailout;
14359 }
14360
14361 X = doubles_array_new(nmax, 2);
14362 if (X == NULL) {
14363 *err = E_ALLOC;
14364 goto bailout;
14365 }
14366
14367 i = 0;
14368 for (t=t1; t<=t2; t++) {
14369 if (complete_obs(x, y, t)) {
14370 X[i][0] = (int) x[t];
14371 X[i][1] = (int) y[t];
14372 i++;
14373 }
14374 }
14375
14376 make_matrix_xtab(X, nmax, vx, vy, tab);
14377
14378 bailout:
14379
14380 free(tmp);
14381 gretl_matrix_free(vx);
14382 gretl_matrix_free(vy);
14383 doubles_array_free(X, nmax);
14384
14385 return tab;
14386 }
14387
14388 /**
14389 * gretl_matrix_bool_sel:
14390 * @A: matrix.
14391 * @sel: selection vector.
14392 * @rowsel: row/column mode selector.
14393 * @err: location to receive error code.
14394 *
14395 * If @rowsel = 1, constructs a matrix which contains the rows
14396 * of A corresponding to non-zero values in the vector @sel;
14397 * if @rowsel = 0, does the same thing but column-wise.
14398 *
14399 * Returns: the generated matrix, or NULL on failure.
14400 */
14401
gretl_matrix_bool_sel(const gretl_matrix * A,const gretl_matrix * sel,int rowsel,int * err)14402 gretl_matrix *gretl_matrix_bool_sel (const gretl_matrix *A,
14403 const gretl_matrix *sel,
14404 int rowsel, int *err)
14405 {
14406 gretl_matrix *ret = NULL;
14407 int nonzero = 0;
14408 int ra, ca, rs, cs;
14409 int rret, cret;
14410 int i, j, k, n;
14411 double x;
14412
14413 *err = 0;
14414
14415 if (gretl_is_null_matrix(A)) {
14416 return gretl_null_matrix_new();
14417 } else if (sel->is_complex) {
14418 *err = E_INVARG;
14419 return NULL;
14420 }
14421
14422 ra = A->rows;
14423 ca = A->cols;
14424 rs = sel->rows;
14425 cs = sel->cols;
14426
14427 /* check dimensions */
14428 if (rowsel) {
14429 if ((ra != rs) || (cs > 1)) {
14430 *err = E_NONCONF;
14431 return NULL;
14432 }
14433 } else {
14434 if ((ca != cs) || (rs > 1)) {
14435 *err = E_NONCONF;
14436 return NULL;
14437 }
14438 }
14439
14440 /* count nonzeros */
14441 n = (rowsel)? rs : cs ;
14442 for (i=0; i<n; i++) {
14443 x = gretl_vector_get(sel, i);
14444 if (na(x)) {
14445 *err = E_MISSDATA;
14446 return NULL;
14447 } else if (x != 0) {
14448 nonzero++;
14449 }
14450 }
14451
14452 /* check for extreme cases */
14453 if (nonzero == n) {
14454 ret = gretl_matrix_copy(A);
14455 goto bailout;
14456 } else if (nonzero == 0) {
14457 ret = gretl_null_matrix_new();
14458 goto bailout;
14459 }
14460
14461 rret = rowsel ? nonzero : ra;
14462 cret = rowsel ? ca : nonzero;
14463
14464 if (A->is_complex) {
14465 ret = gretl_cmatrix_new(rret, cret);
14466 } else {
14467 ret = gretl_matrix_alloc(rret, cret);
14468 }
14469 if (ret == NULL) {
14470 goto bailout;
14471 }
14472
14473 /* copy selected row/columns */
14474 if (rowsel) {
14475 /* selection of rows */
14476 double complex z;
14477
14478 k = 0;
14479 for (i=0; i<ra; i++) {
14480 if (gretl_vector_get(sel, i) != 0) {
14481 for (j=0; j<ca; j++) {
14482 if (A->is_complex) {
14483 z = gretl_cmatrix_get(A, i, j);
14484 gretl_cmatrix_set(ret, k, j, z);
14485 } else {
14486 x = gretl_matrix_get(A, i, j);
14487 gretl_matrix_set(ret, k, j, x);
14488 }
14489 }
14490 k++;
14491 }
14492 }
14493 } else {
14494 /* selection of columns */
14495 double *targ = ret->val;
14496 double *src = A->val;
14497 int rdim = A->is_complex ? 2 : 1;
14498 size_t colsize = ra * rdim * sizeof *src;
14499
14500 for (j=0; j<ca; j++) {
14501 if (gretl_vector_get(sel, j) != 0) {
14502 memcpy(targ, src, colsize);
14503 targ += ra * rdim;
14504 }
14505 src += ra * rdim;
14506 }
14507 }
14508
14509 if (rowsel) {
14510 maybe_preserve_names(ret, A, ROWNAMES, sel);
14511 maybe_preserve_names(ret, A, COLNAMES, NULL);
14512 } else {
14513 maybe_preserve_names(ret, A, COLNAMES, sel);
14514 maybe_preserve_names(ret, A, ROWNAMES, NULL);
14515 }
14516
14517 bailout:
14518
14519 if (ret == NULL) {
14520 *err = E_ALLOC;
14521 }
14522
14523 return ret;
14524 }
14525
unstable_comp(double a,double b)14526 static int unstable_comp (double a, double b)
14527 {
14528 int ret = 0;
14529
14530 if (isnan(a) || isnan(b)) {
14531 if (!isnan(a)) {
14532 ret = -1;
14533 } else if (!isnan(b)) {
14534 ret = 1;
14535 }
14536 } else {
14537 ret = (a > b) - (a < b);
14538 }
14539
14540 return ret;
14541 }
14542
compare_values(const void * a,const void * b)14543 static int compare_values (const void *a, const void *b)
14544 {
14545 const double *da = (const double *) a;
14546 const double *db = (const double *) b;
14547 int ret = unstable_comp(*da, *db);
14548
14549 if (ret == 0) {
14550 /* ensure stable sort */
14551 ret = a - b > 0 ? 1 : -1;
14552 }
14553
14554 return ret;
14555 }
14556
inverse_compare_values(const void * a,const void * b)14557 static int inverse_compare_values (const void *a, const void *b)
14558 {
14559 const double *da = (const double *) a;
14560 const double *db = (const double *) b;
14561 int ret = unstable_comp(*db, *da);
14562
14563 if (ret == 0) {
14564 /* ensure stable sort */
14565 ret = a - b > 0 ? 1 : -1;
14566 }
14567
14568 return ret;
14569 }
14570
14571 /**
14572 * gretl_matrix_sort_by_column:
14573 * @m: matrix.
14574 * @k: column by which to sort.
14575 * @err: location to receive error code.
14576 *
14577 * Produces a matrix which contains the rows of @m, re-
14578 * ordered by increasing value of the elements in column
14579 * @k.
14580 *
14581 * Returns: the generated matrix, or NULL on failure.
14582 */
14583
gretl_matrix_sort_by_column(const gretl_matrix * m,int k,int * err)14584 gretl_matrix *gretl_matrix_sort_by_column (const gretl_matrix *m,
14585 int k, int *err)
14586 {
14587 struct rsort {
14588 double x;
14589 int row;
14590 } *rs;
14591 gretl_matrix *a;
14592 double x;
14593 int i, j;
14594
14595 if (gretl_is_null_matrix(m) || k < 0 || k >= m->cols) {
14596 *err = E_DATA;
14597 return NULL;
14598 }
14599
14600 rs = malloc(m->rows * sizeof *rs);
14601 if (rs == NULL) {
14602 *err = E_ALLOC;
14603 return NULL;
14604 }
14605
14606 a = gretl_matrix_copy(m);
14607 if (a == NULL) {
14608 free(rs);
14609 *err = E_ALLOC;
14610 return NULL;
14611 }
14612
14613 for (i=0; i<m->rows; i++) {
14614 rs[i].x = gretl_matrix_get(m, i, k);
14615 rs[i].row = i;
14616 }
14617
14618 qsort(rs, m->rows, sizeof *rs, compare_values);
14619
14620 for (j=0; j<m->cols; j++) {
14621 for (i=0; i<m->rows; i++) {
14622 x = gretl_matrix_get(m, rs[i].row, j);
14623 gretl_matrix_set(a, i, j, x);
14624 }
14625 }
14626
14627 if (a->info != NULL && a->info->rownames != NULL) {
14628 char **S = malloc(a->rows * sizeof *S);
14629
14630 if (S != NULL) {
14631 for (i=0; i<a->rows; i++) {
14632 S[i] = a->info->rownames[i];
14633 }
14634 for (i=0; i<a->rows; i++) {
14635 a->info->rownames[i] = S[rs[i].row];
14636 }
14637 free(S);
14638 }
14639 }
14640
14641 free(rs);
14642
14643 return a;
14644 }
14645
14646 #define has_colnames(m) (m != NULL && !is_block_matrix(m) && \
14647 m->info != NULL && m->info->colnames != NULL)
14648
14649 #define has_rownames(m) (m != NULL && !is_block_matrix(m) && \
14650 m->info != NULL && m->info->rownames != NULL)
14651
14652 struct named_val {
14653 double x;
14654 const char *s;
14655 };
14656
14657 static struct named_val *
make_named_vals(const gretl_matrix * m,char ** S,int n)14658 make_named_vals (const gretl_matrix *m, char **S, int n)
14659 {
14660 struct named_val *nv = malloc(n * sizeof *nv);
14661
14662 if (nv != NULL) {
14663 int i;
14664
14665 for (i=0; i<n; i++) {
14666 nv[i].x = m->val[i];
14667 nv[i].s = S[i];
14668 }
14669 }
14670
14671 return nv;
14672 }
14673
vector_copy_marginal_names(gretl_vector * v,struct named_val * nv,int n)14674 static int vector_copy_marginal_names (gretl_vector *v,
14675 struct named_val *nv,
14676 int n)
14677 {
14678 int err = gretl_matrix_add_info(v);
14679
14680 /* note: we assume v->info is NULL on entry */
14681
14682 if (!err) {
14683 char ***pS;
14684 int i;
14685
14686 pS = v->cols > 1 ? &v->info->colnames : &v->info->rownames;
14687 *pS = strings_array_new(n);
14688 if (*pS != NULL) {
14689 for (i=0; i<n; i++) {
14690 (*pS)[i] = gretl_strdup(nv[i].s);
14691 }
14692 } else {
14693 err = E_ALLOC;
14694 }
14695 }
14696
14697 return err;
14698 }
14699
gretl_vector_sort(const gretl_matrix * v,int descending,int * err)14700 gretl_matrix *gretl_vector_sort (const gretl_matrix *v,
14701 int descending,
14702 int *err)
14703 {
14704 int n = gretl_vector_get_length(v);
14705 gretl_matrix *vs = NULL;
14706
14707 if (n == 0) {
14708 *err = E_TYPES;
14709 return NULL;
14710 }
14711
14712 vs = matrix_copy_plain(v);
14713
14714 if (vs == NULL) {
14715 *err = E_ALLOC;
14716 } else {
14717 struct named_val *nvals = NULL;
14718 char **S = NULL;
14719
14720 if (v->cols > 1 && has_colnames(v)) {
14721 S = v->info->colnames;
14722 } else if (v->rows > 1 && has_rownames(v)) {
14723 S = v->info->rownames;
14724 }
14725
14726 if (S != NULL) {
14727 nvals = make_named_vals(v, S, n);
14728 if (nvals == NULL) {
14729 *err = E_ALLOC;
14730 }
14731 }
14732
14733 if (nvals != NULL) {
14734 int i;
14735
14736 qsort(nvals, n, sizeof *nvals, descending ?
14737 inverse_compare_values : compare_values);
14738 for (i=0; i<n; i++) {
14739 vs->val[i] = nvals[i].x;
14740 }
14741 vector_copy_marginal_names(vs, nvals, n);
14742 free(nvals);
14743 } else if (!*err) {
14744 double *x = vs->val;
14745
14746 qsort(x, n, sizeof *x, descending ? gretl_inverse_compare_doubles :
14747 gretl_compare_doubles);
14748 }
14749 }
14750
14751 return vs;
14752 }
14753
14754 /* Calculate X(t)-transpose * X(t-lag) */
14755
xtxlag(gretl_matrix * wt,const gretl_matrix * X,int n,int t,int lag)14756 static void xtxlag (gretl_matrix *wt, const gretl_matrix *X,
14757 int n, int t, int lag)
14758 {
14759 double xi, xj;
14760 int i, j;
14761
14762 for (i=0; i<n; i++) {
14763 xi = gretl_matrix_get(X, t, i);
14764 for (j=0; j<n; j++) {
14765 xj = gretl_matrix_get(X, t - lag, j);
14766 gretl_matrix_set(wt, i, j, xi * xj);
14767 }
14768 }
14769 }
14770
14771 /**
14772 * gretl_matrix_covariogram:
14773 * @X: T x k matrix (typically containing regressors).
14774 * @u: T-vector (typically containing residuals), or NULL.
14775 * @w: (p+1)-vector of weights, or NULL.
14776 * @p: lag order >= 0.
14777 * @err: location to receive error code.
14778 *
14779 * Produces the matrix covariogram,
14780 *
14781 * \sum_{j=-p}^{p} \sum_j w_{|j|} (X_t' u_t u_{t-j} X_{t-j})
14782 *
14783 * If @u is not given the u terms are omitted, and if @w
14784 * is not given, all the weights are 1.0.
14785 *
14786 * Returns: the generated matrix, or NULL on failure.
14787 */
14788
gretl_matrix_covariogram(const gretl_matrix * X,const gretl_matrix * u,const gretl_matrix * w,int p,int * err)14789 gretl_matrix *gretl_matrix_covariogram (const gretl_matrix *X,
14790 const gretl_matrix *u,
14791 const gretl_matrix *w,
14792 int p, int *err)
14793 {
14794 gretl_matrix *V;
14795 gretl_matrix *G;
14796 gretl_matrix *xtj;
14797 double uu;
14798 int j, k, t, T;
14799
14800 if (gretl_is_null_matrix(X)) {
14801 return NULL;
14802 }
14803
14804 if (gretl_is_complex(X) ||
14805 gretl_is_complex(u) ||
14806 gretl_is_complex(w)) {
14807 fprintf(stderr, "E_CMPLX in gretl_matrix_covariogram\n");
14808 *err = E_CMPLX;
14809 return NULL;
14810 }
14811
14812 k = X->cols;
14813 T = X->rows;
14814
14815 if (u != NULL && gretl_vector_get_length(u) != T) {
14816 *err = E_NONCONF;
14817 return NULL;
14818 }
14819
14820 if (p < 0 || p > T) {
14821 *err = E_NONCONF;
14822 return NULL;
14823 }
14824
14825 if (w != NULL && gretl_vector_get_length(w) != p + 1) {
14826 *err = E_NONCONF;
14827 return NULL;
14828 }
14829
14830 V = gretl_zero_matrix_new(k, k);
14831 xtj = gretl_matrix_alloc(k, k);
14832 G = gretl_matrix_alloc(k, k);
14833
14834 if (V == NULL || G == NULL || xtj == NULL) {
14835 *err = E_ALLOC;
14836 goto bailout;
14837 }
14838
14839 for (j=0; j<=p; j++) {
14840 gretl_matrix_zero(G);
14841 for (t=j; t<T; t++) {
14842 xtxlag(xtj, X, k, t, j);
14843 if (u != NULL) {
14844 uu = u->val[t] * u->val[t-j];
14845 gretl_matrix_multiply_by_scalar(xtj, uu);
14846 }
14847 gretl_matrix_add_to(G, xtj);
14848 }
14849 if (j > 0) {
14850 gretl_matrix_add_self_transpose(G);
14851 }
14852 if (w != NULL) {
14853 gretl_matrix_multiply_by_scalar(G, w->val[j]);
14854 }
14855 gretl_matrix_add_to(V, G);
14856 }
14857
14858 bailout:
14859
14860 gretl_matrix_free(G);
14861 gretl_matrix_free(xtj);
14862
14863 if (*err) {
14864 gretl_matrix_free(V);
14865 V = NULL;
14866 }
14867
14868 return V;
14869 }
14870
14871 /**
14872 * gretl_matrix_GG_inverse:
14873 * @G: T x k source matrix.
14874 * @err: location to receive error code.
14875 *
14876 * Multiples G' into G and inverts the result. A shortcut
14877 * function intended for producing an approximation to
14878 * the Hessian given a gradient matrix.
14879 *
14880 * Returns: the newly allocated k x k inverse on success,
14881 * or NULL on error.
14882 */
14883
gretl_matrix_GG_inverse(const gretl_matrix * G,int * err)14884 gretl_matrix *gretl_matrix_GG_inverse (const gretl_matrix *G, int *err)
14885 {
14886 gretl_matrix *H = NULL;
14887 int k = G->cols;
14888
14889 H = gretl_matrix_alloc(k, k);
14890 if (H == NULL) {
14891 *err = E_ALLOC;
14892 return NULL;
14893 }
14894
14895 gretl_matrix_multiply_mod(G, GRETL_MOD_TRANSPOSE,
14896 G, GRETL_MOD_NONE,
14897 H, GRETL_MOD_NONE);
14898
14899 *err = gretl_invert_symmetric_matrix(H);
14900
14901 if (*err) {
14902 fprintf(stderr, "gretl_matrix_GG_inverse: H not pd\n");
14903 gretl_matrix_free(H);
14904 H = NULL;
14905 }
14906
14907 return H;
14908 }
14909
14910 /**
14911 * gretl_matrix_transcribe_obs_info:
14912 * @targ: target matrix.
14913 * @src: source matrix.
14914 *
14915 * If @targ and @src have the same number of rows, and if
14916 * the rows of @src are identified by observation stamps
14917 * while those of @targ are not so identified, copy the
14918 * stamp information across to @targ. (Or if the given
14919 * conditions are not satified, do nothing.)
14920 */
14921
gretl_matrix_transcribe_obs_info(gretl_matrix * targ,const gretl_matrix * src)14922 void gretl_matrix_transcribe_obs_info (gretl_matrix *targ,
14923 const gretl_matrix *src)
14924 {
14925 if (targ->rows == src->rows &&
14926 src->info != NULL && targ->info == NULL) {
14927 gretl_matrix_set_t1(targ, src->info->t1);
14928 gretl_matrix_set_t2(targ, src->info->t2);
14929 }
14930 }
14931
reorder_A(const gretl_matrix * A,int n,int np,int * err)14932 static gretl_matrix *reorder_A (const gretl_matrix *A,
14933 int n, int np, int *err)
14934 {
14935 gretl_matrix *B;
14936 int p = np / n;
14937
14938 B = gretl_matrix_alloc(np, n);
14939
14940 if (B == NULL) {
14941 *err = E_ALLOC;
14942 return NULL;
14943 } else {
14944 int i, j, k;
14945 int from, to;
14946 double x, y;
14947
14948 for (j=0; j<n; j++) {
14949 for (k=0; k<=p/2; k++) {
14950 from = k*n;
14951 to = n*(p-k-1);
14952 for (i=0; i<n; i++) {
14953 x = gretl_matrix_get(A, j, from + i);
14954 y = gretl_matrix_get(A, j, to + i);
14955 gretl_matrix_set(B, to + i, j, x);
14956 gretl_matrix_set(B, from + i, j, y);
14957 }
14958 }
14959 }
14960 }
14961
14962 return B;
14963 }
14964
14965 /**
14966 * gretl_matrix_varsimul:
14967 * @A: n x np coefficient matrix.
14968 * @U: T x n data matrix.
14969 * @x0: p x n matrix for initialization.
14970 * @err: location to receive error code.
14971 *
14972 * Simulates a p-order n-variable VAR:
14973 * x_t = \sum A_i x_{t-i} + u_t
14974 *
14975 * The A_i matrices must be stacked horizontally into the @A
14976 * argument, that is: A = A_1 ~ A_2 ~ A_p. The u_t vectors are
14977 * contained (as rows) in @U. Initial values are in @x0.
14978 *
14979 * Note the that the arrangement of the @A matrix is somewhat
14980 * sub-optimal computationally, since its elements have to be
14981 * reordered by the function reorder_A (see above). However, the
14982 * present form is more intuitive for a human being, and that's
14983 * what counts.
14984 *
14985 * Returns: a newly allocated T+p x n matrix on success, whose t-th
14986 * row is (x_t)', or NULL on error.
14987 */
14988
gretl_matrix_varsimul(const gretl_matrix * A,const gretl_matrix * U,const gretl_matrix * x0,int * err)14989 gretl_matrix *gretl_matrix_varsimul (const gretl_matrix *A,
14990 const gretl_matrix *U,
14991 const gretl_matrix *x0,
14992 int *err)
14993 {
14994 gretl_matrix *A2, *X, *UT;
14995 gretl_vector xt, xtlag, ut;
14996 double x;
14997 int p = x0->rows;
14998 int n = x0->cols;
14999 int np = n * p;
15000 int T = p + U->rows;
15001 int t, i;
15002
15003 if (A->rows != n || A->cols != np || U->cols != n) {
15004 *err = E_NONCONF;
15005 return NULL;
15006 }
15007
15008 A2 = reorder_A(A, n, np, err);
15009 X = gretl_matrix_alloc(n, T);
15010 UT = gretl_matrix_copy_transpose(U);
15011
15012 if (X == NULL || A2 == NULL || UT == NULL) {
15013 *err = E_ALLOC;
15014 gretl_matrix_free(A2);
15015 gretl_matrix_free(X);
15016 gretl_matrix_free(UT);
15017 return NULL;
15018 }
15019
15020 for (t=0; t<p; t++) {
15021 for (i=0; i<n; i++) {
15022 x = gretl_matrix_get(x0, t, i);
15023 gretl_matrix_set(X, i, t, x);
15024 }
15025 }
15026
15027 gretl_matrix_init_full(&xt, 1, n, X->val + np);
15028 gretl_matrix_init_full(&ut, 1, n, UT->val);
15029 gretl_matrix_init_full(&xtlag, 1, np, X->val);
15030
15031 for (t=p; t<T; t++) {
15032 gretl_matrix_multiply(&xtlag, A2, &xt);
15033 gretl_matrix_add_to(&xt, &ut);
15034 xt.val += n;
15035 xtlag.val += n;
15036 ut.val += n;
15037 }
15038
15039 *err = gretl_matrix_transpose_in_place(X);
15040
15041 if (!*err) {
15042 /* set dates on output matrix if possible */
15043 int t1 = gretl_matrix_get_t1(U) - p;
15044
15045 if (t1 > 0) {
15046 gretl_matrix_set_t1(X, t1);
15047 gretl_matrix_set_t2(X, t1 + T - 1);
15048 }
15049 }
15050
15051 gretl_matrix_free(A2);
15052 gretl_matrix_free(UT);
15053
15054 return X;
15055 }
15056
15057 /**
15058 * gretl_matrix_set_colnames:
15059 * @m: target matrix.
15060 * @S: array of strings.
15061 *
15062 * Sets an array of strings on @m which can be retrieved
15063 * using gretl_matrix_get_colnames(). Note that @S must
15064 * contain as many strings as @m has columns. The matrix
15065 * takes ownership of @S, which should be allocated and
15066 * not subsequently touched by the caller.
15067 *
15068 * Returns: 0 on success, non-zero code on error.
15069 */
15070
gretl_matrix_set_colnames(gretl_matrix * m,char ** S)15071 int gretl_matrix_set_colnames (gretl_matrix *m, char **S)
15072 {
15073 if (m == NULL) {
15074 return E_DATA;
15075 } else if (is_block_matrix(m)) {
15076 return matrix_block_error("gretl_matrix_set_colnames");
15077 } else if (S != NULL && m->info == NULL &&
15078 gretl_matrix_add_info(m)) {
15079 return E_ALLOC;
15080 }
15081
15082 if (m->info != NULL) {
15083 if (m->info->colnames != NULL) {
15084 strings_array_free(m->info->colnames, m->cols);
15085 }
15086 m->info->colnames = S;
15087 }
15088
15089 return 0;
15090 }
15091
15092 /**
15093 * gretl_matrix_set_rownames:
15094 * @m: target matrix.
15095 * @S: array of strings.
15096 *
15097 * Sets an array of strings on @m which can be retrieved
15098 * using gretl_matrix_get_rownames(). Note that @S must
15099 * contain as many strings as @m has rows. The matrix
15100 * takes ownership of @S, which should be allocated and
15101 * not subsequently touched by the caller.
15102 *
15103 * Returns: 0 on success, non-zero code on error.
15104 */
15105
gretl_matrix_set_rownames(gretl_matrix * m,char ** S)15106 int gretl_matrix_set_rownames (gretl_matrix *m, char **S)
15107 {
15108 if (m == NULL) {
15109 return E_DATA;
15110 } else if (is_block_matrix(m)) {
15111 return matrix_block_error("gretl_matrix_set_rownames");
15112 } else if (S != NULL && m->info == NULL &&
15113 gretl_matrix_add_info(m)) {
15114 return E_ALLOC;
15115 }
15116
15117 if (m->info != NULL) {
15118 if (m->info->rownames != NULL) {
15119 strings_array_free(m->info->rownames, m->rows);
15120 }
15121 m->info->rownames = S;
15122 }
15123
15124 return 0;
15125 }
15126
15127 /**
15128 * gretl_matrix_get_colnames:
15129 * @m: matrix
15130 *
15131 * Returns: The array of strings set on @m using
15132 * gretl_matrix_set_colnames(), or NULL if no such
15133 * strings have been set. The returned array will
15134 * contain as many strings as @m has columns.
15135 */
15136
gretl_matrix_get_colnames(const gretl_matrix * m)15137 const char **gretl_matrix_get_colnames (const gretl_matrix *m)
15138 {
15139 if (has_colnames(m)) {
15140 return (const char **) m->info->colnames;
15141 } else {
15142 return NULL;
15143 }
15144 }
15145
15146 /**
15147 * gretl_matrix_get_rownames:
15148 * @m: matrix
15149 *
15150 * Returns:The array of strings set on @m using
15151 * gretl_matrix_set_rownames(), or NULL if no such
15152 * strings have been set. The returned array will
15153 * contain as many strings as @m has rows.
15154 */
15155
gretl_matrix_get_rownames(const gretl_matrix * m)15156 const char **gretl_matrix_get_rownames (const gretl_matrix *m)
15157 {
15158 if (has_rownames(m)) {
15159 return (const char **) m->info->rownames;
15160 } else {
15161 return NULL;
15162 }
15163 }
15164