1# linalg.tcl -- 2# Linear algebra package, based partly on Hume's LA package, 3# partly on experiments with various representations of 4# matrices. Also the functionality of the BLAS library has 5# been taken into account. 6# 7# General information: 8# - The package provides both a high-level general interface and 9# a lower-level specific interface for various LA functions 10# and tasks. 11# - The general procedures perform some checks and then call 12# the various specific procedures. The general procedures are 13# aimed at robustness and ease of use. 14# - The specific procedures do not check anything, they are 15# designed for speed. Failure to comply to the interface 16# requirements will presumably lead to [expr] errors. 17# - Vectors are represented as lists, matrices as lists of 18# lists, where the rows are the innermost lists: 19# 20# / a11 a12 a13 \ 21# | a21 a22 a23 | == { {a11 a12 a13} {a21 a22 a23} {a31 a32 a33} } 22# \ a31 a32 a33 / 23# 24 25package require Tcl 8.4 26 27namespace eval ::math::linearalgebra { 28 # Define the namespace 29 namespace export dim shape conforming symmetric 30 namespace export norm norm_one norm_two norm_max normMatrix 31 namespace export dotproduct unitLengthVector normalizeStat 32 namespace export axpy axpy_vect axpy_mat crossproduct 33 namespace export add add_vect add_mat 34 namespace export sub sub_vect sub_mat 35 namespace export scale scale_vect scale_mat matmul transpose 36 namespace export rotate angle choleski 37 namespace export getrow getcol getelem setrow setcol setelem 38 namespace export mkVector mkMatrix mkIdentity mkDiagonal 39 namespace export mkHilbert mkDingdong mkBorder mkFrank 40 namespace export mkMoler mkWilkinsonW+ mkWilkinsonW- 41 namespace export solveGauss solveTriangular 42 namespace export solveGaussBand solveTriangularBand 43 namespace export solvePGauss 44 namespace export determineSVD eigenvectorsSVD 45 namespace export leastSquaresSVD 46 namespace export orthonormalizeColumns orthonormalizeRows 47 namespace export show to_LA from_LA 48 namespace export swaprows swapcols 49 namespace export dger dgetrf mkRandom mkTriangular 50 namespace export det largesteigen 51} 52 53# dim -- 54# Return the dimension of an object (scalar, vector or matrix) 55# Arguments: 56# obj Object like a scalar, vector or matrix 57# Result: 58# Dimension: 0 for a scalar, 1 for a vector, 2 for a matrix 59# 60proc ::math::linearalgebra::dim { obj } { 61 set shape [shape $obj] 62 if { $shape != 1 } { 63 return [llength [shape $obj]] 64 } else { 65 return 0 66 } 67} 68 69# shape -- 70# Return the shape of an object (scalar, vector or matrix) 71# Arguments: 72# obj Object like a scalar, vector or matrix 73# Result: 74# List of the sizes: 1 for a scalar, number of components 75# for a vector, number of rows and columns for a matrix 76# 77proc ::math::linearalgebra::shape { obj } { 78 set result [llength $obj] 79 if { [llength [lindex $obj 0]] <= 1 } { 80 return $result 81 } else { 82 lappend result [llength [lindex $obj 0]] 83 } 84 return $result 85} 86 87# show -- 88# Return a string representing the vector or matrix, 89# for easy printing 90# Arguments: 91# obj Object like a scalar, vector or matrix 92# format Format to be used (defaults to %6.4f) 93# rowsep Separator for rows (defaults to \n) 94# colsep Separator for columns (defaults to " ") 95# Result: 96# String representing the vector or matrix 97# 98proc ::math::linearalgebra::show { obj {format %6.4f} {rowsep \n} {colsep " "} } { 99 set result "" 100 if { [llength [lindex $obj 0]] == 1 } { 101 foreach v $obj { 102 append result "[format $format $v]$rowsep" 103 } 104 } else { 105 foreach row $obj { 106 foreach v $row { 107 append result "[format $format $v]$colsep" 108 } 109 append result $rowsep 110 } 111 } 112 return $result 113} 114 115# conforming -- 116# Determine if two objects (vector or matrix) are conforming 117# in shape, rows or for a matrix multiplication 118# Arguments: 119# type Type of conforming: shape, rows or matmul 120# obj1 First object (vector or matrix) 121# obj2 Second object (vector or matrix) 122# Result: 123# 1 if they conform, 0 if not 124# 125proc ::math::linearalgebra::conforming { type obj1 obj2 } { 126 set shape1 [shape $obj1] 127 set shape2 [shape $obj2] 128 set result 0 129 if { $type == "shape" } { 130 set result [expr {[lindex $shape1 0] == [lindex $shape2 0] && 131 [lindex $shape1 1] == [lindex $shape2 1]}] 132 } 133 if { $type == "rows" } { 134 set result [expr {[lindex $shape1 0] == [lindex $shape2 0]}] 135 } 136 if { $type == "matmul" } { 137 set result [expr {[lindex $shape1 1] == [lindex $shape2 0]}] 138 } 139 return $result 140} 141 142# crossproduct -- 143# Return the "cross product" of two 3D vectors 144# Arguments: 145# vect1 First vector 146# vect2 Second vector 147# Result: 148# Cross product 149# 150proc ::math::linearalgebra::crossproduct { vect1 vect2 } { 151 152 if { [llength $vect1] == 3 && [llength $vect2] == 3 } { 153 foreach {v11 v12 v13} $vect1 {v21 v22 v23} $vect2 {break} 154 return [list \ 155 [expr {$v12*$v23 - $v13*$v22}] \ 156 [expr {$v13*$v21 - $v11*$v23}] \ 157 [expr {$v11*$v22 - $v12*$v21}] ] 158 } else { 159 return -code error "Cross-product only defined for 3D vectors" 160 } 161} 162 163# angle -- 164# Return the "angle" between two vectors (in radians) 165# Arguments: 166# vect1 First vector 167# vect2 Second vector 168# Result: 169# Angle between the two vectors 170# 171proc ::math::linearalgebra::angle { vect1 vect2 } { 172 173 set dp [dotproduct $vect1 $vect2] 174 set n1 [norm_two $vect1] 175 set n2 [norm_two $vect2] 176 177 if { $n1 == 0.0 || $n2 == 0.0 } { 178 return -code error "Angle not defined for null vector" 179 } 180 181 return [expr {acos($dp/$n1/$n2)}] 182} 183 184 185# norm -- 186# Compute the (1-, 2- or Inf-) norm of a vector 187# Arguments: 188# vector Vector (list of numbers) 189# type Either 1, 2 or max/inf to indicate the type of 190# norm (default: 2, the euclidean norm) 191# Result: 192# The (1-, 2- or Inf-) norm of a vector 193# Level-1 BLAS : 194# if type = 1, corresponds to DASUM 195# if type = 2, corresponds to DNRM2 196# 197proc ::math::linearalgebra::norm { vector {type 2} } { 198 if { $type == 2 } { 199 return [norm_two $vector] 200 } 201 if { $type == 1 } { 202 return [norm_one $vector] 203 } 204 if { $type == "max" || $type == "inf" } { 205 return [norm_max $vector] 206 } 207 return -code error "Unknown norm: $type" 208} 209 210# norm_one -- 211# Compute the 1-norm of a vector 212# Arguments: 213# vector Vector 214# Result: 215# The 1-norm of a vector 216# 217proc ::math::linearalgebra::norm_one { vector } { 218 set sum 0.0 219 foreach c $vector { 220 set sum [expr {$sum+abs($c)}] 221 } 222 return $sum 223} 224 225# norm_two -- 226# Compute the 2-norm of a vector (euclidean norm) 227# Arguments: 228# vector Vector 229# Result: 230# The 2-norm of a vector 231# Note: 232# Rely on the function hypot() to make this robust 233# against overflow and underflow 234# 235proc ::math::linearalgebra::norm_two { vector } { 236 set sum 0.0 237 foreach c $vector { 238 set sum [expr {hypot($c,$sum)}] 239 } 240 return $sum 241} 242 243# norm_max -- 244# Compute the inf-norm of a vector (maximum of its components) 245# Arguments: 246# vector Vector 247# index, optional if non zero, returns a list made of the maximum 248# value and the index where that maximum was found. 249# if zero, returns the maximum value. 250# Result: 251# The inf-norm of a vector 252# Level-1 BLAS : 253# if index!=0, corresponds to IDAMAX 254# 255proc ::math::linearalgebra::norm_max { vector {index 0}} { 256 set max [lindex $vector 0] 257 set imax 0 258 set i 0 259 foreach c $vector { 260 if {[expr {abs($c)>$max}]} then { 261 set imax $i 262 set max [expr {abs($c)}] 263 } 264 incr i 265 } 266 if {$index == 0} then { 267 set result $max 268 } else { 269 set result [list $max $imax] 270 } 271 return $result 272} 273 274# normMatrix -- 275# Compute the (1-, 2- or Inf-) norm of a matrix 276# Arguments: 277# matrix Matrix (list of row vectors) 278# type Either 1, 2 or max/inf to indicate the type of 279# norm (default: 2, the euclidean norm) 280# Result: 281# The (1-, 2- or Inf-) norm of the matrix 282# 283proc ::math::linearalgebra::normMatrix { matrix {type 2} } { 284 set v {} 285 286 foreach row $matrix { 287 lappend v [norm $row $type] 288 } 289 290 return [norm $v $type] 291} 292 293# symmetric -- 294# Determine if the matrix is symmetric or not 295# Arguments: 296# matrix Matrix (list of row vectors) 297# eps Tolerance (defaults to 1.0e-8) 298# Result: 299# 1 if symmetric (within the tolerance), 0 if not 300# 301proc ::math::linearalgebra::symmetric { matrix {eps 1.0e-8} } { 302 set shape [shape $matrix] 303 if { [lindex $shape 0] != [lindex $shape 1] } { 304 return 0 305 } 306 307 set norm_org [normMatrix $matrix] 308 set norm_asymm [normMatrix [sub $matrix [transpose $matrix]]] 309 310 if { $norm_asymm <= $eps*$norm_org } { 311 return 1 312 } else { 313 return 0 314 } 315} 316 317# dotproduct -- 318# Compute the dot product of two vectors 319# Arguments: 320# vect1 First vector 321# vect2 Second vector 322# Result: 323# The dot product of the two vectors 324# Level-1 BLAS : corresponds to DDOT 325# 326proc ::math::linearalgebra::dotproduct { vect1 vect2 } { 327 if { [llength $vect1] != [llength $vect2] } { 328 return -code error "Vectors must be of equal length" 329 } 330 set sum 0.0 331 foreach c1 $vect1 c2 $vect2 { 332 set sum [expr {$sum + $c1*$c2}] 333 } 334 return $sum 335} 336 337# unitLengthVector -- 338# Normalize a vector so that a length 1 results and return the new vector 339# Arguments: 340# vector Vector to be normalized 341# Result: 342# A vector of length 1 343# 344proc ::math::linearalgebra::unitLengthVector { vector } { 345 set scale [norm_two $vector] 346 if { $scale == 0.0 } { 347 return -code error "Can not normalize a null-vector" 348 } 349 return [scale [expr {1.0/$scale}] $vector] 350} 351 352# normalizeStat -- 353# Normalize a matrix or vector in a statistical sense and return the result 354# Arguments: 355# mv Matrix or vector to be normalized 356# Result: 357# A matrix or vector whose columns are normalised to have a mean of 358# 0 and a standard deviation of 1. 359# 360proc ::math::linearalgebra::normalizeStat { mv } { 361 362 if { [llength [lindex $mv 0]] > 1 } { 363 set result {} 364 foreach vector [transpose $mv] { 365 lappend result [NormalizeStat_vect $vector] 366 } 367 return [transpose $result] 368 } else { 369 return [NormalizeStat_vect $mv] 370 } 371} 372 373# NormalizeStat_vect -- 374# Normalize a vector in a statistical sense and return the result 375# Arguments: 376# v Vector to be normalized 377# Result: 378# A vector whose elements are normalised to have a mean of 379# 0 and a standard deviation of 1. If all coefficients are equal, 380# a null-vector is returned. 381# 382proc ::math::linearalgebra::NormalizeStat_vect { v } { 383 if { [llength $v] <= 1 } { 384 return -code error "Vector can not be normalised - too few coefficients" 385 } 386 387 set sum 0.0 388 set sum2 0.0 389 set count 0.0 390 foreach c $v { 391 set sum [expr {$sum + $c}] 392 set sum2 [expr {$sum2 + $c*$c}] 393 set count [expr {$count + 1.0}] 394 } 395 set corr [expr {$sum/$count}] 396 set factor [expr {($sum2-$sum*$sum/$count)/($count-1)}] 397 if { $factor > 0.0 } { 398 set factor [expr {1.0/sqrt($factor)}] 399 } else { 400 set factor 0.0 401 } 402 set result {} 403 foreach c $v { 404 lappend result [expr {$factor*($c-$corr)}] 405 } 406 return $result 407} 408 409# axpy -- 410# Compute the sum of a scaled vector/matrix and another 411# vector/matrix: a*x + y 412# Arguments: 413# scale Scale factor (a) for the first vector/matrix 414# mv1 First vector/matrix (x) 415# mv2 Second vector/matrix (y) 416# Result: 417# The result of a*x+y 418# Level-1 BLAS : if mv1 is a vector, corresponds to DAXPY 419# 420proc ::math::linearalgebra::axpy { scale mv1 mv2 } { 421 if { [llength [lindex $mv1 0]] > 1 } { 422 return [axpy_mat $scale $mv1 $mv2] 423 } else { 424 return [axpy_vect $scale $mv1 $mv2] 425 } 426} 427 428# axpy_vect -- 429# Compute the sum of a scaled vector and another vector: a*x + y 430# Arguments: 431# scale Scale factor (a) for the first vector 432# vect1 First vector (x) 433# vect2 Second vector (y) 434# Result: 435# The result of a*x+y 436# Level-1 BLAS : corresponds to DAXPY 437# 438proc ::math::linearalgebra::axpy_vect { scale vect1 vect2 } { 439 set result {} 440 441 foreach c1 $vect1 c2 $vect2 { 442 lappend result [expr {$scale*$c1+$c2}] 443 } 444 return $result 445} 446 447# axpy_mat -- 448# Compute the sum of a scaled matrix and another matrix: a*x + y 449# Arguments: 450# scale Scale factor (a) for the first matrix 451# mat1 First matrix (x) 452# mat2 Second matrix (y) 453# Result: 454# The result of a*x+y 455# 456proc ::math::linearalgebra::axpy_mat { scale mat1 mat2 } { 457 set result {} 458 foreach row1 $mat1 row2 $mat2 { 459 lappend result [axpy_vect $scale $row1 $row2] 460 } 461 return $result 462} 463 464# add -- 465# Compute the sum of two vectors/matrices 466# Arguments: 467# mv1 First vector/matrix (x) 468# mv2 Second vector/matrix (y) 469# Result: 470# The result of x+y 471# 472proc ::math::linearalgebra::add { mv1 mv2 } { 473 if { [llength [lindex $mv1 0]] > 1 } { 474 return [add_mat $mv1 $mv2] 475 } else { 476 return [add_vect $mv1 $mv2] 477 } 478} 479 480# add_vect -- 481# Compute the sum of two vectors 482# Arguments: 483# vect1 First vector (x) 484# vect2 Second vector (y) 485# Result: 486# The result of x+y 487# 488proc ::math::linearalgebra::add_vect { vect1 vect2 } { 489 set result {} 490 foreach c1 $vect1 c2 $vect2 { 491 lappend result [expr {$c1+$c2}] 492 } 493 return $result 494} 495 496# add_mat -- 497# Compute the sum of two matrices 498# Arguments: 499# mat1 First matrix (x) 500# mat2 Second matrix (y) 501# Result: 502# The result of x+y 503# 504proc ::math::linearalgebra::add_mat { mat1 mat2 } { 505 set result {} 506 foreach row1 $mat1 row2 $mat2 { 507 lappend result [add_vect $row1 $row2] 508 } 509 return $result 510} 511 512# sub -- 513# Compute the difference of two vectors/matrices 514# Arguments: 515# mv1 First vector/matrix (x) 516# mv2 Second vector/matrix (y) 517# Result: 518# The result of x-y 519# 520proc ::math::linearalgebra::sub { mv1 mv2 } { 521 if { [llength [lindex $mv1 0]] > 0 } { 522 return [sub_mat $mv1 $mv2] 523 } else { 524 return [sub_vect $mv1 $mv2] 525 } 526} 527 528# sub_vect -- 529# Compute the difference of two vectors 530# Arguments: 531# vect1 First vector (x) 532# vect2 Second vector (y) 533# Result: 534# The result of x-y 535# 536proc ::math::linearalgebra::sub_vect { vect1 vect2 } { 537 set result {} 538 foreach c1 $vect1 c2 $vect2 { 539 lappend result [expr {$c1-$c2}] 540 } 541 return $result 542} 543 544# sub_mat -- 545# Compute the difference of two matrices 546# Arguments: 547# mat1 First matrix (x) 548# mat2 Second matrix (y) 549# Result: 550# The result of x-y 551# 552proc ::math::linearalgebra::sub_mat { mat1 mat2 } { 553 set result {} 554 foreach row1 $mat1 row2 $mat2 { 555 lappend result [sub_vect $row1 $row2] 556 } 557 return $result 558} 559 560# scale -- 561# Scale a vector or a matrix 562# Arguments: 563# scale Scale factor (scalar; a) 564# mv Vector/matrix (x) 565# Result: 566# The result of a*x 567# Level-1 BLAS : if mv is a vector, corresponds to DSCAL 568# 569proc ::math::linearalgebra::scale { scale mv } { 570 if { [llength [lindex $mv 0]] > 1 } { 571 return [scale_mat $scale $mv] 572 } else { 573 return [scale_vect $scale $mv] 574 } 575} 576 577# scale_vect -- 578# Scale a vector 579# Arguments: 580# scale Scale factor to apply (a) 581# vect Vector to be scaled (x) 582# Result: 583# The result of a*x 584# Level-1 BLAS : corresponds to DSCAL 585# 586proc ::math::linearalgebra::scale_vect { scale vect } { 587 set result {} 588 foreach c $vect { 589 lappend result [expr {$scale*$c}] 590 } 591 return $result 592} 593 594# scale_mat -- 595# Scale a matrix 596# Arguments: 597# scale Scale factor to apply 598# mat Matrix to be scaled 599# Result: 600# The result of x+y 601# 602proc ::math::linearalgebra::scale_mat { scale mat } { 603 set result {} 604 foreach row $mat { 605 lappend result [scale_vect $scale $row] 606 } 607 return $result 608} 609 610# rotate -- 611# Apply a planar rotation to two vectors 612# Arguments: 613# c Cosine of the angle 614# s Sine of the angle 615# vect1 First vector (x) 616# vect2 Second vector (y) 617# Result: 618# A list of two elements: c*x-s*y and s*x+c*y 619# 620proc ::math::linearalgebra::rotate { c s vect1 vect2 } { 621 set result1 {} 622 set result2 {} 623 foreach v1 $vect1 v2 $vect2 { 624 lappend result1 [expr {$c*$v1-$s*$v2}] 625 lappend result2 [expr {$s*$v1+$c*$v2}] 626 } 627 return [list $result1 $result2] 628} 629 630# transpose -- 631# Transpose a matrix 632# Arguments: 633# matrix Matrix to be transposed 634# Result: 635# The transposed matrix 636# Note: 637# The second transpose implementation is faster on large 638# matrices (100x100 say), there is no significant difference 639# on small ones (10x10 say). 640# 641# 642proc ::math::linearalgebra::transpose_old { matrix } { 643 set row {} 644 set transpose {} 645 foreach c [lindex $matrix 0] { 646 lappend row 0.0 647 } 648 foreach r $matrix { 649 lappend transpose $row 650 } 651 652 set nr 0 653 foreach r $matrix { 654 set nc 0 655 foreach c $r { 656 lset transpose $nc $nr $c 657 incr nc 658 } 659 incr nr 660 } 661 return $transpose 662} 663 664proc ::math::linearalgebra::transpose { matrix } { 665 set transpose {} 666 set c 0 667 foreach col [lindex $matrix 0] { 668 set newrow {} 669 foreach row $matrix { 670 lappend newrow [lindex $row $c] 671 } 672 lappend transpose $newrow 673 incr c 674 } 675 return $transpose 676} 677 678# MorV -- 679# Identify if the object is a row/column vector or a matrix 680# Arguments: 681# obj Object to be examined 682# Result: 683# The letter R, C or M depending on the shape 684# (just to make it all work fine: S for scalar) 685# Note: 686# Private procedure to fix a bug in matmul 687# 688proc ::math::linearalgebra::MorV { obj } { 689 if { [llength $obj] > 1 } { 690 if { [llength [lindex $obj 0]] > 1 } { 691 return "M" 692 } else { 693 return "C" 694 } 695 } else { 696 if { [llength [lindex $obj 0]] > 1 } { 697 return "R" 698 } else { 699 return "S" 700 } 701 } 702} 703 704# matmul -- 705# Multiply a vector/matrix with another vector/matrix 706# Arguments: 707# mv1 First vector/matrix (x) 708# mv2 Second vector/matrix (y) 709# Result: 710# The result of x*y 711# 712proc ::math::linearalgebra::matmul_org { mv1 mv2 } { 713 if { [llength [lindex $mv1 0]] > 1 } { 714 if { [llength [lindex $mv2 0]] > 1 } { 715 return [matmul_mm $mv1 $mv2] 716 } else { 717 return [matmul_mv $mv1 $mv2] 718 } 719 } else { 720 if { [llength [lindex $mv2 0]] > 1 } { 721 return [matmul_vm $mv1 $mv2] 722 } else { 723 return [matmul_vv $mv1 $mv2] 724 } 725 } 726} 727 728proc ::math::linearalgebra::matmul { mv1 mv2 } { 729 switch -exact -- "[MorV $mv1][MorV $mv2]" { 730 "MM" { 731 return [matmul_mm $mv1 $mv2] 732 } 733 "MC" { 734 return [matmul_mv $mv1 $mv2] 735 } 736 "MR" { 737 return -code error "Can not multiply a matrix with a row vector - wrong order" 738 } 739 "RM" { 740 return [matmul_vm [transpose $mv1] $mv2] 741 } 742 "RC" { 743 return [dotproduct [transpose $mv1] $mv2] 744 } 745 "RR" { 746 return -code error "Can not multiply a matrix with a row vector - wrong order" 747 } 748 "CM" { 749 return [transpose [matmul_vm $mv1 $mv2]] 750 } 751 "CR" { 752 return [matmul_vv $mv1 [transpose $mv2]] 753 } 754 "CC" { 755 return [matmul_vv $mv1 $mv2] 756 } 757 "SS" { 758 return [expr {$mv1 * $mv2}] 759 } 760 default { 761 return -code error "Can not use a scalar object" 762 } 763 } 764} 765 766# matmul_mv -- 767# Multiply a matrix and a column vector 768# Arguments: 769# matrix Matrix (applied left: A) 770# vector Vector (interpreted as column vector: x) 771# Result: 772# The vector A*x 773# Level-2 BLAS : corresponds to DTRMV 774# 775proc ::math::linearalgebra::matmul_mv { matrix vector } { 776 set newvect {} 777 foreach row $matrix { 778 set sum 0.0 779 foreach v $vector c $row { 780 set sum [expr {$sum+$v*$c}] 781 } 782 lappend newvect $sum 783 } 784 return $newvect 785} 786 787# matmul_vm -- 788# Multiply a row vector with a matrix 789# Arguments: 790# vector Vector (interpreted as row vector: x) 791# matrix Matrix (applied right: A) 792# Result: 793# The vector xtrans*A = Atrans*x 794# 795proc ::math::linearalgebra::matmul_vm { vector matrix } { 796 return [transpose [matmul_mv [transpose $matrix] $vector]] 797} 798 799# matmul_vv -- 800# Multiply two vectors to obtain a matrix 801# Arguments: 802# vect1 First vector (column vector, x) 803# vect2 Second vector (row vector, y) 804# Result: 805# The "outer product" x*ytrans 806# 807proc ::math::linearalgebra::matmul_vv { vect1 vect2 } { 808 set newmat {} 809 foreach v1 $vect1 { 810 set newrow {} 811 foreach v2 $vect2 { 812 lappend newrow [expr {$v1*$v2}] 813 } 814 lappend newmat $newrow 815 } 816 return $newmat 817} 818 819# matmul_mm -- 820# Multiply two matrices 821# Arguments: 822# mat1 First matrix (A) 823# mat2 Second matrix (B) 824# Result: 825# The matrix product A*B 826# Note: 827# By transposing matrix B we can access the columns 828# as rows - much easier and quicker, as they are 829# the elements of the outermost list. 830# Level-3 BLAS : 831# corresponds to DGEMM (alpha op(A) op(B) + beta C) when alpha=1, op(X)=X and beta=0 832# corresponds to DTRMM (alpha op(A) B) when alpha = 1, op(X)=X 833# 834proc ::math::linearalgebra::matmul_mm { mat1 mat2 } { 835 set newmat {} 836 set tmat [transpose $mat2] 837 foreach row1 $mat1 { 838 set newrow {} 839 foreach row2 $tmat { 840 lappend newrow [dotproduct $row1 $row2] 841 } 842 lappend newmat $newrow 843 } 844 return $newmat 845} 846 847# mkVector -- 848# Make a vector of a given size 849# Arguments: 850# ndim Dimension of the vector 851# value Default value for all elements (default: 0.0) 852# Result: 853# A list with ndim elements, representing a vector 854# 855proc ::math::linearalgebra::mkVector { ndim {value 0.0} } { 856 set result {} 857 858 while { $ndim > 0 } { 859 lappend result $value 860 incr ndim -1 861 } 862 return $result 863} 864 865# mkUnitVector -- 866# Make a unit vector in a given direction 867# Arguments: 868# ndim Dimension of the vector 869# dir The direction (0, ... ndim-1) 870# Result: 871# A list with ndim elements, representing a unit vector 872# 873proc ::math::linearalgebra::mkUnitVector { ndim dir } { 874 875 if { $dir < 0 || $dir >= $ndim } { 876 return -code error "Invalid direction for unit vector - $dir" 877 } else { 878 set result [mkVector $ndim] 879 lset result $dir 1.0 880 } 881 return $result 882} 883 884# mkMatrix -- 885# Make a matrix of a given size 886# Arguments: 887# nrows Number of rows 888# ncols Number of columns 889# value Default value for all elements (default: 0.0) 890# Result: 891# A nested list, representing an nrows x ncols matrix 892# 893proc ::math::linearalgebra::mkMatrix { nrows ncols {value 0.0} } { 894 set result {} 895 896 while { $nrows > 0 } { 897 lappend result [mkVector $ncols $value] 898 incr nrows -1 899 } 900 return $result 901} 902 903# mkIdent -- 904# Make an identity matrix of a given size 905# Arguments: 906# size Number of rows/columns 907# Result: 908# A nested list, representing an size x size identity matrix 909# 910proc ::math::linearalgebra::mkIdentity { size } { 911 set result [mkMatrix $size $size 0.0] 912 913 while { $size > 0 } { 914 incr size -1 915 lset result $size $size 1.0 916 } 917 return $result 918} 919 920# mkDiagonal -- 921# Make a diagonal matrix of a given size 922# Arguments: 923# diag List of values to appear on the diagonal 924# 925# Result: 926# A nested list, representing a diagonal matrix 927# 928proc ::math::linearalgebra::mkDiagonal { diag } { 929 set size [llength $diag] 930 set result [mkMatrix $size $size 0.0] 931 932 while { $size > 0 } { 933 incr size -1 934 lset result $size $size [lindex $diag $size] 935 } 936 return $result 937} 938 939# mkHilbert -- 940# Make a Hilbert matrix of a given size 941# Arguments: 942# size Size of the matrix 943# Result: 944# A nested list, representing a Hilbert matrix 945# Notes: 946# Hilbert matrices are very ill-conditioned wrt 947# eigenvalue/eigenvector problems. Therefore they 948# are good candidates for testing the accuracy 949# of algorithms and implementations. 950# 951proc ::math::linearalgebra::mkHilbert { size } { 952 set result {} 953 for { set j 0 } { $j < $size } { incr j } { 954 set row {} 955 for { set i 0 } { $i < $size } { incr i } { 956 lappend row [expr {1.0/($i+$j+1.0)}] 957 } 958 lappend result $row 959 } 960 return $result 961} 962 963# mkDingdong -- 964# Make a Dingdong matrix of a given size 965# Arguments: 966# size Size of the matrix 967# Result: 968# A nested list, representing a Dingdong matrix 969# Notes: 970# Dingdong matrices are imprecisely represented, 971# but have the property of being very stable in 972# such algorithms as Gauss elimination. 973# 974proc ::math::linearalgebra::mkDingdong { size } { 975 set result {} 976 for { set j 0 } { $j < $size } { incr j } { 977 set row {} 978 for { set i 0 } { $i < $size } { incr i } { 979 lappend row [expr {0.5/($size-$i-$j-0.5)}] 980 } 981 lappend result $row 982 } 983 return $result 984} 985 986# mkOnes -- 987# Make a square matrix consisting of ones 988# Arguments: 989# size Number of rows/columns 990# Result: 991# A nested list, representing a size x size matrix, 992# filled with 1.0 993# 994proc ::math::linearalgebra::mkOnes { size } { 995 return [mkMatrix $size $size 1.0] 996} 997 998# mkMoler -- 999# Make a Moler matrix 1000# Arguments: 1001# size Size of the matrix 1002# Result: 1003# A nested list, representing a Moler matrix 1004# Notes: 1005# Moler matrices have a very simple Choleski 1006# decomposition. It has one small eigenvalue 1007# and it can easily upset elimination methods 1008# for systems of linear equations 1009# 1010proc ::math::linearalgebra::mkMoler { size } { 1011 set result {} 1012 for { set j 0 } { $j < $size } { incr j } { 1013 set row {} 1014 for { set i 0 } { $i < $size } { incr i } { 1015 if { $i == $j } { 1016 lappend row [expr {$i+1}] 1017 } else { 1018 lappend row [expr {($i>$j?$j:$i)-1.0}] 1019 } 1020 } 1021 lappend result $row 1022 } 1023 return $result 1024} 1025 1026# mkFrank -- 1027# Make a Frank matrix 1028# Arguments: 1029# size Size of the matrix 1030# Result: 1031# A nested list, representing a Frank matrix 1032# 1033proc ::math::linearalgebra::mkFrank { size } { 1034 set result {} 1035 for { set j 0 } { $j < $size } { incr j } { 1036 set row {} 1037 for { set i 0 } { $i < $size } { incr i } { 1038 lappend row [expr {($i>$j?$j:$i)-2.0}] 1039 } 1040 lappend result $row 1041 } 1042 return $result 1043} 1044 1045# mkBorder -- 1046# Make a bordered matrix 1047# Arguments: 1048# size Size of the matrix 1049# Result: 1050# A nested list, representing a bordered matrix 1051# Note: 1052# This matrix has size-2 eigenvalues at 1. 1053# 1054proc ::math::linearalgebra::mkBorder { size } { 1055 set result {} 1056 for { set j 0 } { $j < $size } { incr j } { 1057 set row {} 1058 for { set i 0 } { $i < $size } { incr i } { 1059 set entry 0.0 1060 if { $i == $j } { 1061 set entry 1.0 1062 } elseif { $j != $size-1 && $i == $size-1 } { 1063 set entry [expr {pow(2.0,-$j)}] 1064 } elseif { $i != $size-1 && $j == $size-1 } { 1065 set entry [expr {pow(2.0,-$i)}] 1066 } else { 1067 set entry 0.0 1068 } 1069 lappend row $entry 1070 } 1071 lappend result $row 1072 } 1073 return $result 1074} 1075 1076# mkWilkinsonW+ -- 1077# Make a Wilkinson W+ matrix 1078# Arguments: 1079# size Size of the matrix 1080# Result: 1081# A nested list, representing a Wilkinson W+ matrix 1082# Note: 1083# This kind of matrix has pairs of eigenvalues that 1084# are very close together. Usually the order is odd. 1085# 1086proc ::math::linearalgebra::mkWilkinsonW+ { size } { 1087 set result {} 1088 for { set j 0 } { $j < $size } { incr j } { 1089 set row {} 1090 for { set i 0 } { $i < $size } { incr i } { 1091 if { $i == $j } { 1092 # int(n/2) + 1 - min(i,n-i+1) 1093 set min [expr {(($i+1)>$size-($i+1)+1? $size-($i+1)+1 : ($i+1))}] 1094 set entry [expr {int($size/2) + 1 - $min}] 1095 } elseif { $i == $j+1 || $i+1 == $j } { 1096 set entry 1 1097 } else { 1098 set entry 0.0 1099 } 1100 lappend row $entry 1101 } 1102 lappend result $row 1103 } 1104 return $result 1105} 1106 1107# mkWilkinsonW- -- 1108# Make a Wilkinson W- matrix 1109# Arguments: 1110# size Size of the matrix 1111# Result: 1112# A nested list, representing a Wilkinson W- matrix 1113# Note: 1114# This kind of matrix has pairs of eigenvalues with 1115# opposite signs (if the order is odd). 1116# 1117proc ::math::linearalgebra::mkWilkinsonW- { size } { 1118 set result {} 1119 for { set j 0 } { $j < $size } { incr j } { 1120 set row {} 1121 for { set i 0 } { $i < $size } { incr i } { 1122 if { $i == $j } { 1123 set entry [expr {int($size/2) + 1 - ($i+1)}] 1124 } elseif { $i == $j+1 || $i+1 == $j } { 1125 set entry 1 1126 } else { 1127 set entry 0.0 1128 } 1129 lappend row $entry 1130 } 1131 lappend result $row 1132 } 1133 return $result 1134} 1135# mkRandom -- 1136# Make a square matrix consisting of random numbers 1137# Arguments: 1138# size Number of rows/columns 1139# Result: 1140# A nested list, representing a size x size matrix, 1141# filled with random numbers 1142# 1143proc ::math::linearalgebra::mkRandom { size } { 1144 set result {} 1145 for { set j 0 } { $j < $size } { incr j } { 1146 set row {} 1147 for { set i 0 } { $i < $size } { incr i } { 1148 lappend row [expr {rand()}] 1149 } 1150 lappend result $row 1151 } 1152 return $result 1153} 1154# mkTriangular -- 1155# Make a triangular matrix consisting of a constant 1156# Arguments: 1157# size Number of rows/columns 1158# uplo U if the matrix is upper triangular (default), L if the 1159# matrix is lower triangular. 1160# value Default value for all elements (default: 0.0) 1161# Result: 1162# A nested list, representing a size x size matrix, 1163# filled with random numbers 1164# 1165proc ::math::linearalgebra::mkTriangular { size {uplo "U"} {value 1.0}} { 1166 switch -- $uplo { 1167 "U" { 1168 set result {} 1169 for { set j 0 } { $j < $size } { incr j } { 1170 set row {} 1171 for { set i 0 } { $i < $size } { incr i } { 1172 if {$i<$j} then { 1173 lappend row 0. 1174 } else { 1175 lappend row $value 1176 } 1177 } 1178 lappend result $row 1179 } 1180 } 1181 "L" { 1182 set result {} 1183 for { set j 0 } { $j < $size } { incr j } { 1184 set row {} 1185 for { set i 0 } { $i < $size } { incr i } { 1186 if {$i>$j} then { 1187 lappend row 0. 1188 } else { 1189 lappend row $value 1190 } 1191 } 1192 lappend result $row 1193 } 1194 } 1195 default { 1196 error "Unknown value for parameter uplo : $uplo" 1197 } 1198 } 1199 return $result 1200} 1201 1202# getrow -- 1203# Get the specified row from a matrix 1204# Arguments: 1205# matrix Matrix in question 1206# row Index of the row 1207# imin Minimum index of the column (default 0) 1208# imax Maximum index of the column (default ncols-1) 1209# 1210# Result: 1211# A list with the values on the requested row 1212# 1213proc ::math::linearalgebra::getrow { matrix row {imin 0} {imax ""}} { 1214 if {$imax==""} then { 1215 foreach {nrows ncols} [shape $matrix] {break} 1216 if {$ncols==""} then { 1217 # the matrix is a vector 1218 set imax 0 1219 } else { 1220 set imax [expr {$ncols - 1}] 1221 } 1222 } 1223 set row [lindex $matrix $row] 1224 return [lrange $row $imin $imax] 1225} 1226 1227# setrow -- 1228# Set the specified row in a matrix 1229# Arguments: 1230# matrix _Name_ of matrix in question 1231# row Index of the row 1232# newvalues New values for the row 1233# imin Minimum column index (default 0) 1234# imax Maximum column index (default ncols-1) 1235# 1236# Result: 1237# Updated matrix 1238# Side effect: 1239# The matrix is updated 1240# 1241proc ::math::linearalgebra::setrow { matrix row newvalues {imin 0} {imax ""}} { 1242 upvar $matrix mat 1243 if {$imax==""} then { 1244 foreach {nrows ncols} [shape $mat] {break} 1245 if {$ncols==""} then { 1246 # the matrix is a vector 1247 set imax 0 1248 } else { 1249 set imax [expr {$ncols - 1}] 1250 } 1251 } 1252 set icol $imin 1253 foreach value $newvalues { 1254 lset mat $row $icol $value 1255 incr icol 1256 if {$icol>$imax} then { 1257 break 1258 } 1259 } 1260 return $mat 1261} 1262 1263# getcol -- 1264# Get the specified column from a matrix 1265# Arguments: 1266# matrix Matrix in question 1267# col Index of the column 1268# imin Minimum row index (default 0) 1269# imax Minimum row index (default nrows-1) 1270# 1271# Result: 1272# A list with the values on the requested column 1273# 1274proc ::math::linearalgebra::getcol { matrix col {imin 0} {imax ""}} { 1275 if {$imax==""} then { 1276 set nrows [llength $matrix] 1277 set imax [expr {$nrows - 1}] 1278 } 1279 set result {} 1280 set iline 0 1281 foreach row $matrix { 1282 if {$iline>=$imin && $iline<=$imax} then { 1283 lappend result [lindex $row $col] 1284 } 1285 incr iline 1286 } 1287 return $result 1288} 1289 1290# setcol -- 1291# Set the specified column in a matrix 1292# Arguments: 1293# matrix _Name_ of matrix in question 1294# col Index of the column 1295# newvalues New values for the column 1296# imin Minimum row index (default 0) 1297# imax Minimum row index (default nrows-1) 1298# 1299# Result: 1300# Updated matrix 1301# Side effect: 1302# The matrix is updated 1303# 1304proc ::math::linearalgebra::setcol { matrix col newvalues {imin 0} {imax ""}} { 1305 upvar $matrix mat 1306 if {$imax==""} then { 1307 set nrows [llength $mat] 1308 set imax [expr {$nrows - 1}] 1309 } 1310 set index 0 1311 for { set i $imin } { $i <= $imax } { incr i } { 1312 lset mat $i $col [lindex $newvalues $index] 1313 incr index 1314 } 1315 return $mat 1316} 1317 1318# getelem -- 1319# Get the specified element (row,column) from a matrix/vector 1320# Arguments: 1321# matrix Matrix in question 1322# row Index of the row 1323# col Index of the column (not present for vectors) 1324# 1325# Result: 1326# The matrix element (row,column) 1327# 1328proc ::math::linearalgebra::getelem { matrix row {col {}} } { 1329 if { $col != {} } { 1330 lindex $matrix $row $col 1331 } else { 1332 lindex $matrix $row 1333 } 1334} 1335 1336# setelem -- 1337# Set the specified element (row,column) in a matrix or vector 1338# Arguments: 1339# matrix _Name_ of matrix/vector in question 1340# row Index of the row 1341# col Index of the column/new value 1342# newvalue New value for the element (not present for vectors) 1343# 1344# Result: 1345# Updated matrix 1346# Side effect: 1347# The matrix is updated 1348# 1349proc ::math::linearalgebra::setelem { matrix row col {newvalue {}} } { 1350 upvar $matrix mat 1351 if { $newvalue != {} } { 1352 lset mat $row $col $newvalue 1353 } else { 1354 lset mat $row $col 1355 } 1356 return $mat 1357} 1358# swaprows -- 1359# Swap two rows of a matrix 1360# Arguments: 1361# matrix Matrix defining the coefficients 1362# irow1 Index of first row 1363# irow2 Index of second row 1364# imin Minimum column index (default 0) 1365# imax Maximum column index (default ncols-1) 1366# 1367# Result: 1368# The matrix with the two rows swaped. 1369# 1370proc ::math::linearalgebra::swaprows { matrix irow1 irow2 {imin 0} {imax ""}} { 1371 upvar $matrix mat 1372 #swaprows1 mat $irow1 $irow2 $imin $imax 1373 swaprows2 mat $irow1 $irow2 $imin $imax 1374} 1375proc ::math::linearalgebra::swaprows1 { matrix irow1 irow2 {imin 0} {imax ""}} { 1376 upvar $matrix mat 1377 if {$imax==""} then { 1378 foreach {nrows ncols} [shape $mat] {break} 1379 if {$ncols==""} then { 1380 # the matrix is a vector 1381 set imax 0 1382 } else { 1383 set imax [expr {$ncols - 1}] 1384 } 1385 } 1386 set row1 [getrow $mat $irow1 $imin $imax] 1387 set row2 [getrow $mat $irow2 $imin $imax] 1388 setrow mat $irow1 $row2 $imin $imax 1389 setrow mat $irow2 $row1 $imin $imax 1390 return $mat 1391} 1392proc ::math::linearalgebra::swaprows2 { matrix irow1 irow2 {imin 0} {imax ""}} { 1393 upvar $matrix mat 1394 if {$imax==""} then { 1395 foreach {nrows ncols} [shape $mat] {break} 1396 if {$ncols==""} then { 1397 # the matrix is a vector 1398 set imax 0 1399 } else { 1400 set imax [expr {$ncols - 1}] 1401 } 1402 } 1403 set row1 [lrange [lindex $mat $irow1] $imin $imax] 1404 set row2 [lrange [lindex $mat $irow2] $imin $imax] 1405 setrow mat $irow1 $row2 $imin $imax 1406 setrow mat $irow2 $row1 $imin $imax 1407 return $mat 1408} 1409# swapcols -- 1410# Swap two cols of a matrix 1411# Arguments: 1412# matrix Matrix defining the coefficients 1413# icol1 Index of first column 1414# icol2 Index of second column 1415# imin Minimum row index (default 0) 1416# imax Minimum row index (default nrows-1) 1417# 1418# Result: 1419# The matrix with the two columns swaped. 1420# 1421proc ::math::linearalgebra::swapcols { matrix icol1 icol2 {imin 0} {imax ""}} { 1422 upvar $matrix mat 1423 if {$imax==""} then { 1424 set nrows [llength $mat] 1425 set imax [expr {$nrows - 1}] 1426 } 1427 set col1 [getcol $mat $icol1 $imin $imax] 1428 set col2 [getcol $mat $icol2 $imin $imax] 1429 setcol mat $icol1 $col2 $imin $imax 1430 setcol mat $icol2 $col1 $imin $imax 1431 return $mat 1432} 1433 1434# solveGauss -- 1435# Solve a system of linear equations using Gauss elimination 1436# Arguments: 1437# matrix Matrix defining the coefficients 1438# bvect Right-hand side (may be several columns) 1439# 1440# Result: 1441# Solution of the system or an error in case of singularity 1442# LAPACK : corresponds to DGETRS, without row interchanges 1443# 1444proc ::math::linearalgebra::solveGauss { matrix bvect } { 1445 set norows [llength $matrix] 1446 set nocols $norows 1447 1448 for { set i 0 } { $i < $nocols } { incr i } { 1449 set sweep_row [getrow $matrix $i] 1450 set bvect_sweep [getrow $bvect $i] 1451 # No pivoting yet 1452 set sweep_fact [expr {double([lindex $sweep_row $i])}] 1453 for { set j [expr {$i+1}] } { $j < $norows } { incr j } { 1454 set current_row [getrow $matrix $j] 1455 set bvect_current [getrow $bvect $j] 1456 set factor [expr {-[lindex $current_row $i]/$sweep_fact}] 1457 1458 lset matrix $j [axpy_vect $factor $sweep_row $current_row] 1459 lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current] 1460 } 1461 } 1462 1463 return [solveTriangular $matrix $bvect] 1464} 1465# solvePGauss -- 1466# Solve a system of linear equations using Gauss elimination 1467# with partial pivoting 1468# Arguments: 1469# matrix Matrix defining the coefficients 1470# bvect Right-hand side (may be several columns) 1471# 1472# Result: 1473# Solution of the system or an error in case of singularity 1474# LAPACK : corresponds to DGETRS 1475# 1476proc ::math::linearalgebra::solvePGauss { matrix bvect } { 1477 1478 set ipiv [dgetrf matrix] 1479 set norows [llength $matrix] 1480 set nm1 [expr {$norows - 1}] 1481 1482 # Perform all permutations on b 1483 for { set k 0 } { $k < $nm1 } { incr k } { 1484 # Swap b(k) and b(mu) with mu = P(k) 1485 set tmp [lindex $bvect $k] 1486 set mu [lindex $ipiv $k] 1487 setrow bvect $k [lindex $bvect $mu] 1488 setrow bvect $mu $tmp 1489 } 1490 1491 # Perform forward substitution 1492 for { set k 0 } { $k < $nm1 } { incr k } { 1493 set bk [lindex $bvect $k] 1494 # Substitution 1495 for { set iline [expr {$k+1}] } { $iline < $norows } { incr iline } { 1496 set aik [lindex $matrix $iline $k] 1497 set maik [expr {-1. * $aik}] 1498 set bi [lindex $bvect $iline] 1499 setrow bvect $iline [axpy $maik $bk $bi] 1500 } 1501 } 1502 1503 # Perform backward substitution 1504 return [solveTriangular $matrix $bvect] 1505} 1506 1507# solveTriangular -- 1508# Solve a system of linear equations where the matrix is 1509# upper-triangular 1510# Arguments: 1511# matrix Matrix defining the coefficients 1512# bvect Right-hand side (may be several columns) 1513# uplo U if the matrix is upper triangular (default), L if the 1514# matrix is lower triangular. 1515# 1516# Result: 1517# Solution of the system or an error in case of singularity 1518# LAPACK : corresponds to DTPTRS, but in the current command, the matrix 1519# is in regular format (unpacked). 1520# 1521proc ::math::linearalgebra::solveTriangular { matrix bvect {uplo "U"}} { 1522 set norows [llength $matrix] 1523 set nocols $norows 1524 1525 switch -- $uplo { 1526 "U" { 1527 for { set i [expr {$norows-1}] } { $i >= 0 } { incr i -1 } { 1528 set sweep_row [getrow $matrix $i] 1529 set bvect_sweep [getrow $bvect $i] 1530 set sweep_fact [expr {double([lindex $sweep_row $i])}] 1531 set norm_fact [expr {1.0/$sweep_fact}] 1532 1533 lset bvect $i [scale $norm_fact $bvect_sweep] 1534 1535 for { set j [expr {$i-1}] } { $j >= 0 } { incr j -1 } { 1536 set current_row [getrow $matrix $j] 1537 set bvect_current [getrow $bvect $j] 1538 set factor [expr {-[lindex $current_row $i]/$sweep_fact}] 1539 1540 lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current] 1541 } 1542 } 1543 } 1544 "L" { 1545 for { set i 0 } { $i < $norows } { incr i } { 1546 set sweep_row [getrow $matrix $i] 1547 set bvect_sweep [getrow $bvect $i] 1548 set sweep_fact [expr {double([lindex $sweep_row $i])}] 1549 set norm_fact [expr {1.0/$sweep_fact}] 1550 1551 lset bvect $i [scale $norm_fact $bvect_sweep] 1552 1553 for { set j 0 } { $j < $i } { incr j } { 1554 set bvect_current [getrow $bvect $i] 1555 set bvect_sweep [getrow $bvect $j] 1556 set factor [lindex $sweep_row $j] 1557 set factor [expr { -1. * $factor * $norm_fact }] 1558 lset bvect $i [axpy_vect $factor $bvect_sweep $bvect_current] 1559 } 1560 } 1561 } 1562 default { 1563 error "Unknown value for parameter uplo : $uplo" 1564 } 1565 } 1566 return $bvect 1567} 1568 1569# solveGaussBand -- 1570# Solve a system of linear equations using Gauss elimination, 1571# where the matrix is stored as a band matrix. 1572# Arguments: 1573# matrix Matrix defining the coefficients (in band form) 1574# bvect Right-hand side (may be several columns) 1575# 1576# Result: 1577# Solution of the system or an error in case of singularity 1578# 1579proc ::math::linearalgebra::solveGaussBand { matrix bvect } { 1580 set norows [llength $matrix] 1581 set nocols $norows 1582 set nodiags [llength [lindex $matrix 0]] 1583 set lowdiags [expr {($nodiags-1)/2}] 1584 1585 for { set i 0 } { $i < $nocols } { incr i } { 1586 set sweep_row [getrow $matrix $i] 1587 set bvect_sweep [getrow $bvect $i] 1588 1589 set sweep_fact [lindex $sweep_row [expr {$lowdiags-$i}]] 1590 1591 for { set j [expr {$i+1}] } { $j <= $lowdiags } { incr j } { 1592 set sweep_row [concat [lrange $sweep_row 1 end] 0.0] 1593 set current_row [getrow $matrix $j] 1594 set bvect_current [getrow $bvect $j] 1595 set factor [expr {-[lindex $current_row $i]/$sweep_fact}] 1596 1597 lset matrix $j [axpy_vect $factor $sweep_row $current_row] 1598 lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current] 1599 } 1600 } 1601 1602 return [solveTriangularBand $matrix $bvect] 1603} 1604 1605# solveTriangularBand -- 1606# Solve a system of linear equations where the matrix is 1607# upper-triangular (stored as a band matrix) 1608# Arguments: 1609# matrix Matrix defining the coefficients (in band form) 1610# bvect Right-hand side (may be several columns) 1611# 1612# Result: 1613# Solution of the system or an error in case of singularity 1614# 1615proc ::math::linearalgebra::solveTriangularBand { matrix bvect } { 1616 set norows [llength $matrix] 1617 set nocols $norows 1618 set nodiags [llength [lindex $matrix 0]] 1619 set uppdiags [expr {($nodiags-1)/2}] 1620 set middle [expr {($nodiags-1)/2}] 1621 1622 for { set i [expr {$norows-1}] } { $i >= 0 } { incr i -1 } { 1623 set sweep_row [getrow $matrix $i] 1624 set bvect_sweep [getrow $bvect $i] 1625 set sweep_fact [lindex $sweep_row $middle] 1626 set norm_fact [expr {1.0/$sweep_fact}] 1627 1628 lset bvect $i [scale $norm_fact $bvect_sweep] 1629 1630 for { set j [expr {$i-1}] } { $j >= $i-$middle && $j >= 0 } \ 1631 { incr j -1 } { 1632 set current_row [getrow $matrix $j] 1633 set bvect_current [getrow $bvect $j] 1634 set k [expr {$i-$middle}] 1635 set factor [expr {-[lindex $current_row $k]/$sweep_fact}] 1636 1637 lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current] 1638 } 1639 } 1640 1641 return $bvect 1642} 1643 1644# determineSVD -- 1645# Determine the singular value decomposition of a matrix 1646# Arguments: 1647# A Matrix to be examined 1648# epsilon Tolerance for the procedure (defaults to 2.3e-16) 1649# 1650# Result: 1651# List of the three elements U, S and V, where: 1652# U, V orthogonal matrices, S a diagonal matrix (here a vector) 1653# such that A = USVt 1654# Note: 1655# This is taken directly from Hume's LA package, and adjusted 1656# to fit the different matrix format. Also changes are applied 1657# that can be found in the second edition of Nash's book 1658# "Compact numerical methods for computers" 1659# 1660# To be done: transpose the algorithm so that we can work 1661# on rows, rather than columns 1662# 1663proc ::math::linearalgebra::determineSVD { A {epsilon 2.3e-16} } { 1664 foreach {m n} [shape $A] {break} 1665 set tolerance [expr {$epsilon * $epsilon* $m * $n}] 1666 set V [mkIdentity $n] 1667 1668 # 1669 # Top of the iteration 1670 # 1671 set count 1 1672 for {set isweep 0} {$isweep < 30 && $count > 0} {incr isweep} { 1673 set count [expr {$n*($n-1)/2}] ;# count of rotations in a sweep 1674 for {set j 0} {$j < [expr {$n-1}]} {incr j} { 1675 for {set k [expr {$j+1}]} {$k < $n} {incr k} { 1676 set p [set q [set r 0.0]] 1677 for {set i 0} {$i < $m} {incr i} { 1678 set Aij [lindex $A $i $j] 1679 set Aik [lindex $A $i $k] 1680 set p [expr {$p + $Aij*$Aik}] 1681 set q [expr {$q + $Aij*$Aij}] 1682 set r [expr {$r + $Aik*$Aik}] 1683 } 1684 if { $q < $r } { 1685 set c 0.0 1686 set s 1.0 1687 } elseif { $q * $r == 0.0 } { 1688 # Underflow of small elements 1689 incr count -1 1690 continue 1691 } elseif { ($p*$p)/($q*$r) < $tolerance } { 1692 # Cols j,k are orthogonal 1693 incr count -1 1694 continue 1695 } else { 1696 set q [expr {$q-$r}] 1697 set v [expr {sqrt(4.0*$p*$p + $q*$q)}] 1698 set c [expr {sqrt(($v+$q)/(2.0*$v))}] 1699 set s [expr {-$p/($v*$c)}] 1700 # s == sine of rotation angle, c == cosine 1701 # Note: -s in comparison with original LA! 1702 } 1703 # 1704 # Rotation of A 1705 # 1706 set colj [getcol $A $j] 1707 set colk [getcol $A $k] 1708 foreach {colj colk} [rotate $c $s $colj $colk] {break} 1709 setcol A $j $colj 1710 setcol A $k $colk 1711 # 1712 # Rotation of V 1713 # 1714 set colj [getcol $V $j] 1715 set colk [getcol $V $k] 1716 foreach {colj colk} [rotate $c $s $colj $colk] {break} 1717 setcol V $j $colj 1718 setcol V $k $colk 1719 } ;#k 1720 } ;# j 1721 #puts "pass=$isweep skipped rotations=$count" 1722 } ;# isweep 1723 1724 set S {} 1725 for {set j 0} {$j < $n} {incr j} { 1726 set q [norm_two [getcol $A $j]] 1727 lappend S $q 1728 if { $q >= $tolerance } { 1729 set newcol [scale [expr {1.0/$q}] [getcol $A $j]] 1730 setcol A $j $newcol 1731 } 1732 } ;# j 1733 1734 # 1735 # Prepare the output 1736 # 1737 set U $A 1738 1739 if { $m < $n } { 1740 set U {} 1741 incr m -1 1742 foreach row $A { 1743 lappend U [lrange $row 0 $m] 1744 } 1745 puts $U 1746 } 1747 return [list $U $S $V] 1748} 1749 1750# eigenvectorsSVD -- 1751# Determine the eigenvectors and eigenvalues of a real 1752# symmetric matrix via the SVD 1753# Arguments: 1754# A Matrix to be examined 1755# eps Tolerance for the procedure (defaults to 2.3e-16) 1756# 1757# Result: 1758# List of the matrix of eigenvectors and the vector of corresponding 1759# eigenvalues 1760# Note: 1761# This is taken directly from Hume's LA package, and adjusted 1762# to fit the different matrix format. Also changes are applied 1763# that can be found in the second edition of Nash's book 1764# "Compact numerical methods for computers" 1765# 1766proc ::math::linearalgebra::eigenvectorsSVD { A {eps 2.3e-16} } { 1767 foreach {m n} [shape $A] {break} 1768 if { $m != $n } { 1769 return -code error "Expected a square matrix" 1770 } 1771 1772 # 1773 # Determine the shift h so that the matrix A+hI is positive 1774 # definite (the Gershgorin region) 1775 # 1776 set h {} 1777 set i 0 1778 foreach row $A { 1779 set aii [lindex $row $i] 1780 set sum [expr {2.0*abs($aii) - [norm_one $row]}] 1781 incr i 1782 1783 if { $h == {} || $sum < $h } { 1784 set h $sum 1785 } 1786 } 1787 if { $h <= $eps } { 1788 set h [expr {$h - sqrt($eps)}] 1789 # try to make smallest eigenvalue positive and not too small 1790 set A [sub $A [scale_mat $h [mkIdentity $m]]] 1791 } else { 1792 set h 0.0 1793 } 1794 1795 # 1796 # Determine the SVD decomposition: this holds the 1797 # eigenvectors and eigenvalues 1798 # 1799 foreach {U S V} [determineSVD $A $eps] {break} 1800 1801 # 1802 # Rescale and flip signs if all negative or zero 1803 # 1804 for {set j 0} {$j < $n} {incr j} { 1805 set s 0.0 1806 set notpositive 0 1807 for {set i 0} {$i < $n} {incr i} { 1808 set Uij [lindex $U $i $j] 1809 if { $Uij <= 0.0 } { 1810 incr notpositive 1811 } 1812 set s [expr {$s + $Uij*$Uij}] 1813 } 1814 set s [expr {sqrt($s)}] 1815 if { $notpositive == $n } { 1816 set sf [expr {-$s}] 1817 } else { 1818 set sf $s 1819 } 1820 set colv [getcol $U $j] 1821 setcol U $j [scale_vect [expr {1.0/$sf}] $colv] 1822 } 1823 for {set j 0} {$j < $n} {incr j} { 1824 lset S $j [expr {[lindex $S $j] + $h}] 1825 } 1826 return [list $U $S] 1827} 1828 1829# leastSquaresSVD -- 1830# Determine the solution to the least-squares problem Ax ~ y 1831# via the singular value decomposition 1832# Arguments: 1833# A Matrix to be examined 1834# y Dependent variable 1835# qmin Minimum singular value to be considered (defaults to 0) 1836# epsilon Tolerance for the procedure (defaults to 2.3e-16) 1837# 1838# Result: 1839# Vector x as the solution of the least-squares problem 1840# 1841proc ::math::linearalgebra::leastSquaresSVD { A y {qmin 0.0} {epsilon 2.3e-16} } { 1842 1843 foreach {m n} [shape $A] {break} 1844 foreach {U S V} [determineSVD $A $epsilon] {break} 1845 1846 set tol [expr {$epsilon * $epsilon * $n * $n}] 1847 # 1848 # form Utrans*y into g 1849 # 1850 set g {} 1851 for {set j 0} {$j < $n} {incr j} { 1852 set s 0.0 1853 for {set i 0} {$i < $m} {incr i} { 1854 set Uij [lindex $U $i $j] 1855 set yi [lindex $y $i] 1856 set s [expr {$s + $Uij*$yi}] 1857 } 1858 lappend g $s ;# g[j] = $s 1859 } 1860 1861 # 1862 # form VS+g = VS+Utrans*g 1863 # 1864 set x {} 1865 for {set j 0} {$j < $n} {incr j} { 1866 set s 0.0 1867 for {set i 0} {$i < $n} {incr i} { 1868 set zi [lindex $S $i] 1869 if { $zi > $qmin } { 1870 set Vji [lindex $V $j $i] 1871 set gi [lindex $g $i] 1872 set s [expr {$s + $Vji*$gi/$zi}] 1873 } 1874 } 1875 lappend x $s 1876 } 1877 return $x 1878} 1879 1880# choleski -- 1881# Determine the Choleski decomposition of a symmetric, 1882# positive-semidefinite matrix (this condition is not checked!) 1883# 1884# Arguments: 1885# matrix Matrix to be treated 1886# 1887# Result: 1888# Lower-triangular matrix (L) representing the Choleski decomposition: 1889# L Lt = matrix 1890# 1891proc ::math::linearalgebra::choleski { matrix } { 1892 foreach {rows cols} [shape $matrix] {break} 1893 1894 set result $matrix 1895 1896 for { set j 0 } { $j < $cols } { incr j } { 1897 if { $j > 0 } { 1898 for { set i $j } { $i < $cols } { incr i } { 1899 set sum [lindex $result $i $j] 1900 for { set k 0 } { $k <= $j-1 } { incr k } { 1901 set Aki [lindex $result $i $k] 1902 set Akj [lindex $result $j $k] 1903 set sum [expr {$sum-$Aki*$Akj}] 1904 } 1905 lset result $i $j $sum 1906 } 1907 } 1908 1909 # 1910 # Take care of a singular matrix 1911 # 1912 if { [lindex $result $j $j] <= 0.0 } { 1913 lset result $j $j 0.0 1914 } 1915 1916 # 1917 # Scale the column 1918 # 1919 set s [expr {sqrt([lindex $result $j $j])}] 1920 for { set i 0 } { $i < $cols } { incr i } { 1921 if { $i >= $j } { 1922 if { $s == 0.0 } { 1923 lset result $i $j 0.0 1924 } else { 1925 lset result $i $j [expr {[lindex $result $i $j]/$s}] 1926 } 1927 } else { 1928 lset result $i $j 0.0 1929 } 1930 } 1931 } 1932 1933 return $result 1934} 1935 1936# orthonormalizeColumns -- 1937# Orthonormalize the columns of a matrix, using the modified 1938# Gram-Schmidt method 1939# Arguments: 1940# matrix Matrix to be treated 1941# 1942# Result: 1943# Matrix with pairwise orthogonal columns, each having length 1 1944# 1945proc ::math::linearalgebra::orthonormalizeColumns { matrix } { 1946 transpose [orthonormalizeRows [transpose $matrix]] 1947} 1948 1949# orthonormalizeRows -- 1950# Orthonormalize the rows of a matrix, using the modified 1951# Gram-Schmidt method 1952# Arguments: 1953# matrix Matrix to be treated 1954# 1955# Result: 1956# Matrix with pairwise orthogonal rows, each having length 1 1957# 1958proc ::math::linearalgebra::orthonormalizeRows { matrix } { 1959 set result $matrix 1960 set rowno 0 1961 foreach r $matrix { 1962 set newrow [unitLengthVector [getrow $result $rowno]] 1963 setrow result $rowno $newrow 1964 incr rowno 1965 set rowno2 $rowno 1966 1967 # 1968 # Update the matrix immediately: this is numerically 1969 # more stable 1970 # 1971 foreach nextrow [lrange $result $rowno end] { 1972 set factor [dotproduct $newrow $nextrow] 1973 set nextrow [sub_vect $nextrow [scale_vect $factor $newrow]] 1974 setrow result $rowno2 $nextrow 1975 incr rowno2 1976 } 1977 } 1978 return $result 1979} 1980 1981# dger -- 1982# Performs the rank 1 operation alpha*x*y' + A 1983# Arguments: 1984# matrix name of the matrix to process (the matrix must be square) 1985# alpha a real value 1986# x a vector 1987# y a vector 1988# scope if not provided, the operation is performed on all rows/columns of A 1989# if provided, it is expected to be the list [list imin imax jmin jmax] 1990# where : 1991# imin Minimum row index 1992# imax Maximum row index 1993# jmin Minimum column index 1994# jmax Maximum column index 1995# 1996# Result: 1997# Updated matrix 1998# Level-3 BLAS : corresponds to DGER 1999# 2000proc ::math::linearalgebra::dger { matrix alpha x y {scope ""}} { 2001 upvar $matrix mat 2002 set nrows [llength $mat] 2003 set ncols $nrows 2004 if {$scope==""} then { 2005 set imin 0 2006 set imax [expr {$nrows - 1}] 2007 set jmin 0 2008 set jmax [expr {$ncols - 1}] 2009 } else { 2010 foreach {imin imax jmin jmax} $scope {break} 2011 } 2012 set xy [matmul $x $y] 2013 set alphaxy [scale $alpha $xy] 2014 for { set iline $imin } { $iline <= $imax } { incr iline } { 2015 set ilineshift [expr {$iline - $imin}] 2016 set matiline [lindex $mat $iline] 2017 set alphailine [lindex $alphaxy $ilineshift] 2018 for { set icol $jmin } { $icol <= $jmax } { incr icol } { 2019 set icolshift [expr {$icol - $jmin}] 2020 set aij [lindex $matiline $icol] 2021 set shift [lindex $alphailine $icolshift] 2022 setelem mat $iline $icol [expr {$aij + $shift}] 2023 } 2024 } 2025 return $mat 2026} 2027# dgetrf -- 2028# Computes an LU factorization of a general matrix, using partial, 2029# pivoting with row interchanges. 2030# 2031# Arguments: 2032# matrix On entry, the matrix to be factored. 2033# On exit, the factors L and U from the factorization 2034# P*A = L*U; the unit diagonal elements of L are not stored. 2035# 2036# Result: 2037# Returns the permutation vector, as a list of length n-1. 2038# The last entry of the permutation is not stored, since it is 2039# implicitely known, with value n (the last row is not swapped 2040# with any other row). 2041# At index #i of the permutation is stored the index of the row #j 2042# which is swapped with row #i at step #i. That means that each 2043# index of the permutation gives the permutation at each step, not the 2044# cumulated permutation matrix, which is the product of permutations. 2045# The factorization has the form 2046# P * A = L * U 2047# where P is a permutation matrix, L is lower triangular with unit 2048# diagonal elements, and U is upper triangular. 2049# 2050# LAPACK : corresponds to DGETRF 2051# 2052proc ::math::linearalgebra::dgetrf { matrix } { 2053 upvar $matrix mat 2054 set norows [llength $mat] 2055 set nocols $norows 2056 2057 # Initialize permutation 2058 set nm1 [expr {$norows - 1}] 2059 set ipiv {} 2060 # Perform Gauss transforms 2061 for { set k 0 } { $k < $nm1 } { incr k } { 2062 # Search pivot in column n, from lines k to n 2063 set column [getcol $mat $k $k $nm1] 2064 foreach {abspivot murel} [norm_max $column 1] {break} 2065 # Shift mu, because max returns with respect to the column (k:n,k) 2066 set mu [expr {$murel + $k}] 2067 # Swap lines k and mu from columns 1 to n 2068 swaprows mat $k $mu 2069 set akk [lindex $mat $k $k] 2070 # Store permutation 2071 lappend ipiv $mu 2072 # Store pivots for lines k+1 to n in columns k+1 to n 2073 set kp1 [expr {$k+1}] 2074 set akp1 [getcol $mat $k $kp1 $nm1] 2075 set mult [expr {1. / double($akk)}] 2076 set akp1 [scale $mult $akp1] 2077 setcol mat $k $akp1 $kp1 $nm1 2078 # Perform transform for lines k+1 to n 2079 set akp1k [getcol $mat $k $kp1 $nm1] 2080 set akkp1 [lrange [lindex $mat $k] $kp1 $nm1] 2081 set scope [list $kp1 $nm1 $kp1 $nm1] 2082 dger mat -1. $akp1k $akkp1 $scope 2083 } 2084 return $ipiv 2085} 2086 2087# det -- 2088# Returns the determinant of the given matrix, based on PA=LU 2089# decomposition (i.e. dgetrf). 2090# 2091# Arguments: 2092# matrix The matrix values. 2093# ipiv The pivots (optionnal). 2094# If the pivots are not provided, a PA=LU decomposition 2095# is performed. 2096# If the pivots are provided, we assume that it 2097# contains the pivots and that the matrix A contains the 2098# L and U factors, as provided by dgterf. 2099# 2100# Result: 2101# Returns the determinant 2102# 2103proc ::math::linearalgebra::det { matrix {ipiv ""}} { 2104 if { $ipiv == "" } then { 2105 set ipiv [dgetrf matrix] 2106 } 2107 set det 1.0 2108 set norows [llength $matrix] 2109 set i 0 2110 foreach row $matrix { 2111 set uu [lindex $row $i] 2112 set det [expr {$det * $uu}] 2113 if { $i < $norows - 1 } then { 2114 set ii [lindex $ipiv $i] 2115 if { $ii!=$i } then { 2116 set det [expr {-1.0 * $det}] 2117 } 2118 } 2119 incr i 2120 } 2121 return $det 2122} 2123 2124# largesteigen -- 2125# Returns a list made of the largest eigenvalue (in magnitude) 2126# and associated eigenvector. 2127# Uses Power Method. 2128# 2129# Arguments: 2130# matrix The matrix values. 2131# tolerance The relative tolerance of the eigenvalue. 2132# maxiter The maximum number of iterations 2133# 2134# Result: 2135# Returns a list of two items, where the first item 2136# is the eigenvalue and the second is the eigenvector. 2137# Note 2138# This is algorithm #7.3.3 of Golub & Van Loan. 2139# 2140proc ::math::linearalgebra::largesteigen { matrix {tolerance 1.e-8} {maxiter 10}} { 2141 set norows [llength $matrix] 2142 set q [mkVector $norows 1.0] 2143 set lambda 1.0 2144 for { set k 0 } { $k < $maxiter } { incr k } { 2145 set z [matmul $matrix $q] 2146 set zn [norm $z] 2147 if { $zn == 0.0 } then { 2148 return -code error "Cannot continue power method : matrix is singular" 2149 } 2150 set s [expr {1.0 / $zn}] 2151 set q [scale $s $z] 2152 set prod [matmul $matrix $q] 2153 set lambda_old $lambda 2154 set lambda [dotproduct $q $prod] 2155 if { abs($lambda - $lambda_old) < $tolerance * abs($lambda_old) } then { 2156 break 2157 } 2158 } 2159 return [list $lambda $q] 2160} 2161 2162# to_LA -- 2163# Convert a matrix or vector to the LA format 2164# Arguments: 2165# mv Matrix or vector to be converted 2166# 2167# Result: 2168# List according to LA conventions 2169# 2170proc ::math::linearalgebra::to_LA { mv } { 2171 foreach {rows cols} [shape $mv] { 2172 if { $cols == {} } { 2173 set cols 0 2174 } 2175 } 2176 2177 set result [list 2 $rows $cols] 2178 foreach row $mv { 2179 set result [concat $result $row] 2180 } 2181 return $result 2182} 2183 2184# from_LA -- 2185# Convert a matrix or vector from the LA format 2186# Arguments: 2187# mv Matrix or vector to be converted 2188# 2189# Result: 2190# List according to current conventions 2191# 2192proc ::math::linearalgebra::from_LA { mv } { 2193 foreach {rows cols} [lrange $mv 1 2] {break} 2194 2195 if { $cols != 0 } { 2196 set result {} 2197 set elem2 2 2198 for { set i 0 } { $i < $rows } { incr i } { 2199 set elem1 [expr {$elem2+1}] 2200 incr elem2 $cols 2201 lappend result [lrange $mv $elem1 $elem2] 2202 } 2203 } else { 2204 set result [lrange $mv 3 end] 2205 } 2206 2207 return $result 2208} 2209 2210# 2211# Announce the package's presence 2212# 2213package provide math::linearalgebra 1.1.4 2214 2215if { 0 } { 2216Te doen: 2217behoorlijke testen! 2218matmul 2219solveGauss_band 2220join_col, join_row 2221kleinste-kwadraten met SVD en met Gauss 2222PCA 2223} 2224 2225if { 0 } { 2226 set matrix {{1.0 2.0 -1.0} 2227 {3.0 1.1 0.5} 2228 {1.0 -2.0 3.0}} 2229 set bvect {{1.0 2.0 -1.0} 2230 {3.0 1.1 0.5} 2231 {1.0 -2.0 3.0}} 2232 puts [join [::math::linearalgebra::solveGauss $matrix $bvect] \n] 2233 set bvect {{4.0 2.0} 2234 {12.0 1.2} 2235 {4.0 -2.0}} 2236 puts [join [::math::linearalgebra::solveGauss $matrix $bvect] \n] 2237} 2238 2239if { 0 } { 2240 2241 set vect1 {1.0 2.0} 2242 set vect2 {3.0 4.0} 2243 ::math::linearalgebra::axpy_vect 1.0 $vect1 $vect2 2244 ::math::linearalgebra::add_vect $vect1 $vect2 2245 puts [time {::math::linearalgebra::axpy_vect 1.0 $vect1 $vect2} 50000] 2246 puts [time {::math::linearalgebra::axpy_vect 2.0 $vect1 $vect2} 50000] 2247 puts [time {::math::linearalgebra::axpy_vect 1.0 $vect1 $vect2} 50000] 2248 puts [time {::math::linearalgebra::axpy_vect 1.1 $vect1 $vect2} 50000] 2249 puts [time {::math::linearalgebra::add_vect $vect1 $vect2} 50000] 2250} 2251 2252if { 0 } { 2253 set M {{1 2} {2 1}} 2254 puts "[::math::linearalgebra::determineSVD $M]" 2255} 2256if { 0 } { 2257 set M {{1 2} {2 1}} 2258 puts "[::math::linearalgebra::normMatrix $M]" 2259} 2260if { 0 } { 2261 set M {{1.3 2.3} {2.123 1}} 2262 puts "[::math::linearalgebra::show $M]" 2263 set M {{1.3 2.3 45 3.} {2.123 1 5.6 0.01}} 2264 puts "[::math::linearalgebra::show $M]" 2265 puts "[::math::linearalgebra::show $M %12.4f]" 2266} 2267if { 0 } { 2268 set M {{1 0 0} 2269 {1 1 0} 2270 {1 1 1}} 2271 puts [::math::linearalgebra::orthonormalizeRows $M] 2272} 2273if { 0 } { 2274 set M [::math::linearalgebra::mkMoler 5] 2275 puts [::math::linearalgebra::choleski $M] 2276} 2277if { 0 } { 2278 set M [::math::linearalgebra::mkRandom 20] 2279 set b [::math::linearalgebra::mkVector 20] 2280 puts "Gauss A = LU" 2281 puts [time {::math::linearalgebra::solveGauss $M $b} 5] 2282 puts "Gauss PA = LU" 2283 puts [time {::math::linearalgebra::solvePGauss $M $b} 5] 2284 # Gauss A = LU 2285 # 7607.4 microseconds per iteration 2286 # Gauss PA = LU 2287 # 17428.4 microseconds per iteration 2288} 2289