github.com/gonum/lapack@v0.0.0-20181123203213-e4cdc5a0bff9/native/dbdsqr.go

// Copyright ©2015 The gonum Authors. All rights reserved.
// Use of this source code is governed by a BSD-style
// license that can be found in the LICENSE file.

package native

import (
	"math"

	"github.com/gonum/blas"
	"github.com/gonum/blas/blas64"
	"github.com/gonum/lapack"
)

// Dbdsqr performs a singular value decomposition of a real n×n bidiagonal matrix.
//
// The SVD of the bidiagonal matrix B is
//  B = Q * S * P^T
// where S is a diagonal matrix of singular values, Q is an orthogonal matrix of
// left singular vectors, and P is an orthogonal matrix of right singular vectors.
//
// Q and P are only computed if requested. If left singular vectors are requested,
// this routine returns U * Q instead of Q, and if right singular vectors are
// requested P^T * VT is returned instead of P^T.
//
// Frequently Dbdsqr is used in conjunction with Dgebrd which reduces a general
// matrix A into bidiagonal form. In this case, the SVD of A is
//  A = (U * Q) * S * (P^T * VT)
//
// This routine may also compute Q^T * C.
//
// d and e contain the elements of the bidiagonal matrix b. d must have length at
// least n, and e must have length at least n-1. Dbdsqr will panic if there is
// insufficient length. On exit, D contains the singular values of B in decreasing
// order.
//
// VT is a matrix of size n×ncvt whose elements are stored in vt. The elements
// of vt are modified to contain P^T * VT on exit. VT is not used if ncvt == 0.
//
// U is a matrix of size nru×n whose elements are stored in u. The elements
// of u are modified to contain U * Q on exit. U is not used if nru == 0.
//
// C is a matrix of size n×ncc whose elements are stored in c. The elements
// of c are modified to contain Q^T * C on exit. C is not used if ncc == 0.
//
// work contains temporary storage and must have length at least 4*n. Dbdsqr
// will panic if there is insufficient working memory.
//
// Dbdsqr returns whether the decomposition was successful.
//
// Dbdsqr is an internal routine. It is exported for testing purposes.
func (impl Implementation) Dbdsqr(uplo blas.Uplo, n, ncvt, nru, ncc int, d, e, vt []float64, ldvt int, u []float64, ldu int, c []float64, ldc int, work []float64) (ok bool) {
	if uplo != blas.Upper && uplo != blas.Lower {
		panic(badUplo)
	}
	if ncvt != 0 {
		checkMatrix(n, ncvt, vt, ldvt)
	}
	if nru != 0 {
		checkMatrix(nru, n, u, ldu)
	}
	if ncc != 0 {
		checkMatrix(n, ncc, c, ldc)
	}
	if len(d) < n {
		panic(badD)
	}
	if len(e) < n-1 {
		panic(badE)
	}
	if len(work) < 4*n {
		panic(badWork)
	}
	var info int
	bi := blas64.Implementation()
	const (
		maxIter = 6
	)
	if n == 0 {
		return true
	}
	if n != 1 {
		// If the singular vectors do not need to be computed, use qd algorithm.
		if !(ncvt > 0 || nru > 0 || ncc > 0) {
			info = impl.Dlasq1(n, d, e, work)
			// If info is 2 dqds didn't finish, and so try to.
			if info != 2 {
				return info == 0
			}
			info = 0
		}
		nm1 := n - 1
		nm12 := nm1 + nm1
		nm13 := nm12 + nm1
		idir := 0

		eps := dlamchE
		unfl := dlamchS
		lower := uplo == blas.Lower
		var cs, sn, r float64
		if lower {
			for i := 0; i < n-1; i++ {
				cs, sn, r = impl.Dlartg(d[i], e[i])
				d[i] = r
				e[i] = sn * d[i+1]
				d[i+1] *= cs
				work[i] = cs
				work[nm1+i] = sn
			}
			if nru > 0 {
				impl.Dlasr(blas.Right, lapack.Variable, lapack.Forward, nru, n, work, work[n-1:], u, ldu)
			}
			if ncc > 0 {
				impl.Dlasr(blas.Left, lapack.Variable, lapack.Forward, n, ncc, work, work[n-1:], c, ldc)
			}
		}
		// Compute singular values to a relative accuracy of tol. If tol is negative
		// the values will be computed to an absolute accuracy of math.Abs(tol) * norm(b)
		tolmul := math.Max(10, math.Min(100, math.Pow(eps, -1.0/8)))
		tol := tolmul * eps
		var smax float64
		for i := 0; i < n; i++ {
			smax = math.Max(smax, math.Abs(d[i]))
		}
		for i := 0; i < n-1; i++ {
			smax = math.Max(smax, math.Abs(e[i]))
		}

		var sminl float64
		var thresh float64
		if tol >= 0 {
			sminoa := math.Abs(d[0])
			if sminoa != 0 {
				mu := sminoa
				for i := 1; i < n; i++ {
					mu = math.Abs(d[i]) * (mu / (mu + math.Abs(e[i-1])))
					sminoa = math.Min(sminoa, mu)
					if sminoa == 0 {
						break
					}
				}
			}
			sminoa = sminoa / math.Sqrt(float64(n))
			thresh = math.Max(tol*sminoa, float64(maxIter*n*n)*unfl)
		} else {
			thresh = math.Max(math.Abs(tol)*smax, float64(maxIter*n*n)*unfl)
		}
		// Prepare for the main iteration loop for the singular values.
		maxIt := maxIter * n * n
		iter := 0
		oldl2 := -1
		oldm := -1
		// m points to the last element of unconverged part of matrix.
		m := n

	Outer:
		for m > 1 {
			if iter > maxIt {
				info = 0
				for i := 0; i < n-1; i++ {
					if e[i] != 0 {
						info++
					}
				}
				return info == 0
			}
			// Find diagonal block of matrix to work on.
			if tol < 0 && math.Abs(d[m-1]) <= thresh {
				d[m-1] = 0
			}
			smax = math.Abs(d[m-1])
			smin := smax
			var l2 int
			var broke bool
			for l3 := 0; l3 < m-1; l3++ {
				l2 = m - l3 - 2
				abss := math.Abs(d[l2])
				abse := math.Abs(e[l2])
				if tol < 0 && abss <= thresh {
					d[l2] = 0
				}
				if abse <= thresh {
					broke = true
					break
				}
				smin = math.Min(smin, abss)
				smax = math.Max(math.Max(smax, abss), abse)
			}
			if broke {
				e[l2] = 0
				if l2 == m-2 {
					// Convergence of bottom singular value, return to top.
					m--
					continue
				}
				l2++
			} else {
				l2 = 0
			}
			// e[ll] through e[m-2] are nonzero, e[ll-1] is zero
			if l2 == m-2 {
				// Handle 2×2 block separately.
				var sinr, cosr, sinl, cosl float64
				d[m-1], d[m-2], sinr, cosr, sinl, cosl = impl.Dlasv2(d[m-2], e[m-2], d[m-1])
				e[m-2] = 0
				if ncvt > 0 {
					bi.Drot(ncvt, vt[(m-2)*ldvt:], 1, vt[(m-1)*ldvt:], 1, cosr, sinr)
				}
				if nru > 0 {
					bi.Drot(nru, u[m-2:], ldu, u[m-1:], ldu, cosl, sinl)
				}
				if ncc > 0 {
					bi.Drot(ncc, c[(m-2)*ldc:], 1, c[(m-1)*ldc:], 1, cosl, sinl)
				}
				m -= 2
				continue
			}
			// If working on a new submatrix, choose shift direction from larger end
			// diagonal element toward smaller.
			if l2 > oldm-1 || m-1 < oldl2 {
				if math.Abs(d[l2]) >= math.Abs(d[m-1]) {
					idir = 1
				} else {
					idir = 2
				}
			}
			// Apply convergence tests.
			// TODO(btracey): There is a lot of similar looking code here. See
			// if there is a better way to de-duplicate.
			if idir == 1 {
				// Run convergence test in forward direction.
				// First apply standard test to bottom of matrix.
				if math.Abs(e[m-2]) <= math.Abs(tol)*math.Abs(d[m-1]) || (tol < 0 && math.Abs(e[m-2]) <= thresh) {
					e[m-2] = 0
					continue
				}
				if tol >= 0 {
					// If relative accuracy desired, apply convergence criterion forward.
					mu := math.Abs(d[l2])
					sminl = mu
					for l3 := l2; l3 < m-1; l3++ {
						if math.Abs(e[l3]) <= tol*mu {
							e[l3] = 0
							continue Outer
						}
						mu = math.Abs(d[l3+1]) * (mu / (mu + math.Abs(e[l3])))
						sminl = math.Min(sminl, mu)
					}
				}
			} else {
				// Run convergence test in backward direction.
				// First apply standard test to top of matrix.
				if math.Abs(e[l2]) <= math.Abs(tol)*math.Abs(d[l2]) || (tol < 0 && math.Abs(e[l2]) <= thresh) {
					e[l2] = 0
					continue
				}
				if tol >= 0 {
					// If relative accuracy desired, apply convergence criterion backward.
					mu := math.Abs(d[m-1])
					sminl = mu
					for l3 := m - 2; l3 >= l2; l3-- {
						if math.Abs(e[l3]) <= tol*mu {
							e[l3] = 0
							continue Outer
						}
						mu = math.Abs(d[l3]) * (mu / (mu + math.Abs(e[l3])))
						sminl = math.Min(sminl, mu)
					}
				}
			}
			oldl2 = l2
			oldm = m
			// Compute shift. First, test if shifting would ruin relative accuracy,
			// and if so set the shift to zero.
			var shift float64
			if tol >= 0 && float64(n)*tol*(sminl/smax) <= math.Max(eps, (1.0/100)*tol) {
				shift = 0
			} else {
				var sl2 float64
				if idir == 1 {
					sl2 = math.Abs(d[l2])
					shift, _ = impl.Dlas2(d[m-2], e[m-2], d[m-1])
				} else {
					sl2 = math.Abs(d[m-1])
					shift, _ = impl.Dlas2(d[l2], e[l2], d[l2+1])
				}
				// Test if shift is negligible
				if sl2 > 0 {
					if (shift/sl2)*(shift/sl2) < eps {
						shift = 0
					}
				}
			}
			iter += m - l2 + 1
			// If no shift, do simplified QR iteration.
			if shift == 0 {
				if idir == 1 {
					cs := 1.0
					oldcs := 1.0
					var sn, r, oldsn float64
					for i := l2; i < m-1; i++ {
						cs, sn, r = impl.Dlartg(d[i]*cs, e[i])
						if i > l2 {
							e[i-1] = oldsn * r
						}
						oldcs, oldsn, d[i] = impl.Dlartg(oldcs*r, d[i+1]*sn)
						work[i-l2] = cs
						work[i-l2+nm1] = sn
						work[i-l2+nm12] = oldcs
						work[i-l2+nm13] = oldsn
					}
					h := d[m-1] * cs
					d[m-1] = h * oldcs
					e[m-2] = h * oldsn
					if ncvt > 0 {
						impl.Dlasr(blas.Left, lapack.Variable, lapack.Forward, m-l2, ncvt, work, work[n-1:], vt[l2*ldvt:], ldvt)
					}
					if nru > 0 {
						impl.Dlasr(blas.Right, lapack.Variable, lapack.Forward, nru, m-l2, work[nm12:], work[nm13:], u[l2:], ldu)
					}
					if ncc > 0 {
						impl.Dlasr(blas.Left, lapack.Variable, lapack.Forward, m-l2, ncc, work[nm12:], work[nm13:], c[l2*ldc:], ldc)
					}
					if math.Abs(e[m-2]) < thresh {
						e[m-2] = 0
					}
				} else {
					cs := 1.0
					oldcs := 1.0
					var sn, r, oldsn float64
					for i := m - 1; i >= l2+1; i-- {
						cs, sn, r = impl.Dlartg(d[i]*cs, e[i-1])
						if i < m-1 {
							e[i] = oldsn * r
						}
						oldcs, oldsn, d[i] = impl.Dlartg(oldcs*r, d[i-1]*sn)
						work[i-l2-1] = cs
						work[i-l2+nm1-1] = -sn
						work[i-l2+nm12-1] = oldcs
						work[i-l2+nm13-1] = -oldsn
					}
					h := d[l2] * cs
					d[l2] = h * oldcs
					e[l2] = h * oldsn
					if ncvt > 0 {
						impl.Dlasr(blas.Left, lapack.Variable, lapack.Backward, m-l2, ncvt, work[nm12:], work[nm13:], vt[l2*ldvt:], ldvt)
					}
					if nru > 0 {
						impl.Dlasr(blas.Right, lapack.Variable, lapack.Backward, nru, m-l2, work, work[n-1:], u[l2:], ldu)
					}
					if ncc > 0 {
						impl.Dlasr(blas.Left, lapack.Variable, lapack.Backward, m-l2, ncc, work, work[n-1:], c[l2*ldc:], ldc)
					}
					if math.Abs(e[l2]) <= thresh {
						e[l2] = 0
					}
				}
			} else {
				// Use nonzero shift.
				if idir == 1 {
					// Chase bulge from top to bottom. Save cosines and sines for
					// later singular vector updates.
					f := (math.Abs(d[l2]) - shift) * (math.Copysign(1, d[l2]) + shift/d[l2])
					g := e[l2]
					var cosl, sinl float64
					for i := l2; i < m-1; i++ {
						cosr, sinr, r := impl.Dlartg(f, g)
						if i > l2 {
							e[i-1] = r
						}
						f = cosr*d[i] + sinr*e[i]
						e[i] = cosr*e[i] - sinr*d[i]
						g = sinr * d[i+1]
						d[i+1] *= cosr
						cosl, sinl, r = impl.Dlartg(f, g)
						d[i] = r
						f = cosl*e[i] + sinl*d[i+1]
						d[i+1] = cosl*d[i+1] - sinl*e[i]
						if i < m-2 {
							g = sinl * e[i+1]
							e[i+1] = cosl * e[i+1]
						}
						work[i-l2] = cosr
						work[i-l2+nm1] = sinr
						work[i-l2+nm12] = cosl
						work[i-l2+nm13] = sinl
					}
					e[m-2] = f
					if ncvt > 0 {
						impl.Dlasr(blas.Left, lapack.Variable, lapack.Forward, m-l2, ncvt, work, work[n-1:], vt[l2*ldvt:], ldvt)
					}
					if nru > 0 {
						impl.Dlasr(blas.Right, lapack.Variable, lapack.Forward, nru, m-l2, work[nm12:], work[nm13:], u[l2:], ldu)
					}
					if ncc > 0 {
						impl.Dlasr(blas.Left, lapack.Variable, lapack.Forward, m-l2, ncc, work[nm12:], work[nm13:], c[l2*ldc:], ldc)
					}
					if math.Abs(e[m-2]) <= thresh {
						e[m-2] = 0
					}
				} else {
					// Chase bulge from top to bottom. Save cosines and sines for
					// later singular vector updates.
					f := (math.Abs(d[m-1]) - shift) * (math.Copysign(1, d[m-1]) + shift/d[m-1])
					g := e[m-2]
					for i := m - 1; i > l2; i-- {
						cosr, sinr, r := impl.Dlartg(f, g)
						if i < m-1 {
							e[i] = r
						}
						f = cosr*d[i] + sinr*e[i-1]
						e[i-1] = cosr*e[i-1] - sinr*d[i]
						g = sinr * d[i-1]
						d[i-1] *= cosr
						cosl, sinl, r := impl.Dlartg(f, g)
						d[i] = r
						f = cosl*e[i-1] + sinl*d[i-1]
						d[i-1] = cosl*d[i-1] - sinl*e[i-1]
						if i > l2+1 {
							g = sinl * e[i-2]
							e[i-2] *= cosl
						}
						work[i-l2-1] = cosr
						work[i-l2+nm1-1] = -sinr
						work[i-l2+nm12-1] = cosl
						work[i-l2+nm13-1] = -sinl
					}
					e[l2] = f
					if math.Abs(e[l2]) <= thresh {
						e[l2] = 0
					}
					if ncvt > 0 {
						impl.Dlasr(blas.Left, lapack.Variable, lapack.Backward, m-l2, ncvt, work[nm12:], work[nm13:], vt[l2*ldvt:], ldvt)
					}
					if nru > 0 {
						impl.Dlasr(blas.Right, lapack.Variable, lapack.Backward, nru, m-l2, work, work[n-1:], u[l2:], ldu)
					}
					if ncc > 0 {
						impl.Dlasr(blas.Left, lapack.Variable, lapack.Backward, m-l2, ncc, work, work[n-1:], c[l2*ldc:], ldc)
					}
				}
			}
		}
	}

	// All singular values converged, make them positive.
	for i := 0; i < n; i++ {
		if d[i] < 0 {
			d[i] *= -1
			if ncvt > 0 {
				bi.Dscal(ncvt, -1, vt[i*ldvt:], 1)
			}
		}
	}

	// Sort the singular values in decreasing order.
	for i := 0; i < n-1; i++ {
		isub := 0
		smin := d[0]
		for j := 1; j < n-i; j++ {
			if d[j] <= smin {
				isub = j
				smin = d[j]
			}
		}
		if isub != n-i {
			// Swap singular values and vectors.
			d[isub] = d[n-i-1]
			d[n-i-1] = smin
			if ncvt > 0 {
				bi.Dswap(ncvt, vt[isub*ldvt:], 1, vt[(n-i-1)*ldvt:], 1)
			}
			if nru > 0 {
				bi.Dswap(nru, u[isub:], ldu, u[n-i-1:], ldu)
			}
			if ncc > 0 {
				bi.Dswap(ncc, c[isub*ldc:], 1, c[(n-i-1)*ldc:], 1)
			}
		}
	}
	info = 0
	for i := 0; i < n-1; i++ {
		if e[i] != 0 {
			info++
		}
	}
	return info == 0
}