Mercurial > octave-nkf

changeset 7725:7c9ba697a479

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
cosmetic fixes in QR & Cholesky updating codes
author Jaroslav Hajek <highegg@gmail.com>
date Sun, 20 Apr 2008 09:50:22 -0400
parents 932b0cf51834
children 1b954fdaf4ff
files libcruft/ChangeLog libcruft/qrupdate/dch1dn.f libcruft/qrupdate/dchdex.f libcruft/qrupdate/dchinx.f libcruft/qrupdate/dqhqr.f libcruft/qrupdate/dqrdec.f libcruft/qrupdate/dqrinc.f libcruft/qrupdate/dqrqhu.f libcruft/qrupdate/dqrqhv.f libcruft/qrupdate/dqrshc.f libcruft/qrupdate/zch1dn.f libcruft/qrupdate/zchdex.f libcruft/qrupdate/zchinx.f libcruft/qrupdate/zqhqr.f libcruft/qrupdate/zqrdec.f libcruft/qrupdate/zqrder.f libcruft/qrupdate/zqrinc.f libcruft/qrupdate/zqrinr.f libcruft/qrupdate/zqrqhu.f libcruft/qrupdate/zqrqhv.f libcruft/qrupdate/zqrshc.f liboctave/ChangeLog liboctave/CmplxCHOL.cc liboctave/CmplxQR.cc liboctave/dbleCHOL.cc liboctave/dbleQR.cc
diffstat 26 files changed, 56 insertions(+), 41 deletions(-) [+]
line wrap: on
line diff
--- a/libcruft/ChangeLog	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/ChangeLog	Sun Apr 20 09:50:22 2008 -0400
@@ -1,3 +1,14 @@
+2008-04-20  Jaroslav Hajek <highegg@gmail.com>
+
+	* qrupdate/dch1dn.f, qrupdate/dchdex.f, qrupdate/dchinx.f,
+	qrupdate/dqhqr.f, qrupdate/dqrdec.f, qrupdate/dqrinc.f,
+	qrupdate/dqrqhu.f, qrupdate/dqrqhv.f, qrupdate/dqrshc.f,
+	qrupdate/zch1dn.f, qrupdate/zchdex.f, qrupdate/zchinx.f,
+	qrupdate/zqhqr.f, qrupdate/zqrdec.f, qrupdate/zqrder.f,
+	qrupdate/zqrinc.f, qrupdate/zqrinr.f, qrupdate/zqrqhu.f,
+	qrupdate/zqrqhv.f, qrupdate/zqrshc.f:
+	Fix external declarations, XERBLA calls, and docs.
+
 2008-04-07  Jaroslav Hajek <highegg@gmail.com>
 
 	* qrupdate/dqrqhu.f, qrupdate/zqrqhu.f,
--- a/libcruft/qrupdate/dch1dn.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/dch1dn.f	Sun Apr 20 09:50:22 2008 -0400
@@ -36,7 +36,7 @@
       integer n,info
       double precision R(n,n),u(n)
       double precision w(n)
-      external dtrsv,dcopy,dlartg,dnrm2
+      external dtrsv,dlartg,dnrm2
       double precision rho,dnrm2
       double precision rr,ui,t
       integer i,j
--- a/libcruft/qrupdate/dchdex.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/dchdex.f	Sun Apr 20 09:50:22 2008 -0400
@@ -31,7 +31,7 @@
       integer n,j,info
       double precision R(n,n),R1(n-1,n-1)
       double precision Qdum,c,s,rr
-      external dlacpy,dqhqr,dlartg
+      external xerbla,dlacpy,dqhqr,dlartg
 
 c quick return if possible
       if (n == 1) return
@@ -44,7 +44,7 @@
         info = 4
       end if
       if (info /= 0) then
-        call xerbla('DQRDEX',info)
+        call xerbla('DCHDEX',info)
       end if
 
 c setup the new matrix R1
--- a/libcruft/qrupdate/dchinx.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/dchinx.f	Sun Apr 20 09:50:22 2008 -0400
@@ -36,7 +36,7 @@
       integer n,j,info
       double precision R(n,n),R1(n+1,n+1),u(n+1)
       double precision rho,Qdum,w,dnrm2
-      external dcopy,dlacpy,dtrsv,dnrm2
+      external xerbla,dcopy,dlacpy,dtrsv,dnrm2,dqrqhu
       integer jj
 
 c quick return if possible
@@ -57,7 +57,7 @@
         info = 4
       end if
       if (info /= 0) then
-        call xerbla('DQRINX',info)
+        call xerbla('DCHINX',info)
       end if
 
 c copy shifted vector
--- a/libcruft/qrupdate/dqhqr.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/dqhqr.f	Sun Apr 20 09:50:22 2008 -0400
@@ -38,7 +38,7 @@
       double precision Q(ldq,*),R(ldr,*)
       double precision c
       double precision s,rr
-      external dlartg,drot
+      external xerbla,dlartg,drot
       integer info,i
 c quick return if possible.
       if (n <= 0 .or. k <= 1) return
--- a/libcruft/qrupdate/dqrdec.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/dqrdec.f	Sun Apr 20 09:50:22 2008 -0400
@@ -39,7 +39,7 @@
 c
       integer m,n,k,j
       double precision Q(m,k),R(k,n),R1(k,n-1)
-      external dcopy,dqhqr
+      external xerbla,dcopy,dqhqr
       integer info
 c quick return if possible      
       if (m <= 0 .or. k <= 0 .or. n == 1) return
--- a/libcruft/qrupdate/dqrinc.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/dqrinc.f	Sun Apr 20 09:50:22 2008 -0400
@@ -22,8 +22,8 @@
 c               i.e., given an m-by-k orthogonal matrix Q, an m-by-n
 c               upper trapezoidal matrix R and index j in the range 
 c               1:n+1, this subroutine updates the matrix Q -> Q1 and 
-c               forms an m-by-(n+1) matrix R1 so that Q1 is again unitary,
-c               R1 upper trapezoidal, and 
+c               forms an m-by-(n+1) matrix R1 so that Q1 is again
+c               orthogonal, R1 upper trapezoidal, and 
 c               Q1*R1 = [A(:,1:j-1); Q*Q'*x; A(:,j:n-1)], where A = Q*R.
 c               (real version)
 c arguments:
@@ -52,7 +52,7 @@
         info = 6
       end if
       if (info /= 0) then
-        call xerbla('DQRDER',info)
+        call xerbla('DQRINC',info)
       end if
 c copy leading portion of R 
       call dcopy(k*(j-1),R,1,R1,1)
--- a/libcruft/qrupdate/dqrqhu.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/dqrqhu.f	Sun Apr 20 09:50:22 2008 -0400
@@ -42,7 +42,7 @@
       double precision Q(ldq,*),R(ldr,*),u(*),rr
       double precision c
       double precision s,w
-      external dlartg,drot
+      external xerbla,dlartg,drot
       integer i,info
 c quick return if possible.
       if (k <= 0) return
--- a/libcruft/qrupdate/dqrqhv.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/dqrqhv.f	Sun Apr 20 09:50:22 2008 -0400
@@ -42,7 +42,7 @@
       double precision Q(ldq,*),R(ldr,*),u(*),rr
       double precision c
       double precision s,w,w1,ddot
-      external ddot,dlartg,drot
+      external xerbla,ddot,dlartg,drot
       integer i,info
 c quick return if possible.
       if (k <= 0) return
--- a/libcruft/qrupdate/dqrshc.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/dqrshc.f	Sun Apr 20 09:50:22 2008 -0400
@@ -22,8 +22,8 @@
 c               i.e., given an m-by-k orthogonal matrix Q, an k-by-n
 c               upper trapezoidal matrix R and index j in the range 
 c               1:n+1, this subroutine updates the matrix Q -> Q1 and 
-c               R -> R1 so that Q1 is again unitary, R1 upper trapezoidal, 
-c               and 
+c               R -> R1 so that Q1 is again orthogonal, R1 upper 
+c               trapezoidal, and 
 c               Q1*R1 = A(:,p), where A = Q*R and p is the permutation
 c               [1:i-1,shift(i:j,-1),j+1:n] if i < j  or
 c               [1:j-1,shift(j:i,+1),i+1:n] if j > i.
@@ -42,7 +42,7 @@
 c
       integer m,n,k,i,j
       double precision Q(m,k),R(k,n)
-      external dswap,dqhqr
+      external xerbla,dswap,dqhqr,dqrqhu
       double precision w
       integer l,jj,kk,info
 
--- a/libcruft/qrupdate/zch1dn.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/zch1dn.f	Sun Apr 20 09:50:22 2008 -0400
@@ -36,7 +36,7 @@
       integer n,info
       double complex R(n,n),u(n)
       double precision w(n)
-      external ztrsv,zcopy,zlartg,dznrm2
+      external ztrsv,zlartg,dznrm2
       double precision rho,dznrm2
       double complex crho,rr,ui,t
       integer i,j
--- a/libcruft/qrupdate/zchdex.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/zchdex.f	Sun Apr 20 09:50:22 2008 -0400
@@ -22,7 +22,7 @@
 c               factor of a symmetric positive definite matrix A, i.e.
 c               A = R'*R, this subroutine updates R -> R1 so that
 c               R1'*R1 = A(jj,jj), where jj = [1:j-1,j+1:n+1].
-c               (real version)
+c               (complex version)
 c arguments:
 c n (in)        the order of matrix R
 c R (in)        the original upper trapezoidal matrix R
@@ -32,7 +32,7 @@
       double complex R(n,n),R1(n-1,n-1)
       double precision c
       double complex Qdum,s,rr
-      external zlacpy,zqhqr,zlartg
+      external xerbla,zlacpy,zqhqr,zlartg
 
 c quick return if possible
       if (n == 1) return
@@ -45,7 +45,7 @@
         info = 4
       end if
       if (info /= 0) then
-        call xerbla('ZQRDEX',info)
+        call xerbla('ZCHDEX',info)
       end if
 
 c setup the new matrix R1
--- a/libcruft/qrupdate/zchinx.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/zchinx.f	Sun Apr 20 09:50:22 2008 -0400
@@ -37,7 +37,7 @@
       double complex R(n,n),R1(n+1,n+1),u(n+1)
       double precision rho,dznrm2
       double complex Qdum,w
-      external zcopy,zlacpy,ztrsv,dznrm2
+      external xerbla,zcopy,zlacpy,ztrsv,dznrm2,zqrqhu
       integer jj
 
 c quick return if possible
@@ -58,7 +58,7 @@
         info = 4
       end if
       if (info /= 0) then
-        call xerbla('ZQRINX',info)
+        call xerbla('ZCHINX',info)
       end if
 
 c copy shifted vector
--- a/libcruft/qrupdate/zqhqr.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/zqhqr.f	Sun Apr 20 09:50:22 2008 -0400
@@ -38,7 +38,7 @@
       double complex Q(ldq,*),R(ldr,*)
       double precision c
       double complex s,rr
-      external zlartg,zrot
+      external xerbla,zlartg,zrot
       integer info,i
 c quick return if possible.
       if (n <= 0 .or. k <= 1) return
--- a/libcruft/qrupdate/zqrdec.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/zqrdec.f	Sun Apr 20 09:50:22 2008 -0400
@@ -39,7 +39,7 @@
 c
       integer m,n,k,j
       double complex Q(m,k),R(k,n),R1(k,n-1)
-      external zcopy,zqhqr
+      external xerbla,zcopy,zqhqr
       integer info
 c quick return if possible      
       if (m <= 0 .or. k <= 0 .or. n == 1) return
@@ -51,7 +51,7 @@
         info = 7
       end if
       if (info /= 0) then
-        call xerbla('DQRDEC',info)
+        call xerbla('ZQRDEC',info)
       end if
 c copy leading portion
       call zcopy(k*(j-1),R,1,R1,1)
--- a/libcruft/qrupdate/zqrder.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/zqrder.f	Sun Apr 20 09:50:22 2008 -0400
@@ -39,7 +39,7 @@
       double complex Q(m,m),Q1(m-1,m-1),R(m,n),R1(m-1,n)
       double precision c
       double complex s,rr,w
-      external xerbla,zlacpy,zcopy,zlartg,zrot,zdscal,zaxpy
+      external xerbla,zlacpy,zlartg,zrot,zdscal,zaxpy
       integer i
 c quick return if possible      
       if (m == 1) return
--- a/libcruft/qrupdate/zqrinc.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/zqrinc.f	Sun Apr 20 09:50:22 2008 -0400
@@ -52,7 +52,7 @@
         info = 6
       end if
       if (info /= 0) then
-        call xerbla('ZQRDER',info)
+        call xerbla('ZQRINC',info)
       end if
 c copy leading portion of R 
       call zcopy(k*(j-1),R,1,R1,1)
--- a/libcruft/qrupdate/zqrinr.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/zqrinr.f	Sun Apr 20 09:50:22 2008 -0400
@@ -29,7 +29,7 @@
 c arguments:
 c m (in)        number of rows of the matrix R. 
 c n (in)        number of columns of the matrix R
-c Q (in)        the orthogonal matrix Q
+c Q (in)        the unitary matrix Q
 c Q1 (out)      the updated matrix Q1
 c R (in)        the upper trapezoidal matrix R
 c R1 (out)      the updated matrix R1
@@ -38,7 +38,7 @@
 c
       integer m,n,j
       double complex Q(m,m),Q1(m+1,m+1),R(m,n),R1(m+1,n),x(n)
-      external xerbla,zlacpy,dcopy,dqhqr
+      external xerbla,zlacpy,zcopy,zqhqr
       integer i
 c check arguments      
       info = 0
--- a/libcruft/qrupdate/zqrqhu.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/zqrqhu.f	Sun Apr 20 09:50:22 2008 -0400
@@ -27,7 +27,7 @@
 c m (in)        number of rows of the matrix Q.
 c n (in)        number of columns of the matrix R.
 c k (in)        number of columns of Q and rows of R.
-c Q (io)        on entry, the orthogonal matrix Q.
+c Q (io)        on entry, the unitary matrix Q.
 c               on exit, the updated matrix Q1.
 c ldq (in)      leading dimension of Q.
 c R (io)        on entry, the upper triangular matrix R.
@@ -36,13 +36,13 @@
 c u (in)        the k-vector u.
 c rr (out)      the first element of Q1'*u on exit.
 c
-c               if Q is orthogonal, so is Q1. It is not strictly
+c               if Q is unitary, so is Q1. It is not strictly
 c               necessary, however.
       integer m,n,k,ldq,ldr
       double complex Q(ldq,*),R(ldr,*),u(*),rr
       double precision c
       double complex s,w
-      external zlartg,zrot
+      external xerbla,zlartg,zrot
       integer i,info
 c quick return if possible.
       if (k <= 0) return
--- a/libcruft/qrupdate/zqrqhv.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/zqrqhv.f	Sun Apr 20 09:50:22 2008 -0400
@@ -27,7 +27,7 @@
 c m (in)        number of rows of the matrix Q.
 c n (in)        number of columns of the matrix R.
 c k (in)        number of columns of Q and rows of R. k <= m.
-c Q (io)        on entry, the orthogonal matrix Q.
+c Q (io)        on entry, the unitary matrix Q.
 c               on exit, the updated matrix Q1.
 c ldq (in)      leading dimension of Q.
 c R (io)        on entry, the upper triangular matrix R.
@@ -36,13 +36,13 @@
 c u (in)        the m-vector u.
 c rr (out)      the first element of Q1'*u on exit.
 c
-c               if Q is orthogonal, so is Q1. It is not strictly
+c               if Q is unitary, so is Q1. It is not strictly
 c               necessary, however.
       integer m,n,k,ldq,ldr
       double complex Q(ldq,*),R(ldr,*),u(*),rr
       double precision c
       double complex s,w,w1,zdotc
-      external zdotc,zlartg,zrot
+      external xerbla,zdotc,zlartg,zrot
       integer i,info
 c quick return if possible.
       if (k <= 0) return
--- a/libcruft/qrupdate/zqrshc.f	Sun Apr 20 09:04:47 2008 -0400
+++ b/libcruft/qrupdate/zqrshc.f	Sun Apr 20 09:50:22 2008 -0400
@@ -19,7 +19,7 @@
       subroutine zqrshc(m,n,k,Q,R,i,j)
 c purpose:      updates a QR factorization after circular shift of
 c               columns.      
-c               i.e., given an m-by-k orthogonal matrix Q, an k-by-n
+c               i.e., given an m-by-k unitary matrix Q, an k-by-n
 c               upper trapezoidal matrix R and index j in the range 
 c               1:n+1, this subroutine updates the matrix Q -> Q1 and 
 c               R -> R1 so that Q1 is again unitary, R1 upper trapezoidal, 
@@ -28,7 +28,7 @@
 c               [1:i-1,shift(i:j,-1),j+1:n] if i < j  or
 c               [1:j-1,shift(j:i,+1),i+1:n] if j > i.
 c               if m == 0, the matrix Q is ignored.
-c               (real version)
+c               (complex version)
 c arguments:
 c m (in)        number of rows of the matrix Q, or 0 if Q is not needed.
 c n (in)        number of columns of the matrix R.
@@ -42,7 +42,7 @@
 c
       integer m,n,k,i,j
       double complex Q(m,k),R(k,n)
-      external zswap,zqhqr
+      external xerbla,zswap,zqhqr,zqrqhu
       double complex w
       integer l,jj,kk,info
 
--- a/liboctave/ChangeLog	Sun Apr 20 09:04:47 2008 -0400
+++ b/liboctave/ChangeLog	Sun Apr 20 09:50:22 2008 -0400
@@ -1,3 +1,7 @@
+2008-04-19  Jaroslav Hajek <highegg@gmail.com>
+
+	* CmplxCHOL.cc, CmplxQR.cc, dbleCHOL.cc, dbleQR.cc: Fix calls to error()
+
 2008-04-16  David Bateman  <dbateman@free.fr>
 
 	* Sparse.h (Sparse<T>& operator = (Sparse<T>&)): Move definition
--- a/liboctave/CmplxCHOL.cc	Sun Apr 20 09:04:47 2008 -0400
+++ b/liboctave/CmplxCHOL.cc	Sun Apr 20 09:50:22 2008 -0400
@@ -251,7 +251,7 @@
   octave_idx_type n = chol_mat.rows ();
   
   if (j < 0 || j > n-1)
-    (*current_liboctave_error_handler) ("CHOL insert index out of range");
+    (*current_liboctave_error_handler) ("CHOL delete index out of range");
   else
     {
       ComplexMatrix chol_mat1 (n-1, n-1);
--- a/liboctave/CmplxQR.cc	Sun Apr 20 09:04:47 2008 -0400
+++ b/liboctave/CmplxQR.cc	Sun Apr 20 09:50:22 2008 -0400
@@ -259,7 +259,7 @@
   octave_idx_type n = r.columns ();
 
   if (! q.is_square ())
-    (*current_liboctave_error_handler) ("QR insert dimensions mismatch");
+    (*current_liboctave_error_handler) ("QR delete dimensions mismatch");
   else if (j < 0 || j > m-1) 
     (*current_liboctave_error_handler) ("QR delete index out of range");
   else
--- a/liboctave/dbleCHOL.cc	Sun Apr 20 09:04:47 2008 -0400
+++ b/liboctave/dbleCHOL.cc	Sun Apr 20 09:50:22 2008 -0400
@@ -255,7 +255,7 @@
   octave_idx_type n = chol_mat.rows ();
   
   if (j < 0 || j > n-1)
-    (*current_liboctave_error_handler) ("CHOL insert index out of range");
+    (*current_liboctave_error_handler) ("CHOL delete index out of range");
   else
     {
       Matrix chol_mat1 (n-1, n-1);
--- a/liboctave/dbleQR.cc	Sun Apr 20 09:04:47 2008 -0400
+++ b/liboctave/dbleQR.cc	Sun Apr 20 09:50:22 2008 -0400
@@ -248,7 +248,7 @@
   octave_idx_type n = r.columns ();
 
   if (! q.is_square ())
-    (*current_liboctave_error_handler) ("QR insert dimensions mismatch");
+    (*current_liboctave_error_handler) ("QR delete dimensions mismatch");
   else if (j < 0 || j > m-1) 
     (*current_liboctave_error_handler) ("QR delete index out of range");
   else