qrupdate-1.1.2/0000750035452500116100000000000011714051463012301 5ustar higheggengqrupdate-1.1.2/Makeconf.g950000640035452500116100000000075211334744051014357 0ustar higheggeng# set this to your compiler's executable name (e.g. gfortran, g77) FC=g95 # requested flags FFLAGS=-O3 -funroll-loops # set if you need shared library FPICFLAGS=-fPIC # BLAS library (only required for tests) BLAS=-lblas # LAPACK library (only required for tests) LAPACK=-llapack # Library version VERSION=1.1 MAJOR=1 # The default library dir LIBDIR=lib # Destination installation offset DESTDIR= # set default prefix to /usr/local ifeq ($(strip $(PREFIX)),) PREFIX=/usr/local endif qrupdate-1.1.2/src/0000750035452500116100000000000011714051463013070 5ustar higheggengqrupdate-1.1.2/src/cqrinr.f0000640035452500116100000000604611131630410014530 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cqrinr(m,n,Q,ldq,R,ldr,j,x,rw) c purpose: updates a QR factorization after inserting a new c row. c i.e., given an m-by-m unitary matrix Q, an m-by-n c upper trapezoidal matrix R and index j in the range c 1:m+1, this subroutine updates Q -> Q1 and R -> R1 c so that Q1 is again unitary, R1 upper trapezoidal, c and Q1*R1 = [A(1:j-1,:); x; A(j:m,:)], where A = Q*R. c (complex version) c arguments: c m (in) number of rows of the matrix Q. c n (in) number of columns of the matrix R. c Q (io) on entry, the unitary matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m+1. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= m+1. c j (in) the position of the new row in R1 c x (io) on entry, the row being added c on exit, x is destroyed. c rw (out) a real workspace vector of size min(m,n). c integer m,n,j,ldq,ldr complex Q(ldq,*),R(ldr,*),x(*) real rw(*) external xerbla,ccopy,cqhqr,cqrot integer info,i,k c check arguments info = 0 if (n < 0) then info = 2 else if (j < 1 .or. j > m+1) then info = 7 end if if (info /= 0) then call xerbla('CQRINR',info) return end if c permute the columns of Q1 and rows of R1 so that c the new row ends c up being the topmost row of R1. do i = m,1,-1 if (j > 1) then call ccopy(j-1,Q(1,i),1,Q(1,i+1),1) end if Q(j,i+1) = 0e0 if (j <= m) then call ccopy(m+1-j,Q(j,i),1,Q(j+1,i+1),1) end if end do c set up the 1st column do i = 1,j-1 Q(i,1) = 0e0 end do Q(j,1) = 1e0 do i = j+1,m+1 Q(i,1) = 0e0 end do c set up the new matrix R1 do k = 1,n if (k < m) R(m+1,k) = 0e0 do i = min(m,k),1,-1 R(i+1,k) = R(i,k) end do R(1,k) = x(k) end do c retriangularize R call cqhqr(m+1,n,R,ldr,rw,x) c apply rotations to Q call cqrot('F',m+1,min(m,n)+1,Q,ldq,rw,x) end subroutine qrupdate-1.1.2/src/zqrinr.f0000640035452500116100000000607111131630410014555 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zqrinr(m,n,Q,ldq,R,ldr,j,x,rw) c purpose: updates a QR factorization after inserting a new c row. c i.e., given an m-by-m unitary matrix Q, an m-by-n c upper trapezoidal matrix R and index j in the range c 1:m+1, this subroutine updates Q -> Q1 and R -> R1 c so that Q1 is again unitary, R1 upper trapezoidal, c and Q1*R1 = [A(1:j-1,:); x; A(j:m,:)], where A = Q*R. c (complex version) c arguments: c m (in) number of rows of the matrix Q. c n (in) number of columns of the matrix R. c Q (io) on entry, the unitary matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m+1. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= m+1. c j (in) the position of the new row in R1 c x (io) on entry, the row being added c on exit, x is destroyed. c rw (out) a real workspace vector of size min(m,n). c integer m,n,j,ldq,ldr double complex Q(ldq,*),R(ldr,*),x(*) double precision rw(*) external xerbla,zcopy,zqhqr,zqrot integer info,i,k c check arguments info = 0 if (n < 0) then info = 2 else if (j < 1 .or. j > m+1) then info = 7 end if if (info /= 0) then call xerbla('ZQRINR',info) return end if c permute the columns of Q1 and rows of R1 so that c the new row ends c up being the topmost row of R1. do i = m,1,-1 if (j > 1) then call zcopy(j-1,Q(1,i),1,Q(1,i+1),1) end if Q(j,i+1) = 0d0 if (j <= m) then call zcopy(m+1-j,Q(j,i),1,Q(j+1,i+1),1) end if end do c set up the 1st column do i = 1,j-1 Q(i,1) = 0d0 end do Q(j,1) = 1d0 do i = j+1,m+1 Q(i,1) = 0d0 end do c set up the new matrix R1 do k = 1,n if (k < m) R(m+1,k) = 0d0 do i = min(m,k),1,-1 R(i+1,k) = R(i,k) end do R(1,k) = x(k) end do c retriangularize R call zqhqr(m+1,n,R,ldr,rw,x) c apply rotations to Q call zqrot('F',m+1,min(m,n)+1,Q,ldq,rw,x) end subroutine qrupdate-1.1.2/src/caxcpy.f0000640035452500116100000000331611131630410014516 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine caxcpy(n,a,x,incx,y,incy) c purpose: constant times a conjugated vector plus a vector. c arguments: c n (in) vector length c a (in) complex factor c x (in) added vector c incx (in) x increments c y (io) accumulator vector c incy (in) y increments c integer n,incx,incy complex a,x(*),y(*) integer i,ix,iy c quick return if possible. if (n <= 0) return if (incx /= 1 .or. incy /= 1) then c code for unequal increments or equal increments not equal to 1 ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n y(iy) = y(iy) + a*conjg(x(ix)) ix = ix + incx iy = iy + incy end do else c code for both increments equal to 1 do i = 1,n y(i) = y(i) + a*conjg(x(i)) end do end if end subroutine qrupdate-1.1.2/src/cqrtv1.f0000640035452500116100000000301011131630410014436 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cqrtv1(n,u,w) c purpose: generates a sequence of n-1 Givens rotations that c eliminate all but the first element of a vector u. c arguments: c n (in) the length of the vector u c u (io) on entry, the vector u. c on exit, u(2:n) contains the rotation sines, u(1) c contains the remaining element. c w (o) on exit, w contains the rotation cosines. c integer n complex u(*) real w(*) external clartg complex rr,t integer i c quick return if possible. if (n <= 0) return rr = u(n) do i = n-1,1,-1 call clartg(u(i),rr,w(i),u(i+1),t) rr = t end do u(1) = rr end subroutine qrupdate-1.1.2/src/sqrot.f0000640035452500116100000000415611131630410014402 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sqrot(dir,m,n,Q,ldq,c,s) c purpose: Apply a sequence of inv. rotations from right c c arguments: c dir (in) if 'B' or 'b', rotations are applied from backwards c if 'F' or 'f', from forwards. c m (in) number of rows of matrix Q c n (in) number of columns of the matrix Q c Q (io) on entry, the matrix Q c on exit, the updated matrix Q1 c ldq (in) the leading dimension of Q c c (in) n-1 rotation cosines c s (in) n-1 rotation sines c character dir integer m,n,ldq real Q(ldq,*),c(*),s(*) external srot,lsame logical lsame,fwd integer info,i c quick return if possible if (m == 0 .or. n == 0 .or. n == 1) return c check arguments. info = 0 fwd = lsame(dir,'F') if (.not.(fwd .or. lsame(dir,'B'))) then info = 1 else if (m < 0) then info = 2 else if (n < 0) then info = 3 else if (ldq < m) then info = 5 end if if (info /= 0) then call xerbla('SQROT',info) return end if if (fwd) then do i = 1,n-1 call srot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) end do else do i = n-1,1,-1 call srot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) end do end if end subroutine qrupdate-1.1.2/src/sqrinr.f0000640035452500116100000000601411131630410014543 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sqrinr(m,n,Q,ldq,R,ldr,j,x,w) c purpose: updates a QR factorization after inserting a new c row. c i.e., given an m-by-m unitary matrix Q, an m-by-n c upper trapezoidal matrix R and index j in the range c 1:m+1, this subroutine updates Q -> Q1 and R -> R1 c so that Q1 is again unitary, R1 upper trapezoidal, c and Q1*R1 = [A(1:j-1,:); x; A(j:m,:)], where A = Q*R. c (real version) c arguments: c m (in) number of rows of the matrix Q. c n (in) number of columns of the matrix R. c Q (io) on entry, the unitary matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m+1. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= m+1. c j (in) the position of the new row in R1 c x (io) on entry, the row being added c on exit, x is destroyed. c w (out) a workspace vector of size min(m,n). c integer m,n,j,ldq,ldr real Q(ldq,*),R(ldr,*),x(*),w(*) external xerbla,scopy,sqhqr,sqrot integer info,i,k c check arguments info = 0 if (n < 0) then info = 2 else if (j < 1 .or. j > m+1) then info = 7 end if if (info /= 0) then call xerbla('SQRINR',info) return end if c permute the columns of Q1 and rows of R1 so that c the new row ends c up being the topmost row of R1. do i = m,1,-1 if (j > 1) then call scopy(j-1,Q(1,i),1,Q(1,i+1),1) end if Q(j,i+1) = 0e0 if (j <= m) then call scopy(m+1-j,Q(j,i),1,Q(j+1,i+1),1) end if end do c set up the 1st column do i = 1,j-1 Q(i,1) = 0e0 end do Q(j,1) = 1e0 do i = j+1,m+1 Q(i,1) = 0e0 end do c set up the new matrix R1 do k = 1,n if (k < m) R(m+1,k) = 0e0 do i = min(m,k),1,-1 R(i+1,k) = R(i,k) end do R(1,k) = x(k) end do c retriangularize R call sqhqr(m+1,n,R,ldr,w,x) c apply rotations to Q call sqrot('F',m+1,min(m,n)+1,Q,ldq,w,x) end subroutine qrupdate-1.1.2/src/zgqvec.f0000640035452500116100000000451511131630410014530 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zgqvec(m,n,Q,ldq,u) c purpose: given an unitary m-by-n matrix Q, n < m, generates c a vector u such that Q'*u = 0 and norm(u) = 1. c arguments: c m (in) number of rows of matrix Q. c n (in) number of columns of matrix Q. c Q (in) the unitary matrix Q. c ldq (in) leading dimension of Q. c u (out) the generated vector. c integer m,n,ldq double complex Q(ldq,*),u(*) external zdotu,zaxpy,dznrm2,zdscal real zdotu double precision dznrm2,r integer info,i,j c quick return if possible. if (m == 0) return if (n == 0) then u(1) = 1d0 do i = 2,m u(i) = 0d0 end do return end if c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldq < m) then info = 4 end if if (info /= 0) then call xerbla('ZGQVEC',info) return end if j = 1 10 continue c probe j-th canonical unit vector. do i = 1,m u(i) = 0d0 end do u(j) = 1d0 c form u - Q*Q'*u do i = 1,n r = zdotu(m,Q(1,i),1,u,1) call zaxpy(m,-r,Q(1,i),1,u,1) end do r = dznrm2(m,u,1) if (r == 0d0) then j = j + 1 if (j > n) then c this is fatal, and in theory, it can't happen. stop 'fatal: impossible condition in ZGQVEC' else j = j + 1 goto 10 end if end if call zdscal(m,1d0/r,u,1) end subroutine qrupdate-1.1.2/src/dqhqr.f0000640035452500116100000000445711131630410014355 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dqhqr(m,n,R,ldr,c,s) c purpose: given an m-by-n upper Hessenberg matrix R, this c subroutine updates R to upper trapezoidal form c using min(m-1,n) Givens rotations. c (real version) c arguments: c m (in) number of rows of the matrix R c n (in) number of columns of the matrix R c R (io) on entry, the upper Hessenberg matrix R c on exit, the updated upper trapezoidal matrix c ldr (in) leading dimension of R, >= m c c(out) rotation cosines, size at least min(m-1,n) c s(out) rotation sines, size at least min(m-1,n) c integer m,n,ldr double precision R(ldr,*),c(*),s(*) external xerbla,dlartg double precision t integer info,i,ii,j c quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call xerbla('DQHQR',info) return end if do i = 1,n c apply stored rotations, column-wise t = R(1,i) ii = min(m,i) do j = 1,ii-1 R(j,i) = c(j)*t + s(j)*R(j+1,i) t = c(j)*R(j+1,i) - s(j)*t end do if (ii < m) then c generate next rotation call dlartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) R(ii+1,i) = 0d0 else R(ii,i) = t end if end do end subroutine qrupdate-1.1.2/src/dqrqh.f0000640035452500116100000000413511131630410014346 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dqrqh(m,n,R,ldr,c,s) c purpose: brings an upper trapezoidal matrix R into upper c Hessenberg form using min(m-1,n) Givens rotations. c (real version) c arguments: c m (in) number of rows of the matrix R c n (in) number of columns of the matrix R c R (io) on entry, the upper Hessenberg matrix R c on exit, the updated upper trapezoidal matrix c ldr (in) leading dimension of R, >= m c c(in) rotation cosines, size at least min(m-1,n) c s(in) rotation sines, size at least min(m-1,n) c integer m,n,ldr double precision R(ldr,*),c(*),s(*) external xerbla double precision t integer info,i,ii,j c quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call xerbla('DQRQH',info) return end if do i = 1,n ii = min(m-1,i) c apply stored rotations, column-wise t = R(ii+1,i) do j = ii,1,-1 R(j+1,i) = c(j)*t - s(j)*R(j,i) t = c(j)*R(j,i) + s(j)*t end do R(1,i) = t end do end subroutine qrupdate-1.1.2/src/cchinx.f0000640035452500116100000000633011133034413014505 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cchinx(n,R,ldr,j,u,rw,info) c purpose: given an upper triangular matrix R that is a Cholesky c factor of a hermitian positive definite matrix A, i.e. c A = R'*R, this subroutine updates R -> R1 so that c R1'*R1 = A1, A1(jj,jj) = A, A(j,:) = u', A(:,j) = u, c jj = [1:j-1,j+1:n+1]. c (complex version) c arguments: c n (in) the order of matrix R. c R (io) on entry, the original upper trapezoidal matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= n+1. c j (in) the position of the inserted row/column c u (io) on entry, the inserted row/column. c on exit, u is destroyed. c rw (out) real workspace vector of size n+1. c info (out) on exit, error code: c info = 0: success. c info = 1: update violates positive-definiteness. c info = 2: R is singular. c info = 3: diagonal element of u is not real. c integer n,j,ldr,info complex R(ldr,*),u(*),rw(*) external xerbla,ccopy,scnrm2,ctrsv,cqrtv1,cqrqh complex t real scnrm2,rho integer i c check arguments info = 0 if (n < 0) then info = -1 else if (j < 1 .or. j > n+1) then info = -4 end if if (info /= 0) then call xerbla('CCHINX',info) return end if c shift vector. t = u(j) do i = j,n u(i) = u(i+1) end do c the diagonal element must be real. if (imag(t) /= 0e0) goto 30 c check for singularity of R. do i = 1,n if (R(i,i) == 0e0) goto 20 end do c form R' \ u call ctrsv('U','C','N',n,R,ldr,u,1) rho = scnrm2(n,u,1) c check positive definiteness. rho = t - rho**2 if (rho <= 0e0) goto 10 c shift columns do i = n,j,-1 call ccopy(i,R(1,i),1,R(1,i+1),1) R(i+1,i+1) = 0e0 end do call ccopy(n,u,1,R(1,j),1) R(n+1,j) = sqrt(rho) c retriangularize if (j < n+1) then c eliminate the introduced spike. call cqrtv1(n+2-j,R(j,j),rw) c apply rotations to R call cqrqh(n+2-j,n+1-j,R(j,j+1),ldr,rw,R(j+1,j)) c zero spike. do i = j+1,n+1 R(i,j) = 0e0 end do end if c normal return. return c error returns. 10 info = 1 return 20 info = 2 return 30 info = 3 return end subroutine qrupdate-1.1.2/src/sqr1up.f0000640035452500116100000000730511134330274014474 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sqr1up(m,n,k,Q,ldq,R,ldr,u,v,w) c purpose: updates a QR factorization after rank-1 modification c i.e., given a m-by-k orthogonal Q and m-by-n upper c trapezoidal R, an m-vector u and n-vector v, c this subroutine updates Q -> Q1 and R -> R1 so that c Q1*R1 = Q*R + u*v', and Q1 is again orthonormal c and R1 upper trapezoidal. c (real version) c arguments: 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. Must be c either k = m (full Q) or k = n < m (economical form). c Q (io) on entry, the orthogonal m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) the leading dimension of Q. ldq >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R.. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= k. c u (io) the left m-vector. On exit, if k < m, u is destroyed. c v (io) the right n-vector. On exit, v is destroyed. c w (out) a workspace vector of size 2*k c integer m,n,k,ldq,ldr real Q(ldq,*),R(ldr,*),u(*),v(*),w(*) external sqrqh,sqhqr,sqrot,sqrtv1 external saxpy,sdot,snrm2,slamch,sscal,srot real sdot,snrm2,slamch,ru,ruu integer info,i logical full c quick return if possible. if (k == 0 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 endif if (info /= 0) then call xerbla('SQR1UP',info) return end if full = k == m c in the non-full case, we shall need the norm of u. if (.not.full) ru = snrm2(m,u,1) c form Q'*u. In the non-full case, form also u - Q*Q'u. do i = 1,k w(i) = sdot(m,Q(1,i),1,u,1) if (.not.full) call saxpy(m,-w(i),Q(1,i),1,u,1) end do c generate rotations to eliminate Q'*u. call sqrtv1(k,w,w(k+1)) c apply rotations to R. call sqrqh(k,n,R,ldr,w(k+1),w(2)) c apply rotations to Q. call sqrot('B',m,k,Q,ldq,w(k+1),w(2)) c update the first row of R. call saxpy(n,w(1),v,1,R(1,1),ldr) c retriangularize R. call sqhqr(k,n,R,ldr,w(k+1),w) c apply rotations to Q. call sqrot('F',m,min(k,n+1),Q,ldq,w(k+1),w) c in the full case, we're finished if (full) return c compute relative residual norm ruu = snrm2(m,u,1) ru = ru * slamch('e') if (ruu <= ru) return c update the orthogonal basis. call sscal(n,ruu,v,1) call sscal(m,1e0/ruu,u,1) call sch1up(n,R,ldr,v,w(k+1)) do i = 1,n call srot(m,Q(1,i),1,u,1,w(k+i),v(i)) end do end subroutine qrupdate-1.1.2/src/sch1up.f0000640035452500116100000000365411133034413014442 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sch1up(n,R,ldr,u,w) c purpose: given an upper triangular matrix R that is a Cholesky 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 + u*u' c (real version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c u (io) the vector determining the rank-1 update c on exit, u contains the rotation sines c used to transform R to R1. c w (out) cosine parts of rotations. c integer n,ldr real R(ldr,*),u(*) real w(*) external slartg real rr,ui,t integer i,j do i = 1,n c apply stored rotations, column-wise ui = u(i) do j = 1,i-1 t = w(j)*R(j,i) + u(j)*ui ui = w(j)*ui - u(j)*R(j,i) R(j,i) = t end do c generate next rotation call slartg(R(i,i),ui,w(i),u(i),rr) R(i,i) = rr end do end subroutine qrupdate-1.1.2/src/zchshx.f0000640035452500116100000000553411133034413014545 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zchshx(n,R,ldr,i,j,w,rw) c purpose: given an upper triangular matrix R that is a Cholesky 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(p,p), where 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. c (complex version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c i (in) the first index determining the range (see above). c j (in) the second index determining the range (see above). c w (o) a workspace vector of size n. c rw (o) a real workspace vector of size n. c integer n,ldr,i,j double complex R(ldr,*),w(*) double precision rw(*) external xerbla,zcopy,zqrtv1,zqrqh,zqhqr integer info,l c quick return if possible. if (n == 0 .or. n == 1) return info = 0 c check arguments. if (n < 0) then info = 1 else if (i < 1 .or. i > n) then info = 4 else if (j < 1 .or. j > n) then info = 5 end if if (info /= 0) then call xerbla('ZCHSHX',info) return end if if (i < j) then c shift columns call zcopy(n,R(1,i),1,w,1) do l = i,j-1 call zcopy(n,R(1,l+1),1,R(1,l),1) end do call zcopy(n,w,1,R(1,j),1) c retriangularize call zqhqr(n+1-i,n+1-i,R(i,i),ldr,rw,w) else if (j < i) then c shift columns call zcopy(n,R(1,i),1,w,1) do l = i,j+1,-1 call zcopy(n,R(1,l-1),1,R(1,l),1) end do call zcopy(n,w,1,R(1,j),1) c eliminate the introduced spike. call zqrtv1(n+1-j,R(j,j),rw) c apply rotations to R call zqrqh(n+1-j,n-j,R(j,j+1),ldr,rw,R(j+1,j)) c zero spike. do l = j+1,n R(l,j) = 0d0 end do end if end subroutine qrupdate-1.1.2/src/sqrshc.f0000640035452500116100000000743211133034413014540 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sqrshc(m,n,k,Q,ldq,R,ldr,i,j,w) 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 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 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. c (real version) c arguments: 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 Q1, and rows of R1. Must be c either k = m (full Q) or k = n <= m (economical form). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= k. c i (in) the first index determining the range (see above) c j (in) the second index determining the range (see above) c w (o) a workspace vector of size 2*k. c integer m,n,k,ldq,ldr,i,j real Q(ldq,*),R(ldr,*),w(*) external xerbla,scopy,sqrtv1,sqrqh,sqhqr integer info,jj,kk,l c quick return if possible. if (m == 0 .or. n == 1) return info = 0 c check arguments. if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (i < 1 .or. i > n) then info = 6 else if (j < 1 .or. j > n) then info = 7 end if if (info /= 0) then call xerbla('SQRSHC',info) return end if if (i < j) then c shift columns call scopy(k,R(1,i),1,w,1) do l = i,j-1 call scopy(k,R(1,l+1),1,R(1,l),1) end do call scopy(k,w,1,R(1,j),1) c retriangularize if (i < k) then kk = min(k,j) call sqhqr(kk+1-i,n+1-i,R(i,i),ldr,w(k+1),w) c apply rotations to Q. call sqrot('F',m,kk+1-i,Q(1,i),ldq,w(k+1),w) end if else if (j < i) then c shift columns call scopy(k,R(1,i),1,w,1) do l = i,j+1,-1 call scopy(k,R(1,l-1),1,R(1,l),1) end do call scopy(k,w,1,R(1,j),1) c retriangularize if (j < k) then jj = min(j+1,n) kk = min(k,i) c eliminate the introduced spike. call sqrtv1(kk+1-j,R(j,j),w(k+1)) c apply rotations to R call sqrqh(kk+1-j,n-j,R(j,jj),ldr,w(k+1),R(j+1,j)) c apply rotations to Q call sqrot('B',m,kk+1-j,Q(1,j),ldq,w(k+1),R(j+1,j)) c zero spike. do l = j+1,kk R(l,j) = 0e0 end do end if end if end subroutine qrupdate-1.1.2/src/dgqvec.f0000640035452500116100000000450211131630410014476 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dgqvec(m,n,Q,ldq,u) c purpose: given an orthogonal m-by-n matrix Q, n < m, generates c a vector u such that Q'*u = 0 and norm(u) = 1. c arguments: c m (in) number of rows of matrix Q. c n (in) number of columns of matrix Q. c Q (in) the orthogonal matrix Q. c ldq (in) leading dimension of Q. c u (out) the generated vector. c integer m,n,ldq double precision Q(ldq,*),u(*) external ddot,daxpy,dnrm2,dscal double precision ddot,dnrm2,r integer info,i,j c quick return if possible. if (m == 0) return if (n == 0) then u(1) = 1d0 do i = 2,m u(i) = 0d0 end do return end if c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldq < m) then info = 4 end if if (info /= 0) then call xerbla('DGQVEC',info) return end if j = 1 10 continue c probe j-th canonical unit vector. do i = 1,m u(i) = 0d0 end do u(j) = 1d0 c form u - Q*Q'*u do i = 1,n r = ddot(m,Q(1,i),1,u,1) call daxpy(m,-r,Q(1,i),1,u,1) end do r = dnrm2(m,u,1) if (r == 0d0) then j = j + 1 if (j > n) then c this is fatal, and in theory, it can't happen. stop 'fatal: impossible condition in DGQVEC' else j = j + 1 goto 10 end if end if call dscal(m,1d0/r,u,1) end subroutine qrupdate-1.1.2/src/dch1up.f0000640035452500116100000000372011133034413014415 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dch1up(n,R,ldr,u,w) c purpose: given an upper triangular matrix R that is a Cholesky 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 + u*u' c (real version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c u (io) the vector determining the rank-1 update c on exit, u contains the rotation sines c used to transform R to R1. c w (out) cosine parts of rotations. c integer n,ldr double precision R(ldr,*),u(*) double precision w(*) external dlartg double precision rr,ui,t integer i,j do i = 1,n c apply stored rotations, column-wise ui = u(i) do j = 1,i-1 t = w(j)*R(j,i) + u(j)*ui ui = w(j)*ui - u(j)*R(j,i) R(j,i) = t end do c generate next rotation call dlartg(R(i,i),ui,w(i),u(i),rr) R(i,i) = rr end do end subroutine qrupdate-1.1.2/src/sqrinc.f0000640035452500116100000001017211133034413014527 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sqrinc(m,n,k,Q,ldq,R,ldr,j,x,w) c purpose: updates a QR factorization after inserting a new c column. 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 R -> R1 so that Q1 is again orthogonal, R1 upper c trapezoidal, and Q1*R1 = [A(:,1:j-1); x; A(:,j:n)], c where A = Q*R. c (real version) c arguments: 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. Must be c either k = m (full Q) or k = n <= m (economical form, c basis dimension will increase). c Q (io) on entry, the orthogonal m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= min(m,n+1). c j (in) the position of the new column in R1 c x (in) the column being inserted c w (out) a workspace vector of size k. c integer m,n,k,ldq,ldr,j real Q(ldq,*),R(ldr,*),x(*),w(*) external sqrtv1,sqrqh,sqrot external xerbla,scopy,sdot,saxpy,sscal,snrm2 real sdot,snrm2,rx integer info,i,k1 logical full c quick return if possible. if (m == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < min(m,k+1)) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call xerbla('SQRINC',info) return end if full = k == m c insert empty column at j-th position. do i = n,j,-1 call scopy(k,R(1,i),1,R(1,i+1),1) end do c insert Q'*u into R. In the nonfull case, form also u-Q*Q'*u. if (full) then k1 = k do i = 1,k R(i,j) = sdot(m,Q(1,i),1,x,1) end do else k1 = k + 1 c zero last row of R do i = 1,n+1 R(k1,i) = 0e0 end do call scopy(m,x,1,Q(1,k1),1) do i = 1,k R(i,j) = sdot(m,Q(1,i),1,Q(1,k1),1) call saxpy(m,-R(i,j),Q(1,i),1,Q(1,k1),1) end do c get norm of the inserted column rx = snrm2(m,Q(1,k1),1) R(k1,j) = rx if (rx == 0e0) then c in the rare case when rx is exact zero, we still need to provide c a valid orthogonal unit vector. The details are boring, so handle c that elsewhere. call sgqvec(m,k,Q,ldq,Q(1,k1)) else c otherwise, just normalize the added column. call sscal(m,1e0/rx,Q(1,k1),1) end if end if c maybe we're finished. if (j > k) return c eliminate the spike. call sqrtv1(k1+1-j,R(j,j),w) c apply rotations to R(j:k,j:n). if (j <= n) call sqrqh(k1+1-j,n+1-j,R(j,j+1),ldr,w,R(j+1,j)) c apply rotations to Q(:,j:k). call sqrot('B',m,k1+1-j,Q(1,j),ldq,w,R(j+1,j)) c zero spike. do i = j+1,k1 R(i,j) = 0e0 end do end subroutine qrupdate-1.1.2/src/zchdex.f0000640035452500116100000000410511133034413014514 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zchdex(n,R,ldr,j,rw) c purpose: given an upper triangular matrix R that is a Cholesky c factor of a hermitian 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 (complex version) c arguments: c n (in) the order of matrix R. c R (io) on entry, the original upper trapezoidal matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= n. c j (in) the position of the deleted row/column. c rw (out) a real workspace vector of size n. c integer n,ldr,j double complex R(ldr,*) double precision rw(*) integer info,i external xerbla,zcopy,zqhqr c quick return if possible if (n == 1) return c check arguments info = 0 if (n < 0) then info = 1 else if (j < 1 .or. j > n) then info = 4 end if if (info /= 0) then call xerbla('ZCHDEX',info) return end if c delete the j-th column. do i = j,n-1 call zcopy(n,R(1,i+1),1,R(1,i),1) end do c retriangularize. if (j < n) then call zqhqr(n+1-j,n-j,R(j,j),ldr,rw,R(1,n)) end if end subroutine qrupdate-1.1.2/src/zaxcpy.f0000640035452500116100000000332511131630410014545 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zaxcpy(n,a,x,incx,y,incy) c purpose: constant times a conjugated vector plus a vector. c arguments: c n (in) vector length c a (in) complex factor c x (in) added vector c incx (in) x increments c y (io) accumulator vector c incy (in) y increments c integer n,incx,incy double complex a,x(*),y(*) integer i,ix,iy c quick return if possible. if (n <= 0) return if (incx /= 1 .or. incy /= 1) then c code for unequal increments or equal increments not equal to 1 ix = 1 iy = 1 if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do i = 1,n y(iy) = y(iy) + a*conjg(x(ix)) ix = ix + incx iy = iy + incy end do else c code for both increments equal to 1 do i = 1,n y(i) = y(i) + a*conjg(x(i)) end do end if end subroutine qrupdate-1.1.2/src/zqrinc.f0000640035452500116100000001027011133034413014535 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zqrinc(m,n,k,Q,ldq,R,ldr,j,x,rw) c purpose: updates a QR factorization after inserting a new c column. c i.e., given an m-by-k unitary matrix Q, an m-by-n upper c trapezoidal matrix R and index j in the range 1:n+1, c this subroutine updates the matrix Q -> Q1 and R -> R1 c so that Q1 is again unitary, R1 upper trapezoidal, and c Q1*R1 = [A(:,1:j-1); x; A(:,j:n)], where A = Q*R. c (complex version) c arguments: 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. Must be c either k = m (full Q) or k = n <= m (economical form, c basis dimension will increase). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= min(m,n+1). c j (in) the position of the new column in R1 c x (in) the column being inserted c rw (out) a real workspace vector of size k. c integer m,n,k,ldq,ldr,j double complex Q(ldq,*),R(ldr,*),x(*) double precision rw(*) external zqrtv1,zqrqh,zqrot external xerbla,zcopy,zdotc,zaxpy,zdscal,dznrm2 double complex zdotc double precision dznrm2,rx integer info,i,k1 logical full c quick return if possible. if (m == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < min(m,k+1)) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call xerbla('ZQRINC',info) return end if full = k == m c insert empty column at j-th position do i = n,j,-1 call zcopy(k,R(1,i),1,R(1,i+1),1) end do c insert Q'*u into R. In the nonfull case, form also u-Q*Q'*u. if (full) then k1 = k do i = 1,k R(i,j) = zdotc(m,Q(1,i),1,x,1) end do else k1 = k + 1 c zero last row of R do i = 1,n+1 R(k1,i) = 0d0 end do call zcopy(m,x,1,Q(1,k1),1) do i = 1,k R(i,j) = zdotc(m,Q(1,i),1,Q(1,k1),1) call zaxpy(m,-R(i,j),Q(1,i),1,Q(1,k1),1) end do c get norm of the inserted column rx = dznrm2(m,Q(1,k1),1) R(k1,j) = rx if (rx == 0d0) then c in the rare case when rx is exact zero, we still need to provide c a valid orthogonal unit vector. The details are boring, so handle c that elsewhere. call zgqvec(m,k,Q,ldq,Q(1,k1)) else c otherwise, just normalize the added column. call zdscal(m,1d0/rx,Q(1,k1),1) end if end if c maybe we're finished. if (j > k) return c eliminate the spike. call zqrtv1(k1+1-j,R(j,j),rw) c apply rotations to R(j:k,j:n). if (j <= n) call zqrqh(k1+1-j,n+1-j,R(j,j+1),ldr,rw,R(j+1,j)) c apply rotations to Q(:,j:k). call zqrot('B',m,k1+1-j,Q(1,j),ldq,rw,R(j+1,j)) c zero spike. do i = j+1,k1 R(i,j) = 0d0 end do end subroutine qrupdate-1.1.2/src/zlup1up.f0000640035452500116100000001203211263327111014651 0ustar higheggengc Copyright (C) 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zlup1up(m,n,L,ldl,R,ldr,p,u,v,w) c purpose: updates a row-pivoted LU factorization after rank-1 modification c i.e., given an m-by-k lower-triangular matrix L with unit c diagonal, a k-by-n upper-trapezoidal matrix R, and a c permutation matrix P, where k = min(m,n), c this subroutine updates L -> L1, R -> R1 and P -> P1 so that c L is again lower unit triangular, R upper trapezoidal, c P permutation and P1'*L1*R1 = P'*L*R + u*v.'. c (real version) c arguments: c m (in) order of the matrix L. c n (in) number of columns of the matrix U. c L (io) on entry, the unit lower triangular matrix L. c on exit, the updated matrix L1. c ldl (in) the leading dimension of L. ldl >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= min(m,n). c p (in) the permutation vector representing P c u (in) the left m-vector. c v (in) the right n-vector. c w (work) a workspace vector of size m. c c REMARK: Algorithm is due to c A. Kielbasinski, H. Schwetlick, Numerische Lineare c Algebra, Verlag Harri Deutsch, 1988 c integer m,n,ldl,ldr,p(*) double complex L(ldl,*),R(ldr,*),u(*),v(*),w(*) double complex one,tmp double precision tau parameter (one = 1d0, tau = 1d-1) integer k,info,i,j,itmp external xerbla,zcopy,zaxpy,ztrsv,zgeru,zgemv c quick return if possible. k = min(m,n) if (k == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call xerbla('ZLU1UP',info) return end if c form L \ P*u. do i = 1,m w(i) = u(p(i)) end do call ztrsv('L','N','U',k,L,ldl,w,1) c if m > k = n, subtract the trailing part. if (m > k) then call zgemv('N',m-k,k,-one,L(k+1,1),ldl,w,1,one,w(k+1),1) end if c work from bottom to top do j = k-1,1,-1 if (abs(w(j)) < tau * abs(L(j+1,j)*w(j) + w(j+1))) then c need pivoting. swap j and j+1 tmp = w(j) w(j) = w(j+1) w(j+1) = tmp c update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp c update L call zswap(m-j+1,L(j,j),1,L(j,j+1),1) call zswap(j+1,L(j,1),ldl,L(j+1,1),ldl) c update R call zswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) c make L lower triangular again tmp = -L(j,j+1) call zaxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) c update R call zaxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) c update w w(j) = w(j) - tmp*w(j+1) end if c eliminate w(j+1) tmp = w(j+1)/w(j) w(j+1) = 0 c update R. call zaxpy(n-j+1,-tmp,R(j,j),ldr,R(j+1,j),ldr) c update L. call zaxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do c add a multiple of v to R call zaxpy(n,w(1),v,1,R(1,1),ldr) c forward sweep do j = 1,k-1 if (abs(R(j,j)) < tau * abs(L(j+1,j)*R(j,j) + R(j+1,j))) then c need pivoting. swap j and j+1 c update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp c update L call zswap(m-j+1,L(j,j),1,L(j,j+1),1) call zswap(j+1,L(j,1),ldl,L(j+1,1),ldl) c update R call zswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) c make L lower triangular again tmp = -L(j,j+1) call zaxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) c update R call zaxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) end if c eliminate R(j+1,j) tmp = R(j+1,j)/R(j,j) c update R. R(j+1,j) = 0d0 call zaxpy(n-j,-tmp,R(j,j+1),ldr,R(j+1,j+1),ldr) c update L. call zaxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do c if m > k = n, complete the update by updating the lower part of L. if (m > k) then call zcopy(k,v,1,w,1) call ztrsv('U','T','N',k,R,ldr,w,1) call zgeru(m-k,k,one,w(k+1),1,w,1,L(k+1,1),ldl) endif end subroutine qrupdate-1.1.2/src/sqrdec.f0000640035452500116100000000570711133034413014521 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sqrdec(m,n,k,Q,ldq,R,ldr,j,w) c purpose: updates a QR factorization after deleting c a column. 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 remains orthogonal, R1 is upper c trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], c where A = Q*R. c (real version) c arguments: 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. Must be c either k = m (full Q) or k = n < m (economical form, c basis dimension will decrease). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= k. c j (in) the position of the deleted column in R. c 1 <= j <= n. c w (o) a workspace vector of size k-j. c integer m,n,k,ldq,ldr,j real Q(ldq,*),R(ldr,*),w(*) external xerbla,scopy,sqhqr,sqrot integer info,i c quick return if possible. if (m == 0 .or. n == 0 .or. j == n) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call xerbla('SQRDEC',info) return end if c delete the j-th column. do i = j,n-1 call scopy(k,R(1,i+1),1,R(1,i),1) end do c retriangularize. if (j < k) then call sqhqr(k+1-j,n-j,R(j,j),ldr,w,R(1,n)) c apply rotations to Q. call sqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,w,R(1,n)) end if end subroutine qrupdate-1.1.2/src/zqrder.f0000640035452500116100000000536711714050540014555 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zqrder(m,n,Q,ldq,R,ldr,j,w,rw) c purpose: updates a QR factorization after deleting a row. c i.e., given an m-by-m unitary matrix Q, an m-by-n c upper trapezoidal matrix R and index j in the range c 1:m, this subroutine updates Q ->Q1 and an R -> R1 c so that Q1 is again unitary, R1 upper trapezoidal, c and Q1*R1 = [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. c (complex version) c c arguments: c m (in) number of rows of the matrix Q. c n (in) number of columns of the matrix R. c Q (io) on entry, the unitary matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= m. c j (in) the position of the deleted row. c w (out) a workspace vector of size m. c rw (out) a real workspace vector of size m. c integer m,n,j,ldq,ldr double complex Q(ldq,*),R(ldr,*),w(*) double precision rw(*) external xerbla,zcopy,zqrtv1,zqrot,zqrqh integer info,i,k c quick return if possible if (m == 1) return c check arguments info = 0 if (m < 1) then info = 1 else if (j < 1 .or. j > m) then info = 7 end if if (info /= 0) then call xerbla('ZQRDER',info) return end if c eliminate Q(j,2:m). do k = 1,m w(k) = conjg(Q(j,k)) end do call zqrtv1(m,w,rw) c apply rotations to Q. call zqrot('B',m,m,Q,ldq,rw,w(2)) c form Q1. do k = 1,m-1 if (j > 1) call zcopy(j-1,Q(1,k+1),1,Q(1,k),1) if (j < m) call zcopy(m-j,Q(j+1,k+1),1,Q(j,k),1) end do c apply rotations to R. call zqrqh(m,n,R,ldr,rw,w(2)) c form R1. do k = 1,n do i = 1,m-1 R(i,k) = R(i+1,k) end do end do end subroutine qrupdate-1.1.2/src/dqrdec.f0000640035452500116100000000572311133034413014500 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dqrdec(m,n,k,Q,ldq,R,ldr,j,w) c purpose: updates a QR factorization after deleting c a column. 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 remains orthogonal, R1 is upper c trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], c where A = Q*R. c (real version) c arguments: 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. Must be c either k = m (full Q) or k = n < m (economical form, c basis dimension will decrease). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= k. c j (in) the position of the deleted column in R. c 1 <= j <= n. c w (o) a workspace vector of size k-j. c integer m,n,k,ldq,ldr,j double precision Q(ldq,*),R(ldr,*),w(*) external xerbla,dcopy,dqhqr,dqrot integer info,i c quick return if possible. if (m == 0 .or. n == 0 .or. j == n) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call xerbla('DQRDEC',info) return end if c delete the j-th column. do i = j,n-1 call dcopy(k,R(1,i+1),1,R(1,i),1) end do c retriangularize. if (j < k) then call dqhqr(k+1-j,n-j,R(j,j),ldr,w,R(1,n)) c apply rotations to Q. call dqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,w,R(1,n)) end if end subroutine qrupdate-1.1.2/src/cqrdec.f0000640035452500116100000000573311133034413014500 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cqrdec(m,n,k,Q,ldq,R,ldr,j,rw) c purpose: updates a QR factorization after deleting c a column. 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 remains unitary, R1 is upper c trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], c where A = Q*R. c (complex version) c arguments: 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. Must be c either k = m (full Q) or k = n < m (economical form, c basis dimension will decrease). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= k. c j (in) the position of the deleted column in R. c 1 <= j <= n. c rw (o) a real workspace vector of size k-j. c integer m,n,k,ldq,ldr,j complex Q(ldq,*),R(ldr,*) real rw(*) external xerbla,ccopy,cqhqr,cqrot integer info,i c quick return if possible. if (m == 0 .or. n == 0 .or. j == n) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call xerbla('CQRDEC',info) return end if c delete the j-th column. do i = j,n-1 call ccopy(k,R(1,i+1),1,R(1,i),1) end do c retriangularize. if (j < k) then call cqhqr(k+1-j,n-j,R(j,j),ldr,rw,R(1,n)) c apply rotations to Q. call cqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,rw,R(1,n)) end if end subroutine qrupdate-1.1.2/src/zlu1up.f0000640035452500116100000000642511263327111014502 0ustar higheggengc Copyright (C) 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zlu1up(m,n,L,ldl,R,ldr,u,v) c purpose: updates an LU factorization after rank-1 modification c i.e., given an m-by-k lower-triangular matrix L with unit c diagonal and a k-by-n upper-trapezoidal matrix R, c where k = min(m,n), c this subroutine updates L -> L1 and R -> R1 so that c L is again lower unit triangular, R upper trapezoidal, c and L1*R1 = L*R + u*v.'. c (complex version) c arguments: c m (in) order of the matrix L. c n (in) number of columns of the matrix U. c L (io) on entry, the unit lower triangular matrix L. c on exit, the updated matrix L1. c ldl (in) the leading dimension of L. ldl >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= min(m,n). c u (io) the left m-vector. On exit, if k < m, u is destroyed. c v (io) the right n-vector. On exit, v is destroyed. c c REMARK: Algorithm is due to c J. Bennett: Triangular factors of modified matrices, c Numerische Mathematik, 7 (1965) c integer m,n,ldl,ldr double complex L(ldl,*),R(ldr,*),u(*),v(*) double complex ui,vi integer k,info,i,j external xerbla c quick return if possible. k = min(m,n) if (k == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call xerbla('ZLU1UP',info) return end if c The Bennett algorithm, modified for column-major access. c The leading part. do i = 1,k c prefetch ui = u(i) vi = v(i) c delayed R update do j = 1,i-1 R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do c diagonal update R(i,i) = R(i,i) + ui*vi vi = vi/R(i,i) c L update do j = i+1,m u(j) = u(j) - ui*L(j,i) L(j,i) = L(j,i) + u(j)*vi end do u(i) = ui v(i) = vi end do c Finish the trailing part of R if needed. do i = k+1,n vi = v(i) do j = 1,k R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do v(i) = vi end do end subroutine qrupdate-1.1.2/src/zch1dn.f0000640035452500116100000000565111133034413014425 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zch1dn(n,R,ldr,u,rw,info) c purpose: given an upper triangular matrix R that is a Cholesky c factor of a hermitian positive definite matrix A, i.e. c A = R'*R, this subroutine downdates R -> R1 so that c R1'*R1 = A - u*u' c (complex version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c u (io) the vector determining the rank-1 update c on exit, u contains the reflector sines c used to transform R to R1. c rw (out) cosine parts of reflectors. c c info (out) on exit, error code: c info = 0: success. c info = 1: update violates positive-definiteness. c info = 2: R is singular. c integer n,ldr double complex R(ldr,*),u(*) double precision rw(*) integer info external ztrsv,zlartg,dznrm2 double complex crho,rr,ui,t double precision dznrm2,rho integer i,j c quick return if possible. if (n == 0) return c check arguments. info = 0 if (n < 0) then info = -1 else if (ldr < n) then info = -3 end if if (info /= 0) then call xerbla('ZCH1DN',-info) return end if c check for singularity of R. do i = 1,n if (R(i,i) == 0d0) goto 20 end do c form R' \ u call ztrsv('U','C','N',n,R,ldr,u,1) rho = dznrm2(n,u,1) c check positive definiteness rho = 1 - rho**2 if (rho <= 0d0) goto 10 crho = sqrt(rho) c eliminate R' \ u do i = n,1,-1 ui = u(i) c generate next rotation call zlartg(crho,ui,rw(i),u(i),rr) crho = rr end do c apply rotations do i = n,1,-1 ui = 0d0 do j = i,1,-1 t = rw(j)*ui + u(j)*R(j,i) R(j,i) = rw(j)*R(j,i) - conjg(u(j))*ui ui = t end do end do c normal return return c error returns 10 info = 1 return 20 info = 2 return end subroutine qrupdate-1.1.2/src/cch1up.f0000640035452500116100000000370311133034413014415 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cch1up(n,R,ldr,u,w) c purpose: given an upper triangular matrix R that is a Cholesky c factor of a hermitian positive definite matrix A, i.e. c A = R'*R, this subroutine updates R -> R1 so that c R1'*R1 = A + u*u' c (complex version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c u (io) the vector determining the rank-1 update c on exit, u contains the rotation sines c used to transform R to R1. c w (out) cosine parts of rotations. c integer n,ldr complex R(ldr,*),u(*) real w(*) external clartg complex rr,ui,t integer i,j do i = 1,n c apply stored rotations, column-wise ui = conjg(u(i)) do j = 1,i-1 t = w(j)*R(j,i) + u(j)*ui ui = w(j)*ui - conjg(u(j))*R(j,i) R(j,i) = t end do c generate next rotation call clartg(R(i,i),ui,w(i),u(i),rr) R(i,i) = rr end do end subroutine qrupdate-1.1.2/src/cqr1up.f0000640035452500116100000000742511134330274014457 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cqr1up(m,n,k,Q,ldq,R,ldr,u,v,w,rw) c purpose: updates a QR factorization after rank-1 modification c i.e., given a m-by-k unitary Q and m-by-n upper c trapezoidal R, an m-vector u and n-vector v, c this subroutine updates Q -> Q1 and R -> R1 so that c Q1*R1 = Q*R + u*v', and Q1 is again unitary c and R1 upper trapezoidal. c (complex version) c arguments: 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. Must be c either k = m (full Q) or k = n < m (economical form). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) the leading dimension of Q. ldq >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R.. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= k. c u (io) the left m-vector. On exit, if k < m, u is destroyed. c v (io) the right n-vector. On exit, v is destroyed. c w (out) a workspace vector of size k. c rw (out) a real workspace vector of size k. c integer m,n,k,ldq,ldr complex Q(ldq,*),R(ldr,*),u(*),v(*),w(*) real rw(*) external cqrqh,cqhqr,cqrot,cqrtv1,caxcpy external caxpy,cdotc,scnrm2,slamch,csscal,crot complex cdotc real scnrm2,slamch,ru,ruu integer info,i logical full c quick return if possible. if (k == 0 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 endif if (info /= 0) then call xerbla('CQR1UP',info) return end if full = k == m c in the non-full case, we shall need the norm of u. if (.not.full) ru = scnrm2(m,u,1) c form Q'*u. In the non-full case, form also u - Q*Q'u. do i = 1,k w(i) = cdotc(m,Q(1,i),1,u,1) if (.not.full) call caxpy(m,-w(i),Q(1,i),1,u,1) end do c generate rotations to eliminate Q'*u. call cqrtv1(k,w,rw) c apply rotations to R. call cqrqh(k,n,R,ldr,rw,w(2)) c apply rotations to Q. call cqrot('B',m,k,Q,ldq,rw,w(2)) c update the first row of R. call caxcpy(n,w(1),v,1,R(1,1),ldr) c retriangularize R. call cqhqr(k,n,R,ldr,rw,w) c apply rotations to Q. call cqrot('F',m,min(k,n+1),Q,ldq,rw,w) c in the full case, we're finished if (full) return c compute relative residual norm ruu = scnrm2(m,u,1) ru = ru * slamch('e') if (ruu <= ru) return c update the orthogonal basis. call csscal(n,ruu,v,1) call csscal(m,1e0/ruu,u,1) call cch1up(n,R,ldr,v,rw) do i = 1,n call crot(m,Q(1,i),1,u,1,rw(i),conjg(v(i))) end do end subroutine qrupdate-1.1.2/src/dlu1up.f0000640035452500116100000000642411263327111014453 0ustar higheggengc Copyright (C) 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dlu1up(m,n,L,ldl,R,ldr,u,v) c purpose: updates an LU factorization after rank-1 modification c i.e., given an m-by-k lower-triangular matrix L with unit c diagonal and a k-by-n upper-trapezoidal matrix R, c where k = min(m,n), c this subroutine updates L -> L1 and R -> R1 so that c L is again lower unit triangular, R upper trapezoidal, c and L1*R1 = L*R + u*v.'. c (real version) c arguments: c m (in) order of the matrix L. c n (in) number of columns of the matrix U. c L (io) on entry, the unit lower triangular matrix L. c on exit, the updated matrix L1. c ldl (in) the leading dimension of L. ldl >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= min(m,n). c u (io) the left m-vector. On exit, if k < m, u is destroyed. c v (io) the right n-vector. On exit, v is destroyed. c c REMARK: Algorithm is due to c J. Bennett: Triangular factors of modified matrices, c Numerische Mathematik, 7 (1965) c integer m,n,ldl,ldr double precision L(ldl,*),R(ldr,*),u(*),v(*) double precision ui,vi integer k,info,i,j external xerbla c quick return if possible. k = min(m,n) if (k == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call xerbla('DLU1UP',info) return end if c The Bennett algorithm, modified for column-major access. c The leading part. do i = 1,k c prefetch ui = u(i) vi = v(i) c delayed R update do j = 1,i-1 R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do c diagonal update R(i,i) = R(i,i) + ui*vi vi = vi/R(i,i) c L update do j = i+1,m u(j) = u(j) - ui*L(j,i) L(j,i) = L(j,i) + u(j)*vi end do u(i) = ui v(i) = vi end do c Finish the trailing part of R if needed. do i = k+1,n vi = v(i) do j = 1,k R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do v(i) = vi end do end subroutine qrupdate-1.1.2/src/schinx.f0000640035452500116100000000576411133034413014537 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine schinx(n,R,ldr,j,u,w,info) c purpose: given an upper triangular matrix R that is a Cholesky 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 = A1, A1(jj,jj) = A, A(j,:) = u', A(:,j) = u, c jj = [1:j-1,j+1:n+1]. c (real version) c arguments: c n (in) the order of matrix R. c R (io) on entry, the original upper trapezoidal matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= n+1. c j (in) the position of the inserted row/column c u (io) on entry, the inserted row/column. c on exit, u is destroyed. c w (out) workspace vector of size n+1. c info (out) on exit, error code: c info = 1: update violates positive-definiteness. c info = 2: R is singular. c integer n,j,ldr,info real R(ldr,*),u(*),w(*) external xerbla,scopy,snrm2,strsv,sqrtv1,sqrqh real snrm2,t,rho integer i c check arguments info = 0 if (n < 0) then info = -1 else if (j < 1 .or. j > n+1) then info = -4 end if if (info /= 0) then call xerbla('SCHINX',-info) return end if c shift vector. t = u(j) do i = j,n u(i) = u(i+1) end do c check for singularity of R. do i = 1,n if (R(i,i) == 0e0) goto 20 end do c form R' \ u call strsv('U','T','N',n,R,ldr,u,1) rho = snrm2(n,u,1) c check positive definiteness. rho = t - rho**2 if (rho <= 0e0) goto 10 c shift columns do i = n,j,-1 call scopy(i,R(1,i),1,R(1,i+1),1) R(i+1,i+1) = 0e0 end do call scopy(n,u,1,R(1,j),1) R(n+1,j) = sqrt(rho) c retriangularize if (j < n+1) then c eliminate the introduced spike. call sqrtv1(n+2-j,R(j,j),w) c apply rotations to R call sqrqh(n+2-j,n+1-j,R(j,j+1),ldr,w,R(j+1,j)) c zero spike. do i = j+1,n+1 R(i,j) = 0e0 end do end if c normal return. return c error returns. 10 info = 1 return 20 info = 2 return end subroutine qrupdate-1.1.2/src/zqrdec.f0000640035452500116100000000575711133034413014535 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zqrdec(m,n,k,Q,ldq,R,ldr,j,rw) c purpose: updates a QR factorization after deleting c a column. 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 remains unitary, R1 is upper c trapezoidal, and Q1*R1 = [A(:,1:j-1) A(:,j+1:n)], c where A = Q*R. c (complex version) c arguments: 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. Must be c either k = m (full Q) or k = n < m (economical form, c basis dimension will decrease). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= k. c j (in) the position of the deleted column in R. c 1 <= j <= n. c rw (o) a real workspace vector of size k-j. c integer m,n,k,ldq,ldr,j double complex Q(ldq,*),R(ldr,*) double precision rw(*) external xerbla,zcopy,zqhqr,zqrot integer info,i c quick return if possible. if (m == 0 .or. n == 0 .or. j == n) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call xerbla('ZQRDEC',info) return end if c delete the j-th column. do i = j,n-1 call zcopy(k,R(1,i+1),1,R(1,i),1) end do c retriangularize. if (j < k) then call zqhqr(k+1-j,n-j,R(j,j),ldr,rw,R(1,n)) c apply rotations to Q. call zqrot('F',m,min(k,n)+1-j,Q(1,j),ldq,rw,R(1,n)) end if end subroutine qrupdate-1.1.2/src/Makefile0000640035452500116100000000546111325314425014535 0ustar higheggeng# Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic # # Author: Jaroslav Hajek # # This file is part of qrupdate. # # qrupdate is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this software; see the file COPYING. If not, see # . # include ../Makeconf SRC = caxcpy.f cch1dn.f cch1up.f cchdex.f cchinx.f cchshx.f cgqvec.f \ cqhqr.f cqr1up.f cqrdec.f cqrder.f cqrinc.f cqrinr.f cqrot.f cqrqh.f \ cqrshc.f cqrtv1.f dch1dn.f dch1up.f dchdex.f dchinx.f dchshx.f \ dgqvec.f dqhqr.f dqr1up.f dqrdec.f dqrder.f dqrinc.f dqrinr.f dqrot.f \ dqrqh.f dqrshc.f dqrtv1.f sch1dn.f sch1up.f schdex.f schinx.f schshx.f \ sgqvec.f sqhqr.f sqr1up.f sqrdec.f sqrder.f sqrinc.f sqrinr.f sqrot.f \ sqrqh.f sqrshc.f sqrtv1.f zaxcpy.f zch1dn.f zch1up.f zchdex.f zchinx.f \ zchshx.f zgqvec.f zqhqr.f zqr1up.f zqrdec.f zqrder.f zqrinc.f zqrinr.f \ zqrot.f zqrqh.f zqrshc.f zqrtv1.f \ clu1up.f dlu1up.f slu1up.f zlu1up.f \ clup1up.f dlup1up.f slup1up.f zlup1up.f OBJS = $(SRC:%.f=%.o) lib: ../libqrupdate.a ifeq ($(shell uname),Darwin) SOEXT=.dylib else SOEXT=.so endif solib: ../libqrupdate$(SOEXT) ../libqrupdate.a: $(OBJS) ar -cr $@ $(OBJS) ../libqrupdate.so: $(OBJS) $(FC) $(FFLAGS) -shared -o $@ -Wl,-soname=libqrupdate.so.$(MAJOR) $(OBJS) \ $(BLAS) $(LAPACK) ../libqrupdate.dylib: $(OBJS) $(FC) $(FFLAGS) $(LDFLAGS) -dynamiclib -o $@ -install_name $(PREFIX)/$(LIBDIR)/libqrupdate.$(MAJOR).dylib $(OBJS) \ $(BLAS) $(LAPACK) $(OBJS): %.o: %.f $(FC) $(FFLAGS) $(FPICFLAGS) -c $< clean: rm -f $(OBJS) install: install-shlib install-staticlib install-shlib: ../libqrupdate$(SOEXT) install-lib$(SOEXT) install-lib.so: install -D -m644 ../libqrupdate.so $(DESTDIR)$(PREFIX)/$(LIBDIR)/libqrupdate.so.$(VERSION) ln -s libqrupdate.so.$(VERSION) $(DESTDIR)$(PREFIX)/$(LIBDIR)/libqrupdate.so.$(MAJOR) ln -s libqrupdate.so.$(VERSION) $(DESTDIR)$(PREFIX)/$(LIBDIR)/libqrupdate.so install-lib.dylib: install -D -m644 ../libqrupdate.dylib $(DESTDIR)$(PREFIX)/$(LIBDIR)/libqrupdate.$(VERSION).dylib ln -s libqrupdate.$(VERSION).dylib $(DESTDIR)$(PREFIX)/$(LIBDIR)/libqrupdate.$(MAJOR).dylib ln -s libqrupdate.$(VERSION).dylib $(DESTDIR)$(PREFIX)/$(LIBDIR)/libqrupdate.dylib install-staticlib: ../libqrupdate.a install -D -m644 ../libqrupdate.a $(DESTDIR)$(PREFIX)/$(LIBDIR)/libqrupdate.a qrupdate-1.1.2/src/dqrot.f0000640035452500116100000000417211131630410014361 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dqrot(dir,m,n,Q,ldq,c,s) c purpose: Apply a sequence of inv. rotations from right c c arguments: c dir (in) if 'B' or 'b', rotations are applied from backwards c if 'F' or 'f', from forwards. c m (in) number of rows of matrix Q c n (in) number of columns of the matrix Q c Q (io) on entry, the matrix Q c on exit, the updated matrix Q1 c ldq (in) the leading dimension of Q c c (in) n-1 rotation cosines c s (in) n-1 rotation sines c character dir integer m,n,ldq double precision Q(ldq,*),c(*),s(*) external drot,lsame logical lsame,fwd integer info,i c quick return if possible if (m == 0 .or. n == 0 .or. n == 1) return c check arguments. info = 0 fwd = lsame(dir,'F') if (.not.(fwd .or. lsame(dir,'B'))) then info = 1 else if (m < 0) then info = 2 else if (n < 0) then info = 3 else if (ldq < m) then info = 5 end if if (info /= 0) then call xerbla('DQROT',info) return end if if (fwd) then do i = 1,n-1 call drot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) end do else do i = n-1,1,-1 call drot(m,Q(1,i),1,Q(1,i+1),1,c(i),s(i)) end do end if end subroutine qrupdate-1.1.2/src/EXPORTS0000640035452500116100000000111011263327111014144 0ustar higheggengcaxcpy_ cch1dn_ cch1up_ cchdex_ cchinx_ cchshx_ cgqvec_ cqhqr_ clu1up_ clup1up_ cqr1up_ cqrdec_ cqrder_ cqrinc_ cqrinr_ cqrot_ cqrqh_ cqrshc_ cqrtv1_ dch1dn_ dch1up_ dchdex_ dchinx_ dchshx_ dgqvec_ dlu1up_ dlup1up_ dqhqr_ dqr1up_ dqrdec_ dqrder_ dqrinc_ dqrinr_ dqrot_ dqrqh_ dqrshc_ dqrtv1_ sch1dn_ sch1up_ schdex_ schinx_ schshx_ sgqvec_ slu1up_ slup1up_ sqhqr_ sqr1up_ sqrdec_ sqrder_ sqrinc_ sqrinr_ sqrot_ sqrqh_ sqrshc_ sqrtv1_ zaxcpy_ zch1dn_ zch1up_ zchdex_ zchinx_ zchshx_ zgqvec_ zlu1up_ zlup1up_ zqhqr_ zqr1up_ zqrdec_ zqrder_ zqrinc_ zqrinr_ zqrot_ zqrqh_ zqrshc_ zqrtv1_ qrupdate-1.1.2/src/dqrder.f0000640035452500116100000000524111714050540014516 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dqrder(m,n,Q,ldq,R,ldr,j,w) c purpose: updates a QR factorization after deleting a row. c i.e., given an m-by-m orthogonal matrix Q, an m-by-n c upper trapezoidal matrix R and index j in the range c 1:m, this subroutine updates Q ->Q1 and an R -> R1 c so that Q1 is again orthogonal, R1 upper trapezoidal, c and Q1*R1 = [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. c (real version) c c arguments: c m (in) number of rows of the matrix Q. c n (in) number of columns of the matrix R. c Q (io) on entry, the orthogonal matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= m. c j (in) the position of the deleted row. c w (out) a workspace vector of size 2*m. c integer m,n,j,ldq,ldr double precision Q(ldq,*),R(ldr,*),w(*) external xerbla,dcopy,dqrtv1,dqrot,dqrqh integer info,i,k c quick return if possible if (m == 1) return c check arguments info = 0 if (m < 1) then info = 1 else if (j < 1 .or. j > m) then info = 7 end if if (info /= 0) then call xerbla('DQRDER',info) return end if c eliminate Q(j,2:m). call dcopy(m,Q(j,1),ldq,w,1) call dqrtv1(m,w,w(m+1)) c apply rotations to Q. call dqrot('B',m,m,Q,ldq,w(m+1),w(2)) c form Q1. do k = 1,m-1 if (j > 1) call dcopy(j-1,Q(1,k+1),1,Q(1,k),1) if (j < m) call dcopy(m-j,Q(j+1,k+1),1,Q(j,k),1) end do c apply rotations to R. call dqrqh(m,n,R,ldr,w(m+1),w(2)) c form R1. do k = 1,n do i = 1,m-1 R(i,k) = R(i+1,k) end do end do end subroutine qrupdate-1.1.2/src/cqrot.f0000640035452500116100000000421211131630410014353 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cqrot(dir,m,n,Q,ldq,c,s) c purpose: Apply a sequence of inv. rotations from right c c arguments: c dir (in) if 'B' or 'b', rotations are applied from backwards c if 'F' or 'f', from forwards. c m (in) number of rows of matrix Q c n (in) number of columns of the matrix Q c Q (io) on entry, the matrix Q c on exit, the updated matrix Q1 c ldq (in) the leading dimension of Q c c (in) n-1 rotation cosines c s (in) n-1 rotation sines c character dir integer m,n,ldq complex Q(ldq,*),s(*) real c(*) external crot,lsame logical lsame,fwd integer info,i c quick return if possible if (m == 0 .or. n == 0 .or. n == 1) return c check arguments. info = 0 fwd = lsame(dir,'F') if (.not.(fwd .or. lsame(dir,'B'))) then info = 1 else if (m < 0) then info = 2 else if (n < 0) then info = 3 else if (ldq < m) then info = 5 end if if (info /= 0) then call xerbla('CQROT',info) return end if if (fwd) then do i = 1,n-1 call crot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) end do else do i = n-1,1,-1 call crot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) end do end if end subroutine qrupdate-1.1.2/src/clu1up.f0000640035452500116100000000640611263327111014452 0ustar higheggengc Copyright (C) 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine clu1up(m,n,L,ldl,R,ldr,u,v) c purpose: updates an LU factorization after rank-1 modification c i.e., given an m-by-k lower-triangular matrix L with unit c diagonal and a k-by-n upper-trapezoidal matrix R, c where k = min(m,n), c this subroutine updates L -> L1 and R -> R1 so that c L is again lower unit triangular, R upper trapezoidal, c and L1*R1 = L*R + u*v.'. c (complex version) c arguments: c m (in) order of the matrix L. c n (in) number of columns of the matrix U. c L (io) on entry, the unit lower triangular matrix L. c on exit, the updated matrix L1. c ldl (in) the leading dimension of L. ldl >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= min(m,n). c u (io) the left m-vector. On exit, if k < m, u is destroyed. c v (io) the right n-vector. On exit, v is destroyed. c c REMARK: Algorithm is due to c J. Bennett: Triangular factors of modified matrices, c Numerische Mathematik, 7 (1965) c integer m,n,ldl,ldr complex L(ldl,*),R(ldr,*),u(*),v(*) complex ui,vi integer k,info,i,j external xerbla c quick return if possible. k = min(m,n) if (k == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call xerbla('CLU1UP',info) return end if c The Bennett algorithm, modified for column-major access. c The leading part. do i = 1,k c prefetch ui = u(i) vi = v(i) c delayed R update do j = 1,i-1 R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do c diagonal update R(i,i) = R(i,i) + ui*vi vi = vi/R(i,i) c L update do j = i+1,m u(j) = u(j) - ui*L(j,i) L(j,i) = L(j,i) + u(j)*vi end do u(i) = ui v(i) = vi end do c Finish the trailing part of R if needed. do i = k+1,n vi = v(i) do j = 1,k R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do v(i) = vi end do end subroutine qrupdate-1.1.2/src/slup1up.f0000640035452500116100000001175511263327111014655 0ustar higheggengc Copyright (C) 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine slup1up(m,n,L,ldl,R,ldr,p,u,v,w) c purpose: updates a row-pivoted LU factorization after rank-1 modification c i.e., given an m-by-k lower-triangular matrix L with unit c diagonal, a k-by-n upper-trapezoidal matrix R, and a c permutation matrix P, where k = min(m,n), c this subroutine updates L -> L1, R -> R1 and P -> P1 so that c L is again lower unit triangular, R upper trapezoidal, c P permutation and P1'*L1*R1 = P'*L*R + u*v.'. c (real version) c arguments: c m (in) order of the matrix L. c n (in) number of columns of the matrix U. c L (io) on entry, the unit lower triangular matrix L. c on exit, the updated matrix L1. c ldl (in) the leading dimension of L. ldl >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= min(m,n). c p (in) the permutation vector representing P c u (in) the left m-vector. c v (in) the right n-vector. c w (work) a workspace vector of size m. c c REMARK: Algorithm is due to c A. Kielbasinski, H. Schwetlick, Numerische Lineare c Algebra, Verlag Harri Deutsch, 1988 c integer m,n,ldl,ldr,p(*) real L(ldl,*),R(ldr,*),u(*),v(*),w(*) real one,tau,tmp parameter (one = 1e0, tau = 1e-1) integer k,info,i,j,itmp external xerbla,scopy,saxpy,strsv,sger,sgemv c quick return if possible. k = min(m,n) if (k == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call xerbla('SLU1UP',info) return end if c form L \ P*u. do i = 1,m w(i) = u(p(i)) end do call strsv('L','N','U',k,L,ldl,w,1) c if m > k = n, subtract the trailing part. if (m > k) then call sgemv('N',m-k,k,-one,L(k+1,1),ldl,w,1,one,w(k+1),1) end if c work from bottom to top do j = k-1,1,-1 if (abs(w(j)) < tau * abs(L(j+1,j)*w(j) + w(j+1))) then c need pivoting. swap j and j+1 tmp = w(j) w(j) = w(j+1) w(j+1) = tmp c update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp c update L call sswap(m-j+1,L(j,j),1,L(j,j+1),1) call sswap(j+1,L(j,1),ldl,L(j+1,1),ldl) c update R call sswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) c make L lower triangular again tmp = -L(j,j+1) call saxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) c update R call saxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) c update w w(j) = w(j) - tmp*w(j+1) end if c eliminate w(j+1) tmp = w(j+1)/w(j) w(j+1) = 0 c update R. call saxpy(n-j+1,-tmp,R(j,j),ldr,R(j+1,j),ldr) c update L. call saxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do c add a multiple of v to R call saxpy(n,w(1),v,1,R(1,1),ldr) c forward sweep do j = 1,k-1 if (abs(R(j,j)) < tau * abs(L(j+1,j)*R(j,j) + R(j+1,j))) then c need pivoting. swap j and j+1 c update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp c update L call sswap(m-j+1,L(j,j),1,L(j,j+1),1) call sswap(j+1,L(j,1),ldl,L(j+1,1),ldl) c update R call sswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) c make L lower triangular again tmp = -L(j,j+1) call saxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) c update R call saxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) end if c eliminate R(j+1,j) tmp = R(j+1,j)/R(j,j) c update R. R(j+1,j) = 0e0 call saxpy(n-j,-tmp,R(j,j+1),ldr,R(j+1,j+1),ldr) c update L. call saxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do c if m > k = n, complete the update by updating the lower part of L. if (m > k) then call scopy(k,v,1,w,1) call strsv('U','T','N',k,R,ldr,w,1) call sger(m-k,k,one,w(k+1),1,w,1,L(k+1,1),ldl) endif end subroutine qrupdate-1.1.2/src/dqrshc.f0000640035452500116100000000744611133034413014526 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dqrshc(m,n,k,Q,ldq,R,ldr,i,j,w) 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 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 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. c (real version) c arguments: 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 Q1, and rows of R1. Must be c either k = m (full Q) or k = n <= m (economical form). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= k. c i (in) the first index determining the range (see above) c j (in) the second index determining the range (see above) c w (o) a workspace vector of size 2*k. c integer m,n,k,ldq,ldr,i,j double precision Q(ldq,*),R(ldr,*),w(*) external xerbla,dcopy,dqrtv1,dqrqh,dqhqr integer info,jj,kk,l c quick return if possible. if (m == 0 .or. n == 1) return info = 0 c check arguments. if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (i < 1 .or. i > n) then info = 6 else if (j < 1 .or. j > n) then info = 7 end if if (info /= 0) then call xerbla('DQRSHC',info) return end if if (i < j) then c shift columns call dcopy(k,R(1,i),1,w,1) do l = i,j-1 call dcopy(k,R(1,l+1),1,R(1,l),1) end do call dcopy(k,w,1,R(1,j),1) c retriangularize if (i < k) then kk = min(k,j) call dqhqr(kk+1-i,n+1-i,R(i,i),ldr,w(k+1),w) c apply rotations to Q. call dqrot('F',m,kk+1-i,Q(1,i),ldq,w(k+1),w) end if else if (j < i) then c shift columns call dcopy(k,R(1,i),1,w,1) do l = i,j+1,-1 call dcopy(k,R(1,l-1),1,R(1,l),1) end do call dcopy(k,w,1,R(1,j),1) c retriangularize if (j < k) then jj = min(j+1,n) kk = min(k,i) c eliminate the introduced spike. call dqrtv1(kk+1-j,R(j,j),w(k+1)) c apply rotations to R call dqrqh(kk+1-j,n-j,R(j,jj),ldr,w(k+1),R(j+1,j)) c apply rotations to Q call dqrot('B',m,kk+1-j,Q(1,j),ldq,w(k+1),R(j+1,j)) c zero spike. do l = j+1,kk R(l,j) = 0d0 end do end if end if end subroutine qrupdate-1.1.2/src/zchinx.f0000640035452500116100000000631611133034413014540 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zchinx(n,R,ldr,j,u,rw,info) c purpose: given an upper triangular matrix R that is a Cholesky c factor of a hermitian positive definite matrix A, i.e. c A = R'*R, this subroutine updates R -> R1 so that c R1'*R1 = A1, A1(jj,jj) = A, A(j,:) = u', A(:,j) = u, c jj = [1:j-1,j+1:n+1]. c (complex version) c arguments: c n (in) the order of matrix R. c R (io) on entry, the original upper trapezoidal matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= n+1. c j (in) the position of the inserted row/column c u (io) on entry, the inserted row/column. c on exit, u is destroyed. c rw (out) real workspace vector of size n+1. c info (out) on exit, error code: c info = 1: update violates positive-definiteness. c info = 2: R is singular. c info = 3: diagonal element of u is not real. c integer n,j,ldr,info double complex R(ldr,*),u(*),rw(*) external xerbla,zcopy,dznrm2,ztrsv,zqrtv1,zqrqh double complex t double precision dznrm2,rho integer i c check arguments info = 0 if (n < 0) then info = -1 else if (j < 1 .or. j > n+1) then info = -4 end if if (info /= 0) then call xerbla('ZCHINX',info) return end if c shift vector. t = u(j) do i = j,n u(i) = u(i+1) end do c the diagonal element must be real. if (imag(t) /= 0d0) goto 30 c check for singularity of R. do i = 1,n if (R(i,i) == 0d0) goto 20 end do c form R' \ u call ztrsv('U','C','N',n,R,ldr,u,1) rho = dznrm2(n,u,1) c check positive definiteness. rho = t - rho**2 if (rho <= 0d0) goto 10 c shift columns do i = n,j,-1 call zcopy(i,R(1,i),1,R(1,i+1),1) R(i+1,i+1) = 0d0 end do call zcopy(n,u,1,R(1,j),1) R(n+1,j) = sqrt(rho) c retriangularize if (j < n+1) then c eliminate the introduced spike. call zqrtv1(n+2-j,R(j,j),rw) c apply rotations to R call zqrqh(n+2-j,n+1-j,R(j,j+1),ldr,rw,R(j+1,j)) c zero spike. do i = j+1,n+1 R(i,j) = 0d0 end do end if c normal return. return c error returns. 10 info = 1 return 20 info = 2 return 30 info = 3 return end subroutine qrupdate-1.1.2/src/zqrshc.f0000640035452500116100000000753611133034413014554 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zqrshc(m,n,k,Q,ldq,R,ldr,i,j,w,rw) c purpose: updates a QR factorization after circular shift of c columns. 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 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. c (complex version) c arguments: 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 Q1, and rows of R1. Must be c either k = m (full Q) or k = n <= m (economical form). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= k. c i (in) the first index determining the range (see above) c j (in) the second index determining the range (see above) c w (o) a workspace vector of size k. c rw (o) a real workspace vector of size k. c integer m,n,k,ldq,ldr,i,j double complex Q(ldq,*),R(ldr,*),w(*) double precision rw(*) external xerbla,zcopy,zqrtv1,zqrqh,zqhqr integer info,jj,kk,l c quick return if possible. if (m == 0 .or. n == 1) return info = 0 c check arguments. if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (i < 1 .or. i > n) then info = 6 else if (j < 1 .or. j > n) then info = 7 end if if (info /= 0) then call xerbla('ZQRSHC',info) return end if if (i < j) then c shift columns call zcopy(k,R(1,i),1,w,1) do l = i,j-1 call zcopy(k,R(1,l+1),1,R(1,l),1) end do call zcopy(k,w,1,R(1,j),1) c retriangularize if (i < k) then kk = min(k,j) call zqhqr(kk+1-i,n+1-i,R(i,i),ldr,rw,w) c apply rotations to Q. call zqrot('F',m,kk+1-i,Q(1,i),ldq,rw,w) end if else if (j < i) then c shift columns call zcopy(k,R(1,i),1,w,1) do l = i,j+1,-1 call zcopy(k,R(1,l-1),1,R(1,l),1) end do call zcopy(k,w,1,R(1,j),1) c retriangularize if (j < k) then jj = min(j+1,n) kk = min(k,i) c eliminate the introduced spike. call zqrtv1(kk+1-j,R(j,j),rw) c apply rotations to R call zqrqh(kk+1-j,n-j,R(j,jj),ldr,rw,R(j+1,j)) c apply rotations to Q call zqrot('B',m,kk+1-j,Q(1,j),ldq,rw,R(j+1,j)) c zero spike. do l = j+1,kk R(l,j) = 0d0 end do end if end if end subroutine qrupdate-1.1.2/src/sqrder.f0000640035452500116100000000522511714050540014537 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sqrder(m,n,Q,ldq,R,ldr,j,w) c purpose: updates a QR factorization after deleting a row. c i.e., given an m-by-m orthogonal matrix Q, an m-by-n c upper trapezoidal matrix R and index j in the range c 1:m, this subroutine updates Q ->Q1 and an R -> R1 c so that Q1 is again orthogonal, R1 upper trapezoidal, c and Q1*R1 = [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. c (real version) c c arguments: c m (in) number of rows of the matrix Q. c n (in) number of columns of the matrix R. c Q (io) on entry, the orthogonal matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= m. c j (in) the position of the deleted row. c w (out) a workspace vector of size 2*m. c integer m,n,j,ldq,ldr real Q(ldq,*),R(ldr,*),w(*) external xerbla,scopy,sqrtv1,sqrot,sqrqh integer info,i,k c quick return if possible if (m == 1) return c check arguments info = 0 if (m < 1) then info = 1 else if (j < 1 .or. j > m) then info = 7 end if if (info /= 0) then call xerbla('SQRDER',info) return end if c eliminate Q(j,2:m). call scopy(m,Q(j,1),ldq,w,1) call sqrtv1(m,w,w(m+1)) c apply rotations to Q. call sqrot('B',m,m,Q,ldq,w(m+1),w(2)) c form Q1. do k = 1,m-1 if (j > 1) call scopy(j-1,Q(1,k+1),1,Q(1,k),1) if (j < m) call scopy(m-j,Q(j+1,k+1),1,Q(j,k),1) end do c apply rotations to R. call sqrqh(m,n,R,ldr,w(m+1),w(2)) c form R1. do k = 1,n do i = 1,m-1 R(i,k) = R(i+1,k) end do end do end subroutine qrupdate-1.1.2/src/slu1up.f0000640035452500116100000000637411263327111014476 0ustar higheggengc Copyright (C) 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine slu1up(m,n,L,ldl,R,ldr,u,v) c purpose: updates an LU factorization after rank-1 modification c i.e., given an m-by-k lower-triangular matrix L with unit c diagonal and a k-by-n upper-trapezoidal matrix R, c where k = min(m,n), c this subroutine updates L -> L1 and R -> R1 so that c L is again lower unit triangular, R upper trapezoidal, c and L1*R1 = L*R + u*v.'. c (real version) c arguments: c m (in) order of the matrix L. c n (in) number of columns of the matrix U. c L (io) on entry, the unit lower triangular matrix L. c on exit, the updated matrix L1. c ldl (in) the leading dimension of L. ldl >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= min(m,n). c u (io) the left m-vector. On exit, if k < m, u is destroyed. c v (io) the right n-vector. On exit, v is destroyed. c c REMARK: Algorithm is due to c J. Bennett: Triangular factors of modified matrices, c Numerische Mathematik, 7 (1965) c integer m,n,ldl,ldr real L(ldl,*),R(ldr,*),u(*),v(*) real ui,vi integer k,info,i,j external xerbla c quick return if possible. k = min(m,n) if (k == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call xerbla('SLU1UP',info) return end if c The Bennett algorithm, modified for column-major access. c The leading part. do i = 1,k c prefetch ui = u(i) vi = v(i) c delayed R update do j = 1,i-1 R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do c diagonal update R(i,i) = R(i,i) + ui*vi vi = vi/R(i,i) c L update do j = i+1,m u(j) = u(j) - ui*L(j,i) L(j,i) = L(j,i) + u(j)*vi end do u(i) = ui v(i) = vi end do c Finish the trailing part of R if needed. do i = k+1,n vi = v(i) do j = 1,k R(j,i) = R(j,i) + u(j)*vi vi = vi - v(j)*R(j,i) end do v(i) = vi end do end subroutine qrupdate-1.1.2/src/zqrot.f0000640035452500116100000000423511131630410014407 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zqrot(dir,m,n,Q,ldq,c,s) c purpose: Apply a sequence of inv. rotations from right c c arguments: c dir (in) if 'B' or 'b', rotations are applied from backwards c if 'F' or 'f', from forwards. c m (in) number of rows of matrix Q c n (in) number of columns of the matrix Q c Q (io) on entry, the matrix Q c on exit, the updated matrix Q1 c ldq (in) the leading dimension of Q c c (in) n-1 rotation cosines c s (in) n-1 rotation sines c character dir integer m,n,ldq double complex Q(ldq,*),s(*) double precision c(*) external zrot,lsame logical lsame,fwd integer info,i c quick return if possible if (m == 0 .or. n == 0 .or. n == 1) return c check arguments. info = 0 fwd = lsame(dir,'F') if (.not.(fwd .or. lsame(dir,'B'))) then info = 1 else if (m < 0) then info = 2 else if (n < 0) then info = 3 else if (ldq < m) then info = 5 end if if (info /= 0) then call xerbla('ZQROT',info) return end if if (fwd) then do i = 1,n-1 call zrot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) end do else do i = n-1,1,-1 call zrot(m,Q(1,i),1,Q(1,i+1),1,c(i),conjg(s(i))) end do end if end subroutine qrupdate-1.1.2/src/dqrtv1.f0000640035452500116100000000301711131630410014446 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dqrtv1(n,u,w) c purpose: generates a sequence of n-1 Givens rotations that c eliminate all but the first element of a vector u. c arguments: c n (in) the length of the vector u c u (io) on entry, the vector u. c on exit, u(2:n) contains the rotation sines, u(1) c contains the remaining element. c w (o) on exit, w contains the rotation cosines. c integer n double precision u(*),w(*) external dlartg double precision rr,t integer i c quick return if possible. if (n <= 0) return rr = u(n) do i = n-1,1,-1 call dlartg(u(i),rr,w(i),u(i+1),t) rr = t end do u(1) = rr end subroutine qrupdate-1.1.2/src/dqrinr.f0000640035452500116100000000603011131630410014522 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dqrinr(m,n,Q,ldq,R,ldr,j,x,w) c purpose: updates a QR factorization after inserting a new c row. c i.e., given an m-by-m unitary matrix Q, an m-by-n c upper trapezoidal matrix R and index j in the range c 1:m+1, this subroutine updates Q -> Q1 and R -> R1 c so that Q1 is again unitary, R1 upper trapezoidal, c and Q1*R1 = [A(1:j-1,:); x; A(j:m,:)], where A = Q*R. c (real version) c arguments: c m (in) number of rows of the matrix Q. c n (in) number of columns of the matrix R. c Q (io) on entry, the unitary matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m+1. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= m+1. c j (in) the position of the new row in R1 c x (io) on entry, the row being added c on exit, x is destroyed. c w (out) a workspace vector of size min(m,n). c integer m,n,j,ldq,ldr double precision Q(ldq,*),R(ldr,*),x(*),w(*) external xerbla,dcopy,dqhqr,dqrot integer info,i,k c check arguments info = 0 if (n < 0) then info = 2 else if (j < 1 .or. j > m+1) then info = 7 end if if (info /= 0) then call xerbla('DQRINR',info) return end if c permute the columns of Q1 and rows of R1 so that c the new row ends c up being the topmost row of R1. do i = m,1,-1 if (j > 1) then call dcopy(j-1,Q(1,i),1,Q(1,i+1),1) end if Q(j,i+1) = 0d0 if (j <= m) then call dcopy(m+1-j,Q(j,i),1,Q(j+1,i+1),1) end if end do c set up the 1st column do i = 1,j-1 Q(i,1) = 0d0 end do Q(j,1) = 1d0 do i = j+1,m+1 Q(i,1) = 0d0 end do c set up the new matrix R1 do k = 1,n if (k < m) R(m+1,k) = 0d0 do i = min(m,k),1,-1 R(i+1,k) = R(i,k) end do R(1,k) = x(k) end do c retriangularize R call dqhqr(m+1,n,R,ldr,w,x) c apply rotations to Q call dqrot('F',m+1,min(m,n)+1,Q,ldq,w,x) end subroutine qrupdate-1.1.2/src/sqrtv1.f0000640035452500116100000000276711131630410014500 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sqrtv1(n,u,w) c purpose: generates a sequence of n-1 Givens rotations that c eliminate all but the first element of a vector u. c arguments: c n (in) the length of the vector u c u (io) on entry, the vector u. c on exit, u(2:n) contains the rotation sines, u(1) c contains the remaining element. c w (o) on exit, w contains the rotation cosines. c integer n real u(*),w(*) external slartg real rr,t integer i c quick return if possible. if (n <= 0) return rr = u(n) do i = n-1,1,-1 call slartg(u(i),rr,w(i),u(i+1),t) rr = t end do u(1) = rr end subroutine qrupdate-1.1.2/src/cchdex.f0000640035452500116100000000406211133034413014467 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cchdex(n,R,ldr,j,rw) c purpose: given an upper triangular matrix R that is a Cholesky c factor of a hermitian 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 (complex version) c arguments: c n (in) the order of matrix R. c R (io) on entry, the original upper trapezoidal matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= n. c j (in) the position of the deleted row/column. c rw (out) a real workspace vector of size n. c integer n,ldr,j complex R(ldr,*) real rw(*) integer info,i external xerbla,ccopy,cqhqr c quick return if possible if (n == 1) return c check arguments info = 0 if (n < 0) then info = 1 else if (j < 1 .or. j > n) then info = 4 end if if (info /= 0) then call xerbla('CCHDEX',info) return end if c delete the j-th column. do i = j,n-1 call ccopy(n,R(1,i+1),1,R(1,i),1) end do c retriangularize. if (j < n) then call cqhqr(n+1-j,n-j,R(j,j),ldr,rw,R(1,n)) end if end subroutine qrupdate-1.1.2/src/cchshx.f0000640035452500116100000000551111133034413014511 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cchshx(n,R,ldr,i,j,w,rw) c purpose: given an upper triangular matrix R that is a Cholesky 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(p,p), where 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. c (complex version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c i (in) the first index determining the range (see above). c j (in) the second index determining the range (see above). c w (o) a workspace vector of size n. c rw (o) a real workspace vector of size n. c integer n,ldr,i,j complex R(ldr,*),w(*) real rw(*) external xerbla,ccopy,cqrtv1,cqrqh,cqhqr integer info,l c quick return if possible. if (n == 0 .or. n == 1) return info = 0 c check arguments. if (n < 0) then info = 1 else if (i < 1 .or. i > n) then info = 4 else if (j < 1 .or. j > n) then info = 5 end if if (info /= 0) then call xerbla('CCHSHX',info) return end if if (i < j) then c shift columns call ccopy(n,R(1,i),1,w,1) do l = i,j-1 call ccopy(n,R(1,l+1),1,R(1,l),1) end do call ccopy(n,w,1,R(1,j),1) c retriangularize call cqhqr(n+1-i,n+1-i,R(i,i),ldr,rw,w) else if (j < i) then c shift columns call ccopy(n,R(1,i),1,w,1) do l = i,j+1,-1 call ccopy(n,R(1,l-1),1,R(1,l),1) end do call ccopy(n,w,1,R(1,j),1) c eliminate the introduced spike. call cqrtv1(n+1-j,R(j,j),rw) c apply rotations to R call cqrqh(n+1-j,n-j,R(j,j+1),ldr,rw,R(j+1,j)) c zero spike. do l = j+1,n R(l,j) = 0e0 end do end if end subroutine qrupdate-1.1.2/src/dqr1up.f0000640035452500116100000000733511134330274014460 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dqr1up(m,n,k,Q,ldq,R,ldr,u,v,w) c purpose: updates a QR factorization after rank-1 modification c i.e., given a m-by-k orthogonal Q and m-by-n upper c trapezoidal R, an m-vector u and n-vector v, c this subroutine updates Q -> Q1 and R -> R1 so that c Q1*R1 = Q*R + u*v', and Q1 is again orthonormal c and R1 upper trapezoidal. c (real version) c arguments: 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. Must be c either k = m (full Q) or k = n < m (economical form). c Q (io) on entry, the orthogonal m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) the leading dimension of Q. ldq >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R.. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= k. c u (io) the left m-vector. On exit, if k < m, u is destroyed. c v (io) the right n-vector. On exit, v is destroyed. c w (out) a workspace vector of size 2*k c integer m,n,k,ldq,ldr double precision Q(ldq,*),R(ldr,*),u(*),v(*),w(*) external dqrqh,dqhqr,dqrot,dqrtv1 external daxpy,ddot,dnrm2,dlamch,dscal,drot double precision ddot,dnrm2,dlamch,ru,ruu integer info,i logical full c quick return if possible. if (k == 0 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 endif if (info /= 0) then call xerbla('DQR1UP',info) return end if full = k == m c in the non-full case, we shall need the norm of u. if (.not.full) ru = dnrm2(m,u,1) c form Q'*u. In the non-full case, form also u - Q*Q'u. do i = 1,k w(i) = ddot(m,Q(1,i),1,u,1) if (.not.full) call daxpy(m,-w(i),Q(1,i),1,u,1) end do c generate rotations to eliminate Q'*u. call dqrtv1(k,w,w(k+1)) c apply rotations to R. call dqrqh(k,n,R,ldr,w(k+1),w(2)) c apply rotations to Q. call dqrot('B',m,k,Q,ldq,w(k+1),w(2)) c update the first row of R. call daxpy(n,w(1),v,1,R(1,1),ldr) c retriangularize R. call dqhqr(k,n,R,ldr,w(k+1),w) c apply rotations to Q. call dqrot('F',m,min(k,n+1),Q,ldq,w(k+1),w) c in the full case, we're finished if (full) return c compute relative residual norm ruu = dnrm2(m,u,1) ru = ru * dlamch('e') if (ruu <= ru) return c update the orthogonal basis. call dscal(n,ruu,v,1) call dscal(m,1d0/ruu,u,1) call dch1up(n,R,ldr,v,w(k+1)) do i = 1,n call drot(m,Q(1,i),1,u,1,w(k+i),v(i)) end do end subroutine qrupdate-1.1.2/src/cqrinc.f0000640035452500116100000001022211133034413014503 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cqrinc(m,n,k,Q,ldq,R,ldr,j,x,rw) c purpose: updates a QR factorization after inserting a new c column. c i.e., given an m-by-k unitary matrix Q, an m-by-n upper c trapezoidal matrix R and index j in the range 1:n+1, c this subroutine updates the matrix Q -> Q1 and R -> R1 c so that Q1 is again unitary, R1 upper trapezoidal, and c Q1*R1 = [A(:,1:j-1); x; A(:,j:n)], where A = Q*R. c (complex version) c arguments: 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. Must be c either k = m (full Q) or k = n <= m (economical form, c basis dimension will increase). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= min(m,n+1). c j (in) the position of the new column in R1 c x (in) the column being inserted c rw (out) a real workspace vector of size k. c integer m,n,k,ldq,ldr,j complex Q(ldq,*),R(ldr,*),x(*) real rw(*) external cqrtv1,cqrqh,cqrot external xerbla,ccopy,cdotc,caxpy,csscal,scnrm2 complex cdotc real scnrm2,rx integer info,i,k1 logical full c quick return if possible. if (m == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < min(m,k+1)) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call xerbla('CQRINC',info) return end if full = k == m c insert empty column at j-th position do i = n,j,-1 call ccopy(k,R(1,i),1,R(1,i+1),1) end do c insert Q'*u into R. In the nonfull case, form also u-Q*Q'*u. if (full) then k1 = k do i = 1,k R(i,j) = cdotc(m,Q(1,i),1,x,1) end do else k1 = k + 1 c zero last row of R do i = 1,n+1 R(k1,i) = 0e0 end do call ccopy(m,x,1,Q(1,k1),1) do i = 1,k R(i,j) = cdotc(m,Q(1,i),1,Q(1,k1),1) call caxpy(m,-R(i,j),Q(1,i),1,Q(1,k1),1) end do c get norm of the inserted column rx = scnrm2(m,Q(1,k1),1) R(k1,j) = rx if (rx == 0e0) then c in the rare case when rx is exact zero, we still need to provide c a valid orthogonal unit vector. The details are boring, so handle c that elsewhere. call cgqvec(m,k,Q,ldq,Q(1,k1)) else c otherwise, just normalize the added column. call csscal(m,1e0/rx,Q(1,k1),1) end if end if c maybe we're finished. if (j > k) return c eliminate the spike. call cqrtv1(k1+1-j,R(j,j),rw) c apply rotations to R(j:k,j:n). if (j <= n) call cqrqh(k1+1-j,n+1-j,R(j,j+1),ldr,rw,R(j+1,j)) c apply rotations to Q(:,j:k). call cqrot('B',m,k1+1-j,Q(1,j),ldq,rw,R(j+1,j)) c zero spike. do i = j+1,k1 R(i,j) = 0e0 end do end subroutine qrupdate-1.1.2/src/clup1up.f0000640035452500116100000001200311263327111014620 0ustar higheggengc Copyright (C) 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine clup1up(m,n,L,ldl,R,ldr,p,u,v,w) c purpose: updates a row-pivoted LU factorization after rank-1 modification c i.e., given an m-by-k lower-triangular matrix L with unit c diagonal, a k-by-n upper-trapezoidal matrix R, and a c permutation matrix P, where k = min(m,n), c this subroutine updates L -> L1, R -> R1 and P -> P1 so that c L is again lower unit triangular, R upper trapezoidal, c P permutation and P1'*L1*R1 = P'*L*R + u*v.'. c (complex version) c arguments: c m (in) order of the matrix L. c n (in) number of columns of the matrix U. c L (io) on entry, the unit lower triangular matrix L. c on exit, the updated matrix L1. c ldl (in) the leading dimension of L. ldl >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= min(m,n). c p (in) the permutation vector representing P c u (in) the left m-vector. c v (in) the right n-vector. c w (work) a workspace vector of size m. c c REMARK: Algorithm is due to c A. Kielbasinski, H. Schwetlick, Numerische Lineare c Algebra, Verlag Harri Deutsch, 1988 c integer m,n,ldl,ldr,p(*) complex L(ldl,*),R(ldr,*),u(*),v(*),w(*) complex one,tmp real tau parameter (one = 1e0, tau = 1e-1) integer k,info,i,j,itmp external xerbla,ccopy,caxpy,ctrsv,cgeru,cgemv c quick return if possible. k = min(m,n) if (k == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call xerbla('CLU1UP',info) return end if c form L \ P*u. do i = 1,m w(i) = u(p(i)) end do call ctrsv('L','N','U',k,L,ldl,w,1) c if m > k = n, subtract the trailing part. if (m > k) then call cgemv('N',m-k,k,-one,L(k+1,1),ldl,w,1,one,w(k+1),1) end if c work from bottom to top do j = k-1,1,-1 if (abs(w(j)) < tau * abs(L(j+1,j)*w(j) + w(j+1))) then c need pivoting. swap j and j+1 tmp = w(j) w(j) = w(j+1) w(j+1) = tmp c update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp c update L call cswap(m-j+1,L(j,j),1,L(j,j+1),1) call cswap(j+1,L(j,1),ldl,L(j+1,1),ldl) c update R call cswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) c make L lower triangular again tmp = -L(j,j+1) call caxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) c update R call caxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) c update w w(j) = w(j) - tmp*w(j+1) end if c eliminate w(j+1) tmp = w(j+1)/w(j) w(j+1) = 0 c update R. call caxpy(n-j+1,-tmp,R(j,j),ldr,R(j+1,j),ldr) c update L. call caxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do c add a multiple of v to R call caxpy(n,w(1),v,1,R(1,1),ldr) c forward sweep do j = 1,k-1 if (abs(R(j,j)) < tau * abs(L(j+1,j)*R(j,j) + R(j+1,j))) then c need pivoting. swap j and j+1 c update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp c update L call cswap(m-j+1,L(j,j),1,L(j,j+1),1) call cswap(j+1,L(j,1),ldl,L(j+1,1),ldl) c update R call cswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) c make L lower triangular again tmp = -L(j,j+1) call caxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) c update R call caxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) end if c eliminate R(j+1,j) tmp = R(j+1,j)/R(j,j) c update R. R(j+1,j) = 0e0 call caxpy(n-j,-tmp,R(j,j+1),ldr,R(j+1,j+1),ldr) c update L. call caxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do c if m > k = n, complete the update by updating the lower part of L. if (m > k) then call ccopy(k,v,1,w,1) call ctrsv('U','T','N',k,R,ldr,w,1) call cgeru(m-k,k,one,w(k+1),1,w,1,L(k+1,1),ldl) endif end subroutine qrupdate-1.1.2/src/sch1dn.f0000640035452500116100000000551511133034413014415 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sch1dn(n,R,ldr,u,w,info) c purpose: given an upper triangular matrix R that is a Cholesky c factor of a hermitian positive definite matrix A, i.e. c A = R'*R, this subroutine downdates R -> R1 so that c R1'*R1 = A - u*u' c (real version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c u (io) the vector determining the rank-1 update c on exit, u contains the reflector sines c used to transform R to R1. c w (out) cosine parts of reflectors. c c info (out) on exit, error code: c info = 0: success. c info = 1: update violates positive-definiteness. c info = 2: R is singular. c integer n,ldr real R(ldr,*),u(*),w(*) integer info external strsv,slartg,snrm2 real snrm2,rho,rr,ui,t integer i,j c quick return if possible. if (n == 0) return c check arguments. info = 0 if (n < 0) then info = -1 else if (ldr < n) then info = -3 end if if (info /= 0) then call xerbla('SCH1DN',-info) return end if c check for singularity of R. do i = 1,n if (R(i,i) == 0e0) goto 20 end do c form R' \ u call strsv('U','T','N',n,R,ldr,u,1) rho = snrm2(n,u,1) c check positive definiteness rho = 1 - rho**2 if (rho <= 0e0) goto 10 rho = sqrt(rho) c eliminate R' \ u do i = n,1,-1 ui = u(i) c generate next rotation call slartg(rho,ui,w(i),u(i),rr) rho = rr end do c apply rotations do i = n,1,-1 ui = 0e0 do j = i,1,-1 t = w(j)*ui + u(j)*R(j,i) R(j,i) = w(j)*R(j,i) - u(j)*ui ui = t end do end do c normal return return c error returns 10 info = 1 return 20 info = 2 return end subroutine qrupdate-1.1.2/src/sgqvec.f0000640035452500116100000000445211131630410014521 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sgqvec(m,n,Q,ldq,u) c purpose: given an orthogonal m-by-n matrix Q, n < m, generates c a vector u such that Q'*u = 0 and norm(u) = 1. c arguments: c m (in) number of rows of matrix Q. c n (in) number of columns of matrix Q. c Q (in) the orthogonal matrix Q. c ldq (in) leading dimension of Q. c u (out) the generated vector. c integer m,n,ldq real Q(ldq,*),u(*) external sdot,saxpy,snrm2,sscal real sdot,snrm2,r integer info,i,j c quick return if possible. if (m == 0) return if (n == 0) then u(1) = 1e0 do i = 2,m u(i) = 0e0 end do return end if c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldq < m) then info = 4 end if if (info /= 0) then call xerbla('SGQVEC',info) return end if j = 1 10 continue c probe j-th canonical unit vector. do i = 1,m u(i) = 0e0 end do u(j) = 1e0 c form u - Q*Q'*u do i = 1,n r = sdot(m,Q(1,i),1,u,1) call saxpy(m,-r,Q(1,i),1,u,1) end do r = snrm2(m,u,1) if (r == 0e0) then j = j + 1 if (j > n) then c this is fatal, and in theory, it can't happen. stop 'fatal: impossible condition in DGQVEC' else j = j + 1 goto 10 end if end if call sscal(m,1e0/r,u,1) end subroutine qrupdate-1.1.2/src/dqrinc.f0000640035452500116100000001022211133034413014504 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dqrinc(m,n,k,Q,ldq,R,ldr,j,x,w) c purpose: updates a QR factorization after inserting a new c column. 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 R -> R1 so that Q1 is again orthogonal, R1 upper c trapezoidal, and Q1*R1 = [A(:,1:j-1); x; A(:,j:n)], c where A = Q*R. c (real version) c arguments: 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. Must be c either k = m (full Q) or k = n <= m (economical form, c basis dimension will increase). c Q (io) on entry, the orthogonal m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= min(m,n+1). c j (in) the position of the new column in R1 c x (in) the column being inserted c w (out) a workspace vector of size k. c integer m,n,k,ldq,ldr,j double precision Q(ldq,*),R(ldr,*),x(*),w(*) external dqrtv1,dqrqh,dqrot external xerbla,dcopy,ddot,daxpy,dscal,dnrm2 double precision ddot,dnrm2,rx integer info,i,k1 logical full c quick return if possible. if (m == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n >= m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < min(m,k+1)) then info = 7 else if (j < 1 .or. j > n+1) then info = 8 end if if (info /= 0) then call xerbla('DQRINC',info) return end if full = k == m c insert empty column at j-th position. do i = n,j,-1 call dcopy(k,R(1,i),1,R(1,i+1),1) end do c insert Q'*u into R. In the nonfull case, form also u-Q*Q'*u. if (full) then k1 = k do i = 1,k R(i,j) = ddot(m,Q(1,i),1,x,1) end do else k1 = k + 1 c zero last row of R do i = 1,n+1 R(k1,i) = 0d0 end do call dcopy(m,x,1,Q(1,k1),1) do i = 1,k R(i,j) = ddot(m,Q(1,i),1,Q(1,k1),1) call daxpy(m,-R(i,j),Q(1,i),1,Q(1,k1),1) end do c get norm of the inserted column rx = dnrm2(m,Q(1,k1),1) R(k1,j) = rx if (rx == 0d0) then c in the rare case when rx is exact zero, we still need to provide c a valid orthogonal unit vector. The details are boring, so handle c that elsewhere. call dgqvec(m,k,Q,ldq,Q(1,k1)) else c otherwise, just normalize the added column. call dscal(m,1d0/rx,Q(1,k1),1) end if end if c maybe we're finished. if (j > k) return c eliminate the spike. call dqrtv1(k1+1-j,R(j,j),w) c apply rotations to R(j:k,j:n). if (j <= n) call dqrqh(k1+1-j,n+1-j,R(j,j+1),ldr,w,R(j+1,j)) c apply rotations to Q(:,j:k). call dqrot('B',m,k1+1-j,Q(1,j),ldq,w,R(j+1,j)) c zero spike. do i = j+1,k1 R(i,j) = 0d0 end do end subroutine qrupdate-1.1.2/src/zqr1up.f0000640035452500116100000000746511134330274014512 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zqr1up(m,n,k,Q,ldq,R,ldr,u,v,w,rw) c purpose: updates a QR factorization after rank-1 modification c i.e., given a m-by-k unitary Q and m-by-n upper c trapezoidal R, an m-vector u and n-vector v, c this subroutine updates Q -> Q1 and R -> R1 so that c Q1*R1 = Q*R + u*v', and Q1 is again unitary c and R1 upper trapezoidal. c (complex version) c arguments: 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. Must be c either k = m (full Q) or k = n < m (economical form). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) the leading dimension of Q. ldq >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R.. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= k. c u (io) the left m-vector. On exit, if k < m, u is destroyed. c v (io) the right n-vector. On exit, v is destroyed. c w (out) a workspace vector of size k. c rw (out) a real workspace vector of size k. c integer m,n,k,ldq,ldr double complex Q(ldq,*),R(ldr,*),u(*),v(*),w(*) double precision rw(*) external zqrqh,zqhqr,zqrot,zqrtv1,zaxcpy external zdotc,dznrm2,dlamch,zdscal,zrot double complex zdotc double precision dznrm2,dlamch,ru,ruu integer info,i logical full c quick return if possible. if (k == 0 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (ldq < m) then info = 5 else if (ldr < k) then info = 7 endif if (info /= 0) then call xerbla('ZQR1UP',info) return end if full = k == m c in the non-full case, we shall need the norm of u. if (.not.full) ru = dznrm2(m,u,1) c form Q'*u. In the non-full case, form also u - Q*Q'u. do i = 1,k w(i) = zdotc(m,Q(1,i),1,u,1) if (.not.full) call zaxpy(m,-w(i),Q(1,i),1,u,1) end do c generate rotations to eliminate Q'*u. call zqrtv1(k,w,rw) c apply rotations to R. call zqrqh(k,n,R,ldr,rw,w(2)) c apply rotations to Q. call zqrot('B',m,k,Q,ldq,rw,w(2)) c update the first row of R. call zaxcpy(n,w(1),v,1,R(1,1),ldr) c retriangularize R. call zqhqr(k,n,R,ldr,rw,w) c apply rotations to Q. call zqrot('F',m,min(k,n+1),Q,ldq,rw,w) c in the full case, we're finished if (full) return c compute relative residual norm ruu = dznrm2(m,u,1) ru = ru * dlamch('e') if (ruu <= ru) return c update the orthogonal basis. call zdscal(n,ruu,v,1) call zdscal(m,1d0/ruu,u,1) call zch1up(n,R,ldr,v,rw) do i = 1,n call zrot(m,Q(1,i),1,u,1,rw(i),conjg(v(i))) end do end subroutine qrupdate-1.1.2/src/zqrtv1.f0000640035452500116100000000304211131630410014472 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zqrtv1(n,u,w) c purpose: generates a sequence of n-1 Givens rotations that c eliminate all but the first element of a vector u. c arguments: c n (in) the length of the vector u c u (io) on entry, the vector u. c on exit, u(2:n) contains the rotation sines, u(1) c contains the remaining element. c w (o) on exit, w contains the rotation cosines. c integer n double complex u(*) double precision w(*) external zlartg double complex rr,t integer i c quick return if possible. if (n <= 0) return rr = u(n) do i = n-1,1,-1 call zlartg(u(i),rr,w(i),u(i+1),t) rr = t end do u(1) = rr end subroutine qrupdate-1.1.2/src/cgqvec.f0000640035452500116100000000447511131630410014506 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cgqvec(m,n,Q,ldq,u) c purpose: given an unitary m-by-n matrix Q, n < m, generates c a vector u such that Q'*u = 0 and norm(u) = 1. c arguments: c m (in) number of rows of matrix Q. c n (in) number of columns of matrix Q. c Q (in) the unitary matrix Q. c ldq (in) leading dimension of Q. c u (out) the generated vector. c integer m,n,ldq complex Q(ldq,*),u(*) external cdotu,caxpy,scnrm2,csscal complex cdotu real scnrm2,r integer info,i,j c quick return if possible. if (m == 0) return if (n == 0) then u(1) = 1e0 do i = 2,m u(i) = 0e0 end do return end if c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldq < m) then info = 4 end if if (info /= 0) then call xerbla('CGQVEC',info) return end if j = 1 10 continue c probe j-th canonical unit vector. do i = 1,m u(i) = 0e0 end do u(j) = 1e0 c form u - Q*Q'*u do i = 1,n r = cdotu(m,Q(1,i),1,u,1) call caxpy(m,-r,Q(1,i),1,u,1) end do r = scnrm2(m,u,1) if (r == 0e0) then j = j + 1 if (j > n) then c this is fatal, and in theory, it can't happen. stop 'fatal: impossible condition in CGQVEC' else j = j + 1 goto 10 end if end if call csscal(m,1e0/r,u,1) end subroutine qrupdate-1.1.2/src/dchdex.f0000640035452500116100000000404511133034413014471 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dchdex(n,R,ldr,j,w) c purpose: given an upper triangular matrix R that is a Cholesky 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 arguments: c n (in) the order of matrix R. c R (io) on entry, the original upper trapezoidal matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= n. c j (in) the position of the deleted row/column. c w (out) a workspace vector of size n. c integer n,ldr,j double precision R(ldr,*),w(*) integer info,i external xerbla,dcopy,dqhqr c quick return if possible if (n == 1) return c check arguments info = 0 if (n < 0) then info = 1 else if (j < 1 .or. j > n) then info = 4 end if if (info /= 0) then call xerbla('DCHDEX',info) return end if c delete the j-th column. do i = j,n-1 call dcopy(n,R(1,i+1),1,R(1,i),1) end do c retriangularize. if (j < n) then call dqhqr(n+1-j,n-j,R(j,j),ldr,w,R(1,n)) end if end subroutine qrupdate-1.1.2/src/schshx.f0000640035452500116100000000541211133034413014531 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine schshx(n,R,ldr,i,j,w) c purpose: given an upper triangular matrix R that is a Cholesky 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(p,p), where 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. c (real version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c i (in) the first index determining the range (see above). c j (in) the second index determining the range (see above). c w (o) a workspace vector of size 2*n. c integer n,ldr,i,j real R(ldr,*),w(*) external xerbla,scopy,sqrtv1,sqrqh,sqhqr integer info,l c quick return if possible. if (n == 0 .or. n == 1) return info = 0 c check arguments. if (n < 0) then info = 1 else if (i < 1 .or. i > n) then info = 4 else if (j < 1 .or. j > n) then info = 5 end if if (info /= 0) then call xerbla('SCHSHX',info) return end if if (i < j) then c shift columns call scopy(n,R(1,i),1,w,1) do l = i,j-1 call scopy(n,R(1,l+1),1,R(1,l),1) end do call scopy(n,w,1,R(1,j),1) c retriangularize call sqhqr(n+1-i,n+1-i,R(i,i),ldr,w(n+1),w) else if (j < i) then c shift columns call scopy(n,R(1,i),1,w,1) do l = i,j+1,-1 call scopy(n,R(1,l-1),1,R(1,l),1) end do call scopy(n,w,1,R(1,j),1) c eliminate the introduced spike. call sqrtv1(n+1-j,R(j,j),w(n+1)) c apply rotations to R call sqrqh(n+1-j,n-j,R(j,j+1),ldr,w(n+1),R(j+1,j)) c zero spike. do l = j+1,n R(l,j) = 0e0 end do end if end subroutine qrupdate-1.1.2/src/dch1dn.f0000640035452500116100000000554511133034413014401 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dch1dn(n,R,ldr,u,w,info) c purpose: given an upper triangular matrix R that is a Cholesky c factor of a hermitian positive definite matrix A, i.e. c A = R'*R, this subroutine downdates R -> R1 so that c R1'*R1 = A - u*u' c (real version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c u (io) the vector determining the rank-1 update c on exit, u contains the reflector sines c used to transform R to R1. c w (out) cosine parts of reflectors. c c info (out) on exit, error code: c info = 0: success. c info = 1: update violates positive-definiteness. c info = 2: R is singular. c integer n,ldr double precision R(ldr,*),u(*),w(*) integer info external dtrsv,dlartg,dnrm2 double precision dnrm2,rho,rr,ui,t integer i,j c quick return if possible. if (n == 0) return c check arguments. info = 0 if (n < 0) then info = -1 else if (ldr < n) then info = -3 end if if (info /= 0) then call xerbla('DCH1DN',-info) return end if c check for singularity of R. do i = 1,n if (R(i,i) == 0d0) goto 20 end do c form R' \ u call dtrsv('U','T','N',n,R,ldr,u,1) rho = dnrm2(n,u,1) c check positive definiteness rho = 1 - rho**2 if (rho <= 0d0) goto 10 rho = sqrt(rho) c eliminate R' \ u do i = n,1,-1 ui = u(i) c generate next rotation call dlartg(rho,ui,w(i),u(i),rr) rho = rr end do c apply rotations do i = n,1,-1 ui = 0d0 do j = i,1,-1 t = w(j)*ui + u(j)*R(j,i) R(j,i) = w(j)*R(j,i) - u(j)*ui ui = t end do end do c normal return return c error returns 10 info = 1 return 20 info = 2 return end subroutine qrupdate-1.1.2/src/zch1up.f0000640035452500116100000000373511133034413014451 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zch1up(n,R,ldr,u,w) c purpose: given an upper triangular matrix R that is a Cholesky c factor of a hermitian positive definite matrix A, i.e. c A = R'*R, this subroutine updates R -> R1 so that c R1'*R1 = A + u*u' c (complex version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c u (io) the vector determining the rank-1 update c on exit, u contains the rotation sines c used to transform R to R1. c w (out) cosine parts of rotations. c integer n,ldr double complex R(ldr,*),u(*) double precision w(*) external zlartg double complex rr,ui,t integer i,j do i = 1,n c apply stored rotations, column-wise ui = conjg(u(i)) do j = 1,i-1 t = w(j)*R(j,i) + u(j)*ui ui = w(j)*ui - conjg(u(j))*R(j,i) R(j,i) = t end do c generate next rotation call zlartg(R(i,i),ui,w(i),u(i),rr) R(i,i) = rr end do end subroutine qrupdate-1.1.2/src/sqhqr.f0000640035452500116100000000442711131630410014371 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sqhqr(m,n,R,ldr,c,s) c purpose: given an m-by-n upper Hessenberg matrix R, this c subroutine updates R to upper trapezoidal form c using min(m-1,n) Givens rotations. c (real version) c arguments: c m (in) number of rows of the matrix R c n (in) number of columns of the matrix R c R (io) on entry, the upper Hessenberg matrix R c on exit, the updated upper trapezoidal matrix c ldr (in) leading dimension of R, >= m c c(out) rotation cosines, size at least min(m-1,n) c s(out) rotation sines, size at least min(m-1,n) c integer m,n,ldr real R(ldr,*),c(*),s(*) external xerbla,slartg real t integer info,i,ii,j c quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call xerbla('SQHQR',info) return end if do i = 1,n c apply stored rotations, column-wise t = R(1,i) ii = min(m,i) do j = 1,ii-1 R(j,i) = c(j)*t + s(j)*R(j+1,i) t = c(j)*R(j+1,i) - s(j)*t end do if (ii < m) then c generate next rotation call slartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) R(ii+1,i) = 0e0 else R(ii,i) = t end if end do end subroutine qrupdate-1.1.2/src/dchinx.f0000640035452500116100000000601411133034413014505 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dchinx(n,R,ldr,j,u,w,info) c purpose: given an upper triangular matrix R that is a Cholesky 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 = A1, A1(jj,jj) = A, A(j,:) = u', A(:,j) = u, c jj = [1:j-1,j+1:n+1]. c (real version) c arguments: c n (in) the order of matrix R. c R (io) on entry, the original upper trapezoidal matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= n+1. c j (in) the position of the inserted row/column c u (io) on entry, the inserted row/column. c on exit, u is destroyed. c w (out) workspace vector of size n+1. c info (out) on exit, error code: c info = 1: update violates positive-definiteness. c info = 2: R is singular. c integer n,j,ldr,info double precision R(ldr,*),u(*),w(*) external xerbla,dcopy,dnrm2,dtrsv,dqrtv1,dqrqh double precision dnrm2,t,rho integer i c check arguments info = 0 if (n < 0) then info = -1 else if (j < 1 .or. j > n+1) then info = -4 end if if (info /= 0) then call xerbla('DCHINX',-info) return end if c shift vector. t = u(j) do i = j,n u(i) = u(i+1) end do c check for singularity of R. do i = 1,n if (R(i,i) == 0d0) goto 20 end do c form R' \ u call dtrsv('U','C','N',n,R,ldr,u,1) rho = dnrm2(n,u,1) c check positive definiteness. rho = t - rho**2 if (rho <= 0d0) goto 10 c shift columns do i = n,j,-1 call dcopy(i,R(1,i),1,R(1,i+1),1) R(i+1,i+1) = 0d0 end do call dcopy(n,u,1,R(1,j),1) R(n+1,j) = sqrt(rho) c retriangularize if (j < n+1) then c eliminate the introduced spike. call dqrtv1(n+2-j,R(j,j),w) c apply rotations to R call dqrqh(n+2-j,n+1-j,R(j,j+1),ldr,w,R(j+1,j)) c zero spike. do i = j+1,n+1 R(i,j) = 0d0 end do end if c normal return. return c error returns. 10 info = 1 return 20 info = 2 return end subroutine qrupdate-1.1.2/src/zqhqr.f0000640035452500116100000000451411131630410014375 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zqhqr(m,n,R,ldr,c,s) c purpose: given an m-by-n upper Hessenberg matrix R, this c subroutine updates R to upper trapezoidal form c using min(m-1,n) Givens rotations. c (complex version) c arguments: c m (in) number of rows of the matrix R c n (in) number of columns of the matrix R c R (io) on entry, the upper Hessenberg matrix R c on exit, the updated upper trapezoidal matrix c ldr (in) leading dimension of R, >= m c c(out) rotation cosines, size at least min(m-1,n) c s(out) rotation sines, size at least min(m-1,n) c integer m,n,ldr double complex R(ldr,*),s(*) double precision c(*) external xerbla,zlartg double complex t integer info,i,ii,j c quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call xerbla('ZQHQR',info) return end if do i = 1,n c apply stored rotations, column-wise t = R(1,i) ii = min(m,i) do j = 1,ii-1 R(j,i) = c(j)*t + s(j)*R(j+1,i) t = c(j)*R(j+1,i) - conjg(s(j))*t end do if (ii < m) then c generate next rotation call zlartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) R(ii+1,i) = 0d0 else R(ii,i) = t end if end do end subroutine qrupdate-1.1.2/src/dchshx.f0000640035452500116100000000542611133034413014517 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dchshx(n,R,ldr,i,j,w) c purpose: given an upper triangular matrix R that is a Cholesky 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(p,p), where 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. c (real version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c i (in) the first index determining the range (see above). c j (in) the second index determining the range (see above). c w (o) a workspace vector of size 2*n. c integer n,ldr,i,j double precision R(ldr,*),w(*) external xerbla,dcopy,dqrtv1,dqrqh,dqhqr integer info,l c quick return if possible. if (n == 0 .or. n == 1) return info = 0 c check arguments. if (n < 0) then info = 1 else if (i < 1 .or. i > n) then info = 4 else if (j < 1 .or. j > n) then info = 5 end if if (info /= 0) then call xerbla('DCHSHX',info) return end if if (i < j) then c shift columns call dcopy(n,R(1,i),1,w,1) do l = i,j-1 call dcopy(n,R(1,l+1),1,R(1,l),1) end do call dcopy(n,w,1,R(1,j),1) c retriangularize call dqhqr(n+1-i,n+1-i,R(i,i),ldr,w(n+1),w) else if (j < i) then c shift columns call dcopy(n,R(1,i),1,w,1) do l = i,j+1,-1 call dcopy(n,R(1,l-1),1,R(1,l),1) end do call dcopy(n,w,1,R(1,j),1) c eliminate the introduced spike. call dqrtv1(n+1-j,R(j,j),w(n+1)) c apply rotations to R call dqrqh(n+1-j,n-j,R(j,j+1),ldr,w(n+1),R(j+1,j)) c zero spike. do l = j+1,n R(l,j) = 0d0 end do end if end subroutine qrupdate-1.1.2/src/zqrqh.f0000640035452500116100000000417211131630410014375 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine zqrqh(m,n,R,ldr,c,s) c purpose: brings an upper trapezoidal matrix R into upper c Hessenberg form using min(m-1,n) Givens rotations. c (complex version) c arguments: c m (in) number of rows of the matrix R c n (in) number of columns of the matrix R c R (io) on entry, the upper Hessenberg matrix R c on exit, the updated upper trapezoidal matrix c ldr (in) leading dimension of R, >= m c c(in) rotation cosines, size at least min(m-1,n) c s(in) rotation sines, size at least min(m-1,n) c integer m,n,ldr double complex R(ldr,*),s(*) double precision c(*) external xerbla double complex t integer info,i,ii,j c quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call xerbla('ZQRQH',info) return end if do i = 1,n c apply stored rotations, column-wise ii = min(m-1,i) t = R(ii+1,i) do j = ii,1,-1 R(j+1,i) = c(j)*t - conjg(s(j))*R(j,i) t = c(j)*R(j,i) + s(j)*t end do R(1,i) = t end do end subroutine qrupdate-1.1.2/src/cqhqr.f0000640035452500116100000000446211131630410014350 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cqhqr(m,n,R,ldr,c,s) c purpose: given an m-by-n upper Hessenberg matrix R, this c subroutine updates R to upper trapezoidal form c using min(m-1,n) Givens rotations. c (complex version) c arguments: c m (in) number of rows of the matrix R c n (in) number of columns of the matrix R c R (io) on entry, the upper Hessenberg matrix R c on exit, the updated upper trapezoidal matrix c ldr (in) leading dimension of R, >= m c c(out) rotation cosines, size at least min(m-1,n) c s(out) rotation sines, size at least min(m-1,n) c integer m,n,ldr complex R(ldr,*),s(*) real c(*) external xerbla,clartg complex t integer info,i,ii,j c quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call xerbla('CQHQR',info) return end if do i = 1,n c apply stored rotations, column-wise t = R(1,i) ii = min(m,i) do j = 1,ii-1 R(j,i) = c(j)*t + s(j)*R(j+1,i) t = c(j)*R(j+1,i) - conjg(s(j))*t end do if (ii < m) then c generate next rotation call clartg(t,R(ii+1,i),c(i),s(i),R(ii,i)) R(ii+1,i) = 0e0 else R(ii,i) = t end if end do end subroutine qrupdate-1.1.2/src/cqrshc.f0000640035452500116100000000751311133034413014520 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cqrshc(m,n,k,Q,ldq,R,ldr,i,j,w,rw) c purpose: updates a QR factorization after circular shift of c columns. 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 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. c (complex version) c arguments: 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 Q1, and rows of R1. Must be c either k = m (full Q) or k = n <= m (economical form). c Q (io) on entry, the unitary m-by-k matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= k. c i (in) the first index determining the range (see above) c j (in) the second index determining the range (see above) c w (o) a workspace vector of size k. c rw (o) a real workspace vector of size k. c integer m,n,k,ldq,ldr,i,j complex Q(ldq,*),R(ldr,*),w(*) real rw(*) external xerbla,ccopy,cqrtv1,cqrqh,cqhqr integer info,jj,kk,l c quick return if possible. if (m == 0 .or. n == 1) return info = 0 c check arguments. if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (k /= m .and. (k /= n .or. n > m)) then info = 3 else if (i < 1 .or. i > n) then info = 6 else if (j < 1 .or. j > n) then info = 7 end if if (info /= 0) then call xerbla('CQRSHC',info) return end if if (i < j) then c shift columns call ccopy(k,R(1,i),1,w,1) do l = i,j-1 call ccopy(k,R(1,l+1),1,R(1,l),1) end do call ccopy(k,w,1,R(1,j),1) c retriangularize if (i < k) then kk = min(k,j) call cqhqr(kk+1-i,n+1-i,R(i,i),ldr,rw,w) c apply rotations to Q. call cqrot('F',m,kk+1-i,Q(1,i),ldq,rw,w) end if else if (j < i) then c shift columns call ccopy(k,R(1,i),1,w,1) do l = i,j+1,-1 call ccopy(k,R(1,l-1),1,R(1,l),1) end do call ccopy(k,w,1,R(1,j),1) c retriangularize if (j < k) then jj = min(j+1,n) kk = min(k,i) c eliminate the introduced spike. call cqrtv1(kk+1-j,R(j,j),rw) c apply rotations to R call cqrqh(kk+1-j,n-j,R(j,jj),ldr,rw,R(j+1,j)) c apply rotations to Q call cqrot('B',m,kk+1-j,Q(1,j),ldq,rw,R(j+1,j)) c zero spike. do l = j+1,kk R(l,j) = 0e0 end do end if end if end subroutine qrupdate-1.1.2/src/cqrqh.f0000640035452500116100000000414011131630410014341 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cqrqh(m,n,R,ldr,c,s) c purpose: brings an upper trapezoidal matrix R into upper c Hessenberg form using min(m-1,n) Givens rotations. c (complex version) c arguments: c m (in) number of rows of the matrix R c n (in) number of columns of the matrix R c R (io) on entry, the upper Hessenberg matrix R c on exit, the updated upper trapezoidal matrix c ldr (in) leading dimension of R, >= m c c(in) rotation cosines, size at least min(m-1,n) c s(in) rotation sines, size at least min(m-1,n) c integer m,n,ldr complex R(ldr,*),s(*) real c(*) external xerbla complex t integer info,i,ii,j c quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call xerbla('CQRQH',info) return end if do i = 1,n c apply stored rotations, column-wise ii = min(m-1,i) t = R(ii+1,i) do j = ii,1,-1 R(j+1,i) = c(j)*t - conjg(s(j))*R(j,i) t = c(j)*R(j,i) + s(j)*t end do R(1,i) = t end do end subroutine qrupdate-1.1.2/src/dlup1up.f0000640035452500116100000001200511263327111014623 0ustar higheggengc Copyright (C) 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine dlup1up(m,n,L,ldl,R,ldr,p,u,v,w) c purpose: updates a row-pivoted LU factorization after rank-1 modification c i.e., given an m-by-k lower-triangular matrix L with unit c diagonal, a k-by-n upper-trapezoidal matrix R, and a c permutation matrix P, where k = min(m,n), c this subroutine updates L -> L1, R -> R1 and P -> P1 so that c L is again lower unit triangular, R upper trapezoidal, c P permutation and P1'*L1*R1 = P'*L*R + u*v.'. c (real version) c arguments: c m (in) order of the matrix L. c n (in) number of columns of the matrix U. c L (io) on entry, the unit lower triangular matrix L. c on exit, the updated matrix L1. c ldl (in) the leading dimension of L. ldl >= m. c R (io) on entry, the upper trapezoidal m-by-n matrix R. c on exit, the updated matrix R1. c ldr (in) the leading dimension of R. ldr >= min(m,n). c p (in) the permutation vector representing P c u (in) the left m-vector. c v (in) the right n-vector. c w (work) a workspace vector of size m. c c REMARK: Algorithm is due to c A. Kielbasinski, H. Schwetlick, Numerische Lineare c Algebra, Verlag Harri Deutsch, 1988 c integer m,n,ldl,ldr,p(*) double precision L(ldl,*),R(ldr,*),u(*),v(*),w(*) double precision one,tau,tmp parameter (one = 1d0, tau = 1d-1) integer k,info,i,j,itmp external xerbla,dcopy,daxpy,dtrsv,dger,dgemv c quick return if possible. k = min(m,n) if (k == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldl < m) then info = 4 else if (ldr < k) then info = 6 endif if (info /= 0) then call xerbla('DLU1UP',info) return end if c form L \ P*u. do i = 1,m w(i) = u(p(i)) end do call dtrsv('L','N','U',k,L,ldl,w,1) c if m > k = n, subtract the trailing part. if (m > k) then call dgemv('N',m-k,k,-one,L(k+1,1),ldl,w,1,one,w(k+1),1) end if c work from bottom to top do j = k-1,1,-1 if (abs(w(j)) < tau * abs(L(j+1,j)*w(j) + w(j+1))) then c need pivoting. swap j and j+1 tmp = w(j) w(j) = w(j+1) w(j+1) = tmp c update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp c update L call dswap(m-j+1,L(j,j),1,L(j,j+1),1) call dswap(j+1,L(j,1),ldl,L(j+1,1),ldl) c update R call dswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) c make L lower triangular again tmp = -L(j,j+1) call daxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) c update R call daxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) c update w w(j) = w(j) - tmp*w(j+1) end if c eliminate w(j+1) tmp = w(j+1)/w(j) w(j+1) = 0 c update R. call daxpy(n-j+1,-tmp,R(j,j),ldr,R(j+1,j),ldr) c update L. call daxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do c add a multiple of v to R call daxpy(n,w(1),v,1,R(1,1),ldr) c forward sweep do j = 1,k-1 if (abs(R(j,j)) < tau * abs(L(j+1,j)*R(j,j) + R(j+1,j))) then c need pivoting. swap j and j+1 c update p itmp = p(j) p(j) = p(j+1) p(j+1) = itmp c update L call dswap(m-j+1,L(j,j),1,L(j,j+1),1) call dswap(j+1,L(j,1),ldl,L(j+1,1),ldl) c update R call dswap(n-j+1,R(j,j),ldr,R(j+1,j),ldr) c make L lower triangular again tmp = -L(j,j+1) call daxpy(m-j+1,tmp,L(j,j),1,L(j,j+1),1) c update R call daxpy(n-j+1,-tmp,R(j+1,j),ldr,R(j,j),ldr) end if c eliminate R(j+1,j) tmp = R(j+1,j)/R(j,j) c update R. R(j+1,j) = 0d0 call daxpy(n-j,-tmp,R(j,j+1),ldr,R(j+1,j+1),ldr) c update L. call daxpy(m-j,tmp,L(j+1,j+1),1,L(j+1,j),1) end do c if m > k = n, complete the update by updating the lower part of L. if (m > k) then call dcopy(k,v,1,w,1) call dtrsv('U','T','N',k,R,ldr,w,1) call dger(m-k,k,one,w(k+1),1,w,1,L(k+1,1),ldl) endif end subroutine qrupdate-1.1.2/src/cch1dn.f0000640035452500116100000000560311133034413014373 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cch1dn(n,R,ldr,u,rw,info) c purpose: given an upper triangular matrix R that is a Cholesky c factor of a hermitian positive definite matrix A, i.e. c A = R'*R, this subroutine downdates R -> R1 so that c R1'*R1 = A - u*u' c (complex version) c arguments: c n (in) the order of matrix R c R (io) on entry, the upper triangular matrix R c on exit, the updated matrix R1 c ldr (in) leading dimension of R. ldr >= n. c u (io) the vector determining the rank-1 update c on exit, u contains the reflector sines c used to transform R to R1. c rw (out) cosine parts of reflectors. c c info (out) on exit, error code: c info = 0: success. c info = 1: update violates positive-definiteness. c info = 2: R is singular. c integer n,ldr complex R(ldr,*),u(*) real rw(*) integer info external ctrsv,clartg,scnrm2 complex crho,rr,ui,t real scnrm2,rho integer i,j c quick return if possible. if (n == 0) return c check arguments. info = 0 if (n < 0) then info = -1 else if (ldr < n) then info = -3 end if if (info /= 0) then call xerbla('CCH1DN',-info) return end if c check for singularity of R. do i = 1,n if (R(i,i) == 0e0) goto 20 end do c form R' \ u call ctrsv('U','C','N',n,R,ldr,u,1) rho = scnrm2(n,u,1) c check positive definiteness rho = 1 - rho**2 if (rho <= 0e0) goto 10 crho = sqrt(rho) c eliminate R' \ u do i = n,1,-1 ui = u(i) c generate next rotation call clartg(crho,ui,rw(i),u(i),rr) crho = rr end do c apply rotations do i = n,1,-1 ui = 0e0 do j = i,1,-1 t = rw(j)*ui + u(j)*R(j,i) R(j,i) = rw(j)*R(j,i) - conjg(u(j))*ui ui = t end do end do c normal return return c error returns 10 info = 1 return 20 info = 2 return end subroutine qrupdate-1.1.2/src/schdex.f0000640035452500116100000000403111133034413014503 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine schdex(n,R,ldr,j,w) c purpose: given an upper triangular matrix R that is a Cholesky 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 arguments: c n (in) the order of matrix R. c R (io) on entry, the original upper trapezoidal matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= n. c j (in) the position of the deleted row/column. c w (out) a workspace vector of size n. c integer n,ldr,j real R(ldr,*),w(*) integer info,i external xerbla,scopy,sqhqr c quick return if possible if (n == 1) return c check arguments info = 0 if (n < 0) then info = 1 else if (j < 1 .or. j > n) then info = 4 end if if (info /= 0) then call xerbla('SCHDEX',info) return end if c delete the j-th column. do i = j,n-1 call scopy(n,R(1,i+1),1,R(1,i),1) end do c retriangularize. if (j < n) then call sqhqr(n+1-j,n-j,R(j,j),ldr,w,R(1,n)) end if end subroutine qrupdate-1.1.2/src/cqrder.f0000640035452500116100000000534311714050540014520 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine cqrder(m,n,Q,ldq,R,ldr,j,w,rw) c purpose: updates a QR factorization after deleting a row. c i.e., given an m-by-m unitary matrix Q, an m-by-n c upper trapezoidal matrix R and index j in the range c 1:m, this subroutine updates Q ->Q1 and an R -> R1 c so that Q1 is again unitary, R1 upper trapezoidal, c and Q1*R1 = [A(1:j-1,:); A(j+1:m,:)], where A = Q*R. c (complex version) c c arguments: c m (in) number of rows of the matrix Q. c n (in) number of columns of the matrix R. c Q (io) on entry, the unitary matrix Q. c on exit, the updated matrix Q1. c ldq (in) leading dimension of Q. ldq >= m. c R (io) on entry, the original matrix R. c on exit, the updated matrix R1. c ldr (in) leading dimension of R. ldr >= m. c j (in) the position of the deleted row. c w (out) a workspace vector of size m. c rw (out) a real workspace vector of size m. c integer m,n,j,ldq,ldr complex Q(ldq,*),R(ldr,*),w(*) real rw(*) external xerbla,ccopy,cqrtv1,cqrot,cqrqh integer info,i,k c quick return if possible if (m == 1) return c check arguments info = 0 if (m < 1) then info = 1 else if (j < 1 .or. j > m) then info = 7 end if if (info /= 0) then call xerbla('CQRDER',info) return end if c eliminate Q(j,2:m). do k = 1,m w(k) = conjg(Q(j,k)) end do call cqrtv1(m,w,rw) c apply rotations to Q. call cqrot('B',m,m,Q,ldq,rw,w(2)) c form Q1. do k = 1,m-1 if (j > 1) call ccopy(j-1,Q(1,k+1),1,Q(1,k),1) if (j < m) call ccopy(m-j,Q(j+1,k+1),1,Q(j,k),1) end do c apply rotations to R. call cqrqh(m,n,R,ldr,rw,w(2)) c form R1. do k = 1,n do i = 1,m-1 R(i,k) = R(i+1,k) end do end do end subroutine qrupdate-1.1.2/src/sqrqh.f0000640035452500116100000000410511131630410014362 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine sqrqh(m,n,R,ldr,c,s) c purpose: brings an upper trapezoidal matrix R into upper c Hessenberg form using min(m-1,n) Givens rotations. c (real version) c arguments: c m (in) number of rows of the matrix R c n (in) number of columns of the matrix R c R (io) on entry, the upper Hessenberg matrix R c on exit, the updated upper trapezoidal matrix c ldr (in) leading dimension of R, >= m c c(in) rotation cosines, size at least min(m-1,n) c s(in) rotation sines, size at least min(m-1,n) c integer m,n,ldr real R(ldr,*),c(*),s(*) external xerbla real t integer info,i,ii,j c quick return if possible. if (m == 0 .or. m == 1 .or. n == 0) return c check arguments. info = 0 if (m < 0) then info = 1 else if (n < 0) then info = 2 else if (ldr < m) then info = 4 end if if (info /= 0) then call xerbla('SQRQH',info) return end if do i = 1,n ii = min(m-1,i) c apply stored rotations, column-wise t = R(ii+1,i) do j = ii,1,-1 R(j+1,i) = c(j)*t - s(j)*R(j,i) t = c(j)*R(j,i) + s(j)*t end do R(1,i) = t end do end subroutine qrupdate-1.1.2/INSTALL0000640035452500116100000000374311334774270013350 0ustar higheggengINSTALLATION NOTES FOR QRUPDATE ------------------------------- The library is written in Fortran. Officially, it is Fortran 90-compliant, but will probably be compilable with Fortran 77 compilers supporting two common extensions: double complex type, end if/end do/end subroutine blocks and automatic arrays. The latter are only needed for the test suite. In particular, it has been tested with the following compilers: * gfortran 4.3 * g95 0.91 * Intel Fortran 10.1 * g77 3.4 (does not compile test suite) * f2c (does not compile test suite) * Lahey/Fujitsu Fortran 8.0 (SSL II for test suite) -- thanks to Jan Piclum, U. Alberta, Canada If you succeeded to compile qrupdate with a compiler not mentioned here (or an earlier version), please contact me so that the list can be expanded. To compile on an UNIX-compatible system, edit Makeconf to set up your preferred compiler & compiler flags. Defaults are provided using GNU Fortran, which should work straight away. Then do "make lib" to create a static library (libqrupdate.a). To create a dynamic library (libqrupdate.so), do "make solib". In that case, make sure your compiler flags support PIC code (if needed on your system). To compile & run tests, do "make test". All tests will display their results as well as save them using the "tee" utility. A test works correctly if it runs OK and outputs all small residuals (of order e-06 for single precision, e-14 for double precision). Note that subsequent "make test" only redisplays the stored results, unless a test is changed. The test suite includes some guards against buggy BLAS CHERK and ZHERK routines. You may get warnings from the test suite about this. Installing is as simple as doing "make install", which will install the library according to modern conventions for UNIX-based platforms. Another option is putting the static library anywhere at will and point compilers to it with the -L switch. Windows makefile is not (yet) provided, but should be easily derived from the UNIX one. qrupdate-1.1.2/README0000640035452500116100000000410211322560232013151 0ustar higheggengQRUPDATE: A LIBRARY FOR FAST UPDATING OF QR AND CHOLESKY DECOMPOSITIONS ----------------------------------------------------------------------- The following operations are supported: QR rank-1 update (qr1up) Updates the QR factorization after an additive rank-1 update to the original matrix (A = A + u*v'). Works for full & economized factorization. QR column insert (qrinc) Updates the QR factorization after an inserting a column to the original matrix. Works for full & economized factorization. QR column delete (qrdec) Updates the QR factorization after an deleting a column from the original matrix. Works for full & economized factorization. QR column shift (qrshc) Updates the QR factorization after a circular shift of columns in the original matrix. Works for full & economized factorization. QR row insert (qrinr) Updates the QR factorization after an inserting a row to the original matrix. Works for full factorization only. QR row delete (qrder) Updates the QR factorization after an deleting a row from the original matrix. Works for full factorization only. Cholesky rank-1 update (ch1up) Updates the Cholesky factorization after positive rank-1 update A = A + u*u'. Cholesky rank-1 downdate (ch1dn) Updates the Cholesky factorization after positive rank-1 downdate A = A - u*u'. Cholesky symmetric insert (chinx) Updates the Cholesky factorization after a symmetric column/row insertion. Cholesky symmetric insert (chdex) Updates the Cholesky factorization after a symmetric column/row deletion. Cholesky symmetric shift (chshx) Updates the Cholesky factorization after a symmetric column/row left/right circular shift. LU rank-1 update (lu1up) Updates the LU factorization after a rank-1 update (A = A + u*v.'). No pivoting available. Faster than lup1up, but less stable. LU pivoted rank-1 update (lup1up) Updates a row-pivoted LUP factorization after a rank-1 update (A = A + u*v.'). Also updates the row permutation matrix. Slower than lu1up, but more stable. See the INSTALL file for installation details. Consult individual routines for documentation. qrupdate-1.1.2/Makeconf0000640035452500116100000000100011325314425013735 0ustar higheggeng# set this to your compiler's executable name (e.g. gfortran, g77) FC=gfortran # requested flags FFLAGS=-fimplicit-none -O3 -funroll-loops # set if you need shared library FPICFLAGS=-fPIC # BLAS library (only required for tests) BLAS=-lblas # LAPACK library (only required for tests) LAPACK=-llapack # Library version VERSION=1.1 MAJOR=1 # The default library dir LIBDIR=lib # Destination installation offset DESTDIR= # set default prefix to /usr/local ifeq ($(strip $(PREFIX)),) PREFIX=/usr/local endif qrupdate-1.1.2/Makefile0000640035452500116100000000270511143004214013732 0ustar higheggeng# Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic # # Author: Jaroslav Hajek # # This file is part of qrupdate. # # qrupdate is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this software; see the file COPYING. If not, see # . # include Makeconf help: @echo @echo "The following targets are available:" @echo " make help - displays this help" @echo " make lib - compiles a static library" @echo " make solib - compiles a dynamic library" @echo " make test - compiles and runs the testsuite" @echo " make clean - cleans up everything" @echo " make install - installs everything" lib: make -C src/ lib solib: make -C src/ solib test: lib make -C test/ clean: rm -f libqrupdate.a libqrupdate.so make -C src/ clean make -C test/ clean install: make -C src/ install install-shlib: make -C src/ install-shlib install-staticlib: make -C src/ install-staticlib qrupdate-1.1.2/ChangeLog0000640035452500116100000000435111714050540014052 0ustar higheggeng2012-02-06 Jaroslav Hajek * src/sqrder.f, src/dqrder.f, src/cqrder.f, src/zqrder.f: Fix fast return conditions for out-of-bounds row. 2010-02-11 Jaroslav Hajek * test/utils.f: Test CHERK and ZHERK results for validity. Warn about possibly buggy BLAS routines. * test/report_results: Dump out the warnings at the end. 2010-02-11 Jaroslav Hajek * test/utils.f: Correct invalid calls to xLANGE. Make dummy workspace decls consistent. 2010-02-11 Jaroslav Hajek * test/Makefile: Ensure the test output file is created to prevent errors from report_results. 2010-01-19 Fabian Groffen * Makeconf: Define DESTDIR. * src/Makefile: Prefix DESTDIR to install targets, to comply with GNU Makefile standard. 2010-01-19 Fabian Groffen * src/Makefile: Define SOEXT and set it correctly for Darwin. Use it in build and install rules. 2010-01-11 Jaroslav Hajek * Makeconf: Mark version 1.1. * README: Document LU updating routines. 2009-10-08 Jaroslav Hajek * src/slup1up.f: New source. * src/dlup1up.f: New source. * src/clup1up.f: New source. * src/zlup1up.f: New source. * src/Makefile: Include them. * src/slu1up.f: Mention algorithm source. * src/dlu1up.f: Ditto. * src/clu1up.f: Ditto. * src/zlu1up.f: Ditto. * src/EXPORTS: Update. * test/utils.f (P2IPIV, SLUPGEN, DLUPGEN, CLUPGEN, ZLUPGEN, SLUPCHK, DLUPCHK, CLUPCHK, ZLUPCHK): New subroutines. * test/tlup1up.f: New source. * test/Makefile: Include it. 2009-10-05 Jaroslav Hajek * src/slu1up.f: New source. * src/dlu1up.f: New source. * src/clu1up.f: New source. * src/zlu1up.f: New source. * src/Makefile: Include them in build. * test/utils.f (SLUGEN, DLUGEN, CLUGEN, ZLUGEN, SLUCHK, DLUCHK, CLUCHK, ZLUCHK): New subroutines. * test/tlu1up.f: New source. * test/Makefile: Include it. 2009-02-06 Jordi Gutiérrez Hermoso * Makeconf: Set default PREFIX. * Makefile: Add install targets. * src/Makefile: Likewise. 2009-02-04 Jaroslav Hajek * ChangeLog: Create. * src/Makefile: Specify BLAS and LAPACK when creating dynamic library. qrupdate-1.1.2/COPYING0000640035452500116100000010451311131630410013325 0ustar higheggeng GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . qrupdate-1.1.2/test/0000750035452500116100000000000011714051463013260 5ustar higheggengqrupdate-1.1.2/test/tqrinr.f0000640035452500116100000000744511132663174014763 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tqrinr integer m,n,j write (*,*) write (*,*) 'testing QR row insert routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 j = 30 write (*,*) 'sqrinr test (full factorization):' call stest(m,n,j) write (*,*) 'dqrinr test (full factorization):' call dtest(m,n,j) write (*,*) 'cqrinr test (full factorization):' call ctest(m,n,j) write (*,*) 'zqrinr test (full factorization):' call ztest(m,n,j) call pstats end program subroutine stest(m,n,j) integer m,n,j real A(m+1,max(m+1,n)),Q(m+1,m+1),R(m+1,n),u(n),wrk(n) external srandg,sqrgen,scopy,sqrinr,sqrchk integer i c set up random matrix & vector call srandg(m,n,A,m+1) call srandg(n,1,u,n) c generate QR decomposition call sqrgen(m,n,A,m+1,Q,m+1,R,m+1) c update A do i = m,j,-1 call scopy(n,A(i,1),m+1,A(i+1,1),m+1) end do call scopy(n,u,1,A(j,1),m+1) c update the QR decomposition call sqrinr(m,n,Q,m+1,R,m+1,j,u,wrk) c check result call sqrchk(m+1,n,m+1,A,m+1,Q,m+1,R,m+1) end subroutine subroutine dtest(m,n,j) integer m,n,j double precision A(m+1,max(m+1,n)),Q(m+1,m+1),R(m+1,n),u(n),wrk(n) external drandg,dqrgen,dcopy,dqrinr,dqrchk integer i c set up random matrix & vector call drandg(m,n,A,m+1) call drandg(n,1,u,n) c generate QR decomposition call dqrgen(m,n,A,m+1,Q,m+1,R,m+1) c update A do i = m,j,-1 call dcopy(n,A(i,1),m+1,A(i+1,1),m+1) end do call dcopy(n,u,1,A(j,1),m+1) c update the QR decomposition call dqrinr(m,n,Q,m+1,R,m+1,j,u,wrk) c check result call dqrchk(m+1,n,m+1,A,m+1,Q,m+1,R,m+1) end subroutine subroutine ctest(m,n,j) integer m,n,j complex A(m+1,max(m+1,n)),Q(m+1,m+1),R(m+1,n),u(n),wrk(n) external crandg,cqrgen,ccopy,cqrinr,cqrchk integer i c set up random matrix & vector call crandg(m,n,A,m+1) call crandg(n,1,u,n) c generate QR decomposition call cqrgen(m,n,A,m+1,Q,m+1,R,m+1) c update A do i = m,j,-1 call ccopy(n,A(i,1),m+1,A(i+1,1),m+1) end do call ccopy(n,u,1,A(j,1),m+1) c update the QR decomposition call cqrinr(m,n,Q,m+1,R,m+1,j,u,wrk) c check result call cqrchk(m+1,n,m+1,A,m+1,Q,m+1,R,m+1) end subroutine subroutine ztest(m,n,j) integer m,n,j double complex A(m+1,max(m+1,n)),Q(m+1,m+1),R(m+1,n),u(n),wrk(n) external zrandg,zqrgen,zcopy,zqrinr,zqrchk integer i c set up random matrix & vector call zrandg(m,n,A,m+1) call zrandg(n,1,u,n) c generate QR decomposition call zqrgen(m,n,A,m+1,Q,m+1,R,m+1) c update A do i = m,j,-1 call zcopy(n,A(i,1),m+1,A(i+1,1),m+1) end do call zcopy(n,u,1,A(j,1),m+1) c update the QR decomposition call zqrinr(m,n,Q,m+1,R,m+1,j,u,wrk) c check result call zqrchk(m+1,n,m+1,A,m+1,Q,m+1,R,m+1) end subroutine qrupdate-1.1.2/test/utils.f0000640035452500116100000007127311334757677014624 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c subroutine srandg(m,n,x,ldx) integer m,n,ldx real x(ldx,*) external slaruv integer seed(4),j,k common /xrand/ seed do j = 1,n do k = 1,m,128 call slaruv(seed,min(m-k+1,128),x(k,j)) end do end do do j = 1,n do k = 1,m if (.not. (x(k,j) > 0e0 .and. x(k,j) < 1e0)) then stop 'slaruv produced invalid number' end if end do end do end subroutine subroutine drandg(m,n,x,ldx) integer m,n,ldx double precision x(ldx,*) external dlaruv integer seed(4),j,k common /xrand/ seed do j = 1,n do k = 1,m,128 call dlaruv(seed,min(m-k+1,128),x(k,j)) end do end do do j = 1,n do k = 1,m if (.not. (x(k,j) > 0d0 .and. x(k,j) < 1d0)) then stop 'dlaruv produced invalid number' end if end do end do end subroutine subroutine crandg(m,n,x,ldx) integer m,n,ldx complex x(ldx,*) external srandg call srandg(2*m,n,x,2*ldx) end subroutine subroutine zrandg(m,n,x,ldx) integer m,n,ldx double complex x(ldx,*) external srandg call drandg(2*m,n,x,2*ldx) end subroutine block data xrandi integer seed(4) common /xrand/ seed data seed /4*1/ end block data subroutine sqrgen(m,n,A,lda,Q,ldq,R,ldr) integer m,n,lda,ldq,ldr real A(lda,n),Q(ldq,m),R(ldr,n) real work(max(m,n)),tau(min(m,n)) integer info,i,j external slacpy,sgeqrf,sorgqr if (m == 0) return call slacpy('0',m,n,A,lda,R,ldr) call sgeqrf(m,n,R,ldr,tau,work,max(m,n),info) do i = 1,n do j = i+1,m Q(j,i) = R(j,i) R(j,i) = 0e0 end do end do call sorgqr(m,m,min(m,n),Q,ldq,tau,work,max(m,n),info) end subroutine subroutine dqrgen(m,n,A,lda,Q,ldq,R,ldr) integer m,n,lda,ldq,ldr double precision A(lda,n),Q(ldq,m),R(ldr,n) double precision work(max(m,n)),tau(min(m,n)) integer info,i,j external dlacpy,dgeqrf,dorgqr if (m == 0) return call dlacpy('0',m,n,A,lda,R,ldr) call dgeqrf(m,n,R,ldr,tau,work,max(m,n),info) do i = 1,n do j = i+1,m Q(j,i) = R(j,i) R(j,i) = 0d0 end do end do call dorgqr(m,m,min(m,n),Q,ldq,tau,work,max(m,n),info) end subroutine subroutine cqrgen(m,n,A,lda,Q,ldq,R,ldr) integer m,n,lda,ldq,ldr complex A(lda,n),Q(ldq,m),R(ldr,n) complex work(max(m,n)),tau(min(m,n)) integer info,i,j external clacpy,cgeqrf,cungqr if (m == 0) return call clacpy('0',m,n,A,lda,R,ldr) call cgeqrf(m,n,R,ldr,tau,work,max(m,n),info) do i = 1,n do j = i+1,m Q(j,i) = R(j,i) R(j,i) = 0e0 end do end do call cungqr(m,m,min(m,n),Q,ldq,tau,work,max(m,n),info) end subroutine subroutine zqrgen(m,n,A,lda,Q,ldq,R,ldr) integer m,n,lda,ldq,ldr double complex A(lda,n),Q(ldq,m),R(ldr,n) double complex work(max(m,n)),tau(min(m,n)) integer info,i,j external zlacpy,zgeqrf,zungqr if (m == 0) return call zlacpy('0',m,n,A,lda,R,ldr) call zgeqrf(m,n,R,ldr,tau,work,max(m,n),info) do i = 1,n do j = i+1,m Q(j,i) = R(j,i) R(j,i) = 0d0 end do end do call zungqr(m,m,min(m,n),Q,ldq,tau,work,max(m,n),info) end subroutine subroutine smdump(name,m,n,A,lda) character(*) name integer m,n,lda real A(lda,n) integer i,j write (*,1001) name do i = 1,m do j = 1,n write(*,1002) A(i,j) end do write(*,*) end do 1001 format (A,' = ') 1002 format (1x,F6.3,$) end subroutine subroutine dmdump(name,m,n,A,lda) character(*) name integer m,n,lda double precision A(lda,n) integer i,j write (*,1001) name do i = 1,m do j = 1,n write(*,1002) A(i,j) end do write(*,*) end do 1001 format (A,' = ') 1002 format (1x,F6.3,$) end subroutine subroutine cmdump(name,m,n,A,lda) character(*) name integer m,n,lda complex A(lda,n) integer i,j write (*,1001) name do i = 1,m do j = 1,n write(*,1002) A(i,j) end do write(*,*) end do 1001 format (A,' = ') 1002 format (1x,F6.3,SP,F6.3,'i',$) end subroutine subroutine zmdump(name,m,n,A,lda) character(*) name integer m,n,lda double complex A(lda,n) integer i,j write (*,1001) name do i = 1,m do j = 1,n write(*,1002) A(i,j) end do write(*,*) end do 1001 format (A,' = ') 1002 format (1x,F6.3,SP,F6.3,'i',$) end subroutine character*4 function spftol(rnrm) real rnrm,slamch external slamch common /stats/ passed,failed integer passed,failed if (rnrm < 2e2*slamch('p')) then spftol = 'PASS' passed = passed + 1 else spftol = 'FAIL' failed = failed + 1 end if end function character*4 function dpftol(rnrm) double precision rnrm,dlamch external dlamch common /stats/ passed,failed integer passed,failed if (rnrm < 2d2*dlamch('p')) then dpftol = 'PASS' passed = passed + 1 else dpftol = 'FAIL' failed = failed + 1 end if end function subroutine pstats common /stats/ passed,failed integer passed,failed write(*,1001) write(*,1002) passed,failed write(*,*) 1001 format(70('-')) 1002 format(1x,'total:',5x,'PASSED',1x,I3,5x,'FAILED',1x,I3) end subroutine subroutine sqrchk(m,n,k,A,lda,Q,ldq,R,ldr) integer m,n,k,lda,ldq,ldr real A(lda,max(n,k)),Q(ldq,k),R(ldr,n) real rnrm,slange,slansy external sgemm,ssyrk,slange,slansy,spftol character*4 spftol real wrk(m) integer i c get residual call sgemm('N','N',m,n,k,-1e0,Q,ldq,R,ldr,1e0,A,lda) c get frobenius norm rnrm = slange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) c form Q'*Q - I call ssyrk('U','T',k,m,1e0,Q,ldq,0e0,A,lda) do i = 1,k A(i,i) = A(i,i) - 1e0 end do c get frobenius norm rnrm = slansy('M','U',k,A,lda,wrk) write(*,1002) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) 1002 format('orth. residual error = ',10x,E21.12,5x,A6) end subroutine subroutine dqrchk(m,n,k,A,lda,Q,ldq,R,ldr) integer m,n,k,lda,ldq,ldr double precision A(lda,max(n,k)),Q(ldq,k),R(ldr,n) double precision rnrm,dlange,dlansy external dgemm,dsyrk,dlange,dlansy,dpftol character*4 dpftol double precision wrk(m) integer i c get residual call dgemm('N','N',m,n,k,-1d0,Q,ldq,R,ldr,1d0,A,lda) c get frobenius norm rnrm = dlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) c form Q'*Q - I call dsyrk('U','T',k,m,1d0,Q,ldq,0d0,A,lda) do i = 1,k A(i,i) = A(i,i) - 1d0 end do c get frobenius norm rnrm = dlansy('M','U',k,A,lda,wrk) write(*,1002) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) 1002 format('orth. residual error = ',10x,E21.12,5x,A6) end subroutine subroutine cqrchk(m,n,k,A,lda,Q,ldq,R,ldr) integer m,n,k,lda,ldq,ldr complex A(lda,max(n,k)),Q(ldq,k),R(ldr,n) real rnrm,clange,clanhe external cgemm,cherk,clange,clanhe,spftol character*4 spftol real wrk(m) integer i c get residual call cgemm('N','N',m,n,k,-(1e0,0e0),Q,ldq,R,ldr,(1e0,0e0),A,lda) c get frobenius norm rnrm = clange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) c form Q'*Q - I call cherk('U','C',k,m,1e0,Q,ldq,0e0,A,lda) do i = 1,k A(i,i) = A(i,i) - 1e0 end do c get frobenius norm rnrm = clanhe('M','U',k,A,lda,wrk) write(*,1002) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) 1002 format('orth. residual error = ',10x,E21.12,5x,A6) end subroutine subroutine zqrchk(m,n,k,A,lda,Q,ldq,R,ldr) integer m,n,k,lda,ldq,ldr double complex A(lda,max(n,k)),Q(ldq,k),R(ldr,n) double precision rnrm,zlange,zlanhe external zgemm,zherk,zlange,zlanhe,dpftol character*4 dpftol double precision wrk(m) integer i c get residual call zgemm('N','N',m,n,k,-(1d0,0d0),Q,ldq,R,ldr,(1d0,0d0),A,lda) c get frobenius norm rnrm = zlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) c form Q'*Q - I call zherk('U','C',k,m,1d0,Q,ldq,0d0,A,lda) do i = 1,k A(i,i) = A(i,i) - 1d0 end do c get frobenius norm rnrm = zlanhe('M','U',k,A,lda,wrk) write(*,1002) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) 1002 format('orth. residual error = ',10x,E21.12,5x,A6) end subroutine subroutine schgen(n,A,lda,R,ldr) integer n,lda,ldr real A(lda,n),R(ldr,n) external ssyrk,slacpy,spotrf integer i,j,info call ssyrk('U','T',n,n,1e0,A,lda,0e0,R,ldr) c augment to ensure strict positivity, zero below diag do i = 1,n R(i,i) = R(i,i) + 1e-3 c zero below diagonal do j = i+1,n R(j,i) = 0e0 end do end do call slacpy('U',n,n,R,ldr,A,lda) c symmetrize A do i = 1,n-1 do j = i+1,n A(j,i) = A(i,j) end do end do call spotrf('U',n,R,ldr,info) if (info /= 0) stop 'fatal:error generating positive matrix' end subroutine subroutine dchgen(n,A,lda,R,ldr) integer n,lda,ldr double precision A(lda,n),R(ldr,n) external dsyrk,dlacpy,dpotrf integer i,j,info call dsyrk('U','T',n,n,1d0,A,lda,0d0,R,ldr) c augment to ensure strict positivity do i = 1,n R(i,i) = R(i,i) + 1d-3 c zero below diagonal do j = i+1,n R(j,i) = 0d0 end do end do call dlacpy('U',n,n,R,ldr,A,lda) c symmetrize A do i = 1,n-1 do j = i+1,n A(j,i) = A(i,j) end do end do call dpotrf('U',n,R,ldr,info) if (info /= 0) stop 'fatal:error generating positive matrix' end subroutine subroutine cchgen(n,A,lda,R,ldr) integer n,lda,ldr complex A(lda,n),R(ldr,n) external cherk,clacpy,cpotrf,cdotc complex cdotc,Rii integer i,j,info call cherk('U','C',n,n,1e0,A,lda,0e0,R,ldr) c augment to ensure strict positivity do i = 1,n c CHERK is often buggy. We'll recompute the diagonal elements and c possibly warn about the bug. Rii = cdotc (n, A(1,i), 1, A(1,i), 1) if (.not. abs (Rii - R(i,i)) < 1e-5 * abs(Rii)) then write (*,1001) write (*,1002) R(i,i), Rii endif R(i,i) = Rii + 1e-3 c zero below diagonal do j = i+1,n R(j,i) = 0e0 end do end do call clacpy('U',n,n,R,ldr,A,lda) c symmetrize A do i = 1,n-1 do j = i+1,n A(j,i) = conjg(A(i,j)) end do end do call cpotrf('U',n,R,ldr,info) if (info /= 0) stop 'fatal:error generating positive matrix' 1001 format ('WARNING: Possible bug in BLAS CHERK:') 1002 format ('WARNING: CHERK computed diagonal element (', +F6.3,F6.3,'), direct computation gives (',F6.3,F6.3,').') end subroutine subroutine zchgen(n,A,lda,R,ldr) integer n,lda,ldr double complex A(lda,n),R(ldr,n) external zherk,zlacpy,zpotrf,zdotc double complex zdotc,Rii integer i,j,info call zherk('U','C',n,n,1d0,A,lda,0d0,R,ldr) c augment to ensure strict positivity do i = 1,n c ZHERK is often buggy. We'll recompute the diagonal elements and c possibly warn about the bug. Rii = zdotc (n, A(1,i), 1, A(1,i), 1) if (.not. abs (Rii - R(i,i)) < 1d-10 * abs(Rii)) then write (*,1001) write (*,1002) R(i,i), Rii endif R(i,i) = Rii + 1d-3 c zero below diagonal do j = i+1,n R(j,i) = 0d0 end do end do call zlacpy('U',n,n,R,ldr,A,lda) c symmetrize A do i = 1,n-1 do j = i+1,n A(j,i) = conjg(A(i,j)) end do end do call zpotrf('U',n,R,ldr,info) if (info /= 0) stop 'fatal:error generating positive matrix' 1001 format ('WARNING: Possible bug in BLAS CHERK:') 1002 format ('WARNING: ZHERK computed diagonal element (', +F6.3,F6.3,'), direct computation gives (',F6.3,F6.3,').') end subroutine subroutine schchk(n,A,lda,R,ldr) integer n,lda,ldr real A(lda,n),R(ldr,n) real rnrm,slansy external ssyrk,slansy,spftol character*4 spftol real wrk(n) integer i,j c zero lower triangle of R do j = 1,n-1 do i = j+1,n R(i,j) = 0e0 end do end do c form A - R'*R call ssyrk('U','T',n,n,1e0,R,ldr,-1e0,A,lda) c get frobenius norm rnrm = slansy('M','U',n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine dchchk(n,A,lda,R,ldr) integer n,lda,ldr double precision A(lda,n),R(ldr,n) double precision rnrm,dlansy external dsyrk,dlansy,dpftol character*4 dpftol double precision wrk(n) integer i,j c zero lower triangle of R do j = 1,n-1 do i = j+1,n R(i,j) = 0d0 end do end do c form A - R'*R call dsyrk('U','T',n,n,1d0,R,ldr,-1d0,A,lda) c get frobenius norm rnrm = dlansy('M','U',n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine cchchk(n,A,lda,R,ldr) integer n,lda,ldr complex A(lda,n),R(ldr,n) real rnrm,clanhe external cherk,clanhe,spftol character*4 spftol real wrk(n) integer i,j c zero lower triangle of R do j = 1,n-1 do i = j+1,n R(i,j) = 0e0 end do end do c form A - R'*R call cherk('U','C',n,n,1e0,R,ldr,-1e0,A,lda) c get frobenius norm rnrm = clanhe('M','U',n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine zchchk(n,A,lda,R,ldr) integer n,lda,ldr double complex A(lda,n),R(ldr,n) double precision rnrm,zlanhe external zherk,zlanhe,dpftol character*4 dpftol double precision wrk(n) integer i,j c zero lower triangle of R do j = 1,n-1 do i = j+1,n R(i,j) = 0d0 end do end do c form A - R'*R call zherk('U','C',n,n,1d0,R,ldr,-1d0,A,lda) c get frobenius norm rnrm = zlanhe('M','U',n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine slugen(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr real A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j external sswap,slacpy,sgetrf if (m >= n) then call slacpy('0',m,n,A,lda,L,ldl) call sgetrf(m,n,L,ldl,ipiv,info) call slacpy('U',m,n,L,ldl,R,ldr) else call slacpy('0',m,n,A,lda,R,ldr) call sgetrf(m,n,R,ldr,ipiv,info) call slacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0e0 end do L(i,i) = 1e0 end do c permute the orig matrix do i = 1,min(m,n) j = ipiv(i) if (i /= j) then call sswap(n,A(i,1),lda,A(j,1),lda) end if end do end subroutine subroutine dlugen(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr double precision A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j external dswap,dlacpy,dgetrf if (m >= n) then call dlacpy('0',m,n,A,lda,L,ldl) call dgetrf(m,n,L,ldl,ipiv,info) call dlacpy('U',m,n,L,ldl,R,ldr) else call dlacpy('0',m,n,A,lda,R,ldr) call dgetrf(m,n,R,ldr,ipiv,info) call dlacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0d0 end do L(i,i) = 1d0 end do c permute the orig matrix do i = 1,min(m,n) j = ipiv(i) if (i /= j) then call dswap(n,A(i,1),lda,A(j,1),lda) end if end do end subroutine subroutine clugen(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j external cswap,clacpy,cgetrf if (m >= n) then call clacpy('0',m,n,A,lda,L,ldl) call cgetrf(m,n,L,ldl,ipiv,info) call clacpy('U',m,n,L,ldl,R,ldr) else call clacpy('0',m,n,A,lda,R,ldr) call cgetrf(m,n,R,ldr,ipiv,info) call clacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0d0 end do L(i,i) = 1e0 end do c permute the orig matrix do i = 1,min(m,n) j = ipiv(i) if (i /= j) then call cswap(n,A(i,1),lda,A(j,1),lda) end if end do end subroutine subroutine zlugen(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr double complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j external zswap,zlacpy,zgetrf if (m >= n) then call zlacpy('0',m,n,A,lda,L,ldl) call zgetrf(m,n,L,ldl,ipiv,info) call zlacpy('U',m,n,L,ldl,R,ldr) else call zlacpy('0',m,n,A,lda,R,ldr) call zgetrf(m,n,R,ldr,ipiv,info) call zlacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0d0 end do L(i,i) = 1d0 end do c permute the orig matrix do i = 1,min(m,n) j = ipiv(i) if (i /= j) then call zswap(n,A(i,1),lda,A(j,1),lda) end if end do end subroutine subroutine sluchk(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr real A(lda,n),L(ldl,min(m,n)),R(ldr,n) real rnrm,slange external sgemm,slange,spftol character*4 spftol real wrk(1) integer i,j c zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do c form A - L*R call sgemm('N','N',m,n,min(m,n),1e0,L,ldl,R,ldr,-1e0,A,lda) c get frobenius norm rnrm = slange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine dluchk(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr double precision A(lda,n),L(ldl,min(m,n)),R(ldr,n) double precision rnrm,dlange external dgemm,dlange,dpftol character*4 dpftol double precision wrk(1) integer i,j c zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do c form A - L*R call dgemm('N','N',m,n,min(m,n),1d0,L,ldl,R,ldr,-1d0,A,lda) c get frobenius norm rnrm = dlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine cluchk(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) real rnrm,clange external cgemm,clange,spftol character*4 spftol real wrk(1) integer i,j c zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do c form A - L*R call cgemm('N','N',m,n,min(m,n),(1e0,0e0),L,ldl,R,ldr,(-1e0,0e0), +A,lda) c get frobenius norm rnrm = clange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine zluchk(m,n,A,lda,L,ldl,R,ldr) integer m,n,lda,ldl,ldr double complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) double precision rnrm,zlange external zgemm,zlange,dpftol character*4 dpftol double precision wrk(1) integer i,j c zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do c form A - L*R call zgemm('N','N',m,n,min(m,n),(1d0,0d0),L,ldl,R,ldr,(-1d0,0d0), +A,lda) c get frobenius norm rnrm = zlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine slupgen(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) real A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j,tmp external sswap,slacpy,sgetrf if (m >= n) then call slacpy('0',m,n,A,lda,L,ldl) call sgetrf(m,n,L,ldl,ipiv,info) call slacpy('U',m,n,L,ldl,R,ldr) else call slacpy('0',m,n,A,lda,R,ldr) call sgetrf(m,n,R,ldr,ipiv,info) call slacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0e0 end do L(i,i) = 1e0 end do c generate permutation do i = 1,m p(i) = i end do do i = 1,min(m,n) j = ipiv(i) if (i /= j) then tmp = p(i) p(i) = p(j) p(j) = tmp end if end do c zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do end subroutine subroutine dlupgen(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) double precision A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j,tmp external dswap,dlacpy,dgetrf if (m >= n) then call dlacpy('0',m,n,A,lda,L,ldl) call dgetrf(m,n,L,ldl,ipiv,info) call dlacpy('U',m,n,L,ldl,R,ldr) else call dlacpy('0',m,n,A,lda,R,ldr) call dgetrf(m,n,R,ldr,ipiv,info) call dlacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0d0 end do L(i,i) = 1d0 end do c generate permutation do i = 1,m p(i) = i end do do i = 1,min(m,n) j = ipiv(i) if (i /= j) then tmp = p(i) p(i) = p(j) p(j) = tmp end if end do c zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0d0 end do end do end subroutine subroutine clupgen(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j,tmp external cswap,clacpy,cgetrf if (m >= n) then call clacpy('0',m,n,A,lda,L,ldl) call cgetrf(m,n,L,ldl,ipiv,info) call clacpy('U',m,n,L,ldl,R,ldr) else call clacpy('0',m,n,A,lda,R,ldr) call cgetrf(m,n,R,ldr,ipiv,info) call clacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0e0 end do L(i,i) = 1e0 end do c generate permutation do i = 1,m p(i) = i end do do i = 1,min(m,n) j = ipiv(i) if (i /= j) then tmp = p(i) p(i) = p(j) p(j) = tmp end if end do c zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0e0 end do end do end subroutine subroutine zlupgen(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) double complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) integer ipiv(min(m,n)),info,i,j,tmp external zswap,zlacpy,zgetrf if (m >= n) then call zlacpy('0',m,n,A,lda,L,ldl) call zgetrf(m,n,L,ldl,ipiv,info) call zlacpy('U',m,n,L,ldl,R,ldr) else call zlacpy('0',m,n,A,lda,R,ldr) call zgetrf(m,n,R,ldr,ipiv,info) call zlacpy('L',m,n,R,ldr,L,ldl) end if do i = 1,min(m,n) do j = 1,i-1 L(j,i) = 0d0 end do L(i,i) = 1d0 end do c generate permutation do i = 1,m p(i) = i end do do i = 1,min(m,n) j = ipiv(i) if (i /= j) then tmp = p(i) p(i) = p(j) p(j) = tmp end if end do c zero lower triangle of R do j = 1,n-1 do i = j+1,min(m,n) R(i,j) = 0d0 end do end do end subroutine c converts a linear permutation into LAPACK ipiv-style form subroutine p2ipiv(n,p) integer n,p(n) integer q(n),i,j,k do i = 1,n q(p(i)) = i end do do i = 1,n j = p(i) k = q(i) if (j /= i) then p(k) = j q(j) = k p(i) = j end if end do end subroutine subroutine slupchk(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) real A(lda,n),L(ldl,min(m,n)),R(ldr,n) real rnrm,slange external sswap,sgemm,slange,spftol character*4 spftol real wrk(1) integer i,j c convert p into successive swaps call p2ipiv(m,p) c form A - L*R do i = 1,m j = p(i) if (i /= j) then call sswap(n,A(i,1),lda,A(j,1),lda) end if end do call sgemm('N','N',m,n,min(m,n),1e0,L,ldl,R,ldr,-1e0,A,lda) c get frobenius norm rnrm = slange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine dlupchk(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) double precision A(lda,n),L(ldl,min(m,n)),R(ldr,n) double precision rnrm,dlange external dswap,dgemm,dlange,dpftol character*4 dpftol double precision wrk(1) integer i,j c convert p into successive swaps call p2ipiv(m,p) c form A - L*R do i = 1,m j = p(i) if (i /= j) then call dswap(n,A(i,1),lda,A(j,1),lda) end if end do call dgemm('N','N',m,n,min(m,n),1d0,L,ldl,R,ldr,-1d0,A,lda) c get frobenius norm rnrm = dlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine clupchk(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) real rnrm,clange external cswap,cgemm,clange,spftol character*4 spftol real wrk(1) integer i,j c convert p into successive swaps call p2ipiv(m,p) c form A - L*R do i = 1,m j = p(i) if (i /= j) then call cswap(n,A(i,1),lda,A(j,1),lda) end if end do call cgemm('N','N',m,n,min(m,n),(1e0,0e0),L,ldl,R,ldr,(-1e0,0e0), +A,lda) c get frobenius norm rnrm = clange('M',m,n,A,lda,wrk) write(*,1001) rnrm,spftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine subroutine zlupchk(m,n,A,lda,L,ldl,R,ldr,p) integer m,n,lda,ldl,ldr,p(m) double complex A(lda,n),L(ldl,min(m,n)),R(ldr,n) double precision rnrm,zlange external zswap,zgemm,zlange,dpftol character*4 dpftol double precision wrk(1) integer i,j c convert p into successive swaps call p2ipiv(m,p) c form A - L*R do i = 1,m j = p(i) if (i /= j) then call zswap(n,A(i,1),lda,A(j,1),lda) end if end do call zgemm('N','N',m,n,min(m,n),(1d0,0d0),L,ldl,R,ldr,(-1d0,0d0), +A,lda) c get frobenius norm rnrm = zlange('M',m,n,A,lda,wrk) write(*,1001) rnrm,dpftol(rnrm) return 1001 format(6x,'residual error = ',10x,E21.12,5x,A6) end subroutine qrupdate-1.1.2/test/report_results0000750035452500116100000000073011334757677016324 0ustar higheggeng#!/bin/sh OUTS=$* passed_total=0 failed_total=0 cat $OUTS # if awk exists, use it to print total statistics if which awk > /dev/null ; then awk '/total:/ { passed += $3; failed += $5; } END { printf " TOTAL: PASSED %3d FAILED %3d\n", passed, failed; }' $OUTS fi for out in $OUTS ; do if [ ! -s $out ] ; then echo " $out file empty (test crashed)!" else if grep -q WARNING $out ; then echo " $out produced warnings:" grep WARNING $out fi fi done qrupdate-1.1.2/test/tqr1up.f0000640035452500116100000001055511132663174014674 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tqr1up integer m,n write (*,*) write (*,*) 'testing QR rank-1 update routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 write (*,*) 'sqr1up test (full factorization):' call stest(m,n,0) write (*,*) 'dqr1up test (full factorization):' call dtest(m,n,0) write (*,*) 'cqr1up test (full factorization):' call ctest(m,n,0) write (*,*) 'zqr1up test (full factorization):' call ztest(m,n,0) write (*,*) 'sqr1up test (economized factorization):' call stest(m,n,1) write (*,*) 'dqr1up test (economized factorization):' call dtest(m,n,1) write (*,*) 'cqr1up test (economized factorization):' call ctest(m,n,1) write (*,*) 'zqr1up test (economized factorization):' call ztest(m,n,1) m = 40 n = 60 write (*,*) 'sqr1up test (rows < columns):' call stest(m,n,0) write (*,*) 'dqr1up test (rows < columns):' call dtest(m,n,0) write (*,*) 'cqr1up test (rows < columns):' call ctest(m,n,0) write (*,*) 'zqr1up test (rows < columns):' call ztest(m,n,0) call pstats end program subroutine stest(m,n,ec) integer m,n,ec real A(m,max(m,n)),Q(m,m),R(m,n),u(m),v(n),wrk(2*m) external srandg,sqrgen,sger,sqr1up,sqrchk integer k c set up random matrix & vectors call srandg(m,n,A,m) call srandg(m,1,u,m) call srandg(n,1,v,n) c generate QR decomposition call sqrgen(m,n,A,m,Q,m,R,m) c update A call sger(m,n,1e0,u,1,v,1,A,m) c update the QR decomposition k = m if (ec == 1) k = n call sqr1up(m,n,k,Q,m,R,m,u,v,wrk) c check result call sqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine dtest(m,n,ec) integer m,n,ec double precision A(m,max(m,n)),Q(m,m),R(m,n),u(m),v(n),wrk(2*m) external drandg,dqrgen,dger,dqr1up,dqrchk integer k c set up random matrix & vectors call drandg(m,n,A,m) call drandg(m,1,u,m) call drandg(n,1,v,n) c generate QR decomposition call dqrgen(m,n,A,m,Q,m,R,m) c update A call dger(m,n,1d0,u,1,v,1,A,m) c update the QR decomposition k = m if (ec == 1) k = n call dqr1up(m,n,k,Q,m,R,m,u,v,wrk) c check result call dqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine ctest(m,n,ec) integer m,n,ec complex A(m,max(m,n)),Q(m,m),R(m,n),u(m),v(n),wrk(m) real rwrk(m) external crandg,cqrgen,cgerc,cqr1up,cqrchk integer k c set up random matrix & vectors call crandg(m,n,A,m) call crandg(m,1,u,m) call crandg(n,1,v,n) c generate QR decomposition call cqrgen(m,n,A,m,Q,m,R,m) c update A call cgerc(m,n,(1e0,0e0),u,1,v,1,A,m) c update the QR decomposition k = m if (ec == 1) k = n call cqr1up(m,n,k,Q,m,R,m,u,v,wrk,rwrk) c check result call cqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine ztest(m,n,ec) integer m,n,ec double complex A(m,max(m,n)),Q(m,m),R(m,n),u(m),v(n),wrk(m) double precision rwrk(m) external zrandg,zqrgen,zgerc,zqr1up,zqrchk integer k c set up random matrix & vectors call zrandg(m,n,A,m) call zrandg(m,1,u,m) call zrandg(n,1,v,n) c generate QR decomposition call zqrgen(m,n,A,m,Q,m,R,m) c update A call zgerc(m,n,(1d0,0d0),u,1,v,1,A,m) c update the QR decomposition k = m if (ec == 1) k = n call zqr1up(m,n,k,Q,m,R,m,u,v,wrk,rwrk) c check result call zqrchk(m,n,k,A,m,Q,m,R,m) end subroutine qrupdate-1.1.2/test/tqrinc.f0000640035452500116100000001046111132663174014734 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tqrinc integer m,n,j write (*,*) write (*,*) 'testing QR column insert routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 j = 28 write (*,*) 'sqrinc test (full factorization):' call stest(m,n,j,0) write (*,*) 'dqrinc test (full factorization):' call dtest(m,n,j,0) write (*,*) 'cqrinc test (full factorization):' call ctest(m,n,j,0) write (*,*) 'zqrinc test (full factorization):' call ztest(m,n,j,0) write (*,*) 'sqrinc test (economized factorization):' call stest(m,n,j,1) write (*,*) 'dqrinc test (economized factorization):' call dtest(m,n,j,1) write (*,*) 'cqrinc test (economized factorization):' call ctest(m,n,j,1) write (*,*) 'zqrinc test (economized factorization):' call ztest(m,n,j,1) call pstats end program subroutine stest(m,n,j,ec) integer m,n,j,ec real A(m,max(m,n+1)),Q(m,m),R(m,n+1),u(m),wrk(m) external srandg,sqrgen,scopy,sqrinc,sqrchk integer k,i c set up random matrix & vector call srandg(m,n,A,m) call srandg(m,1,u,m) c generate QR decomposition call sqrgen(m,n,A,m,Q,m,R,m) c update A do i = n,j,-1 call scopy(m,A(1,i),1,A(1,i+1),1) end do call scopy(m,u,1,A(1,j),1) c update the QR decomposition k = m if (ec == 1) k = n call sqrinc(m,n,k,Q,m,R,m,j,u,wrk) c check result if (ec == 1) k = n+1 call sqrchk(m,n+1,k,A,m,Q,m,R,m) end subroutine subroutine dtest(m,n,j,ec) integer m,n,j,ec double precision A(m,max(m,n+1)),Q(m,m),R(m,n+1),u(m),wrk(m) external drandg,dqrgen,dcopy,dqrinc,dqrchk integer k,i c set up random matrix & vector call drandg(m,n,A,m) call drandg(m,1,u,m) c generate QR decomposition call dqrgen(m,n,A,m,Q,m,R,m) c update A do i = n,j,-1 call dcopy(m,A(1,i),1,A(1,i+1),1) end do call dcopy(m,u,1,A(1,j),1) c update the QR decomposition k = m if (ec == 1) k = n call dqrinc(m,n,k,Q,m,R,m,j,u,wrk) c check result if (ec == 1) k = n+1 call dqrchk(m,n+1,k,A,m,Q,m,R,m) end subroutine subroutine ctest(m,n,j,ec) integer m,n,j,ec complex A(m,max(m,n+1)),Q(m,m),R(m,n+1),u(m),wrk(m) external crandg,cqrgen,ccopy,cqrinc,cqrchk integer k,i c set up random matrix & vector call crandg(m,n,A,m) call crandg(m,1,u,m) c generate QR decomposition call cqrgen(m,n,A,m,Q,m,R,m) c update A do i = n,j,-1 call ccopy(m,A(1,i),1,A(1,i+1),1) end do call ccopy(m,u,1,A(1,j),1) c update the QR decomposition k = m if (ec == 1) k = n call cqrinc(m,n,k,Q,m,R,m,j,u,wrk) c check result if (ec == 1) k = n+1 call cqrchk(m,n+1,k,A,m,Q,m,R,m) end subroutine subroutine ztest(m,n,j,ec) integer m,n,j,ec double complex A(m,max(m,n+1)),Q(m,m),R(m,n+1),u(m),wrk(m) external zrandg,zqrgen,zcopy,zqrinc,zqrchk integer k,i c set up random matrix & vector call zrandg(m,n,A,m) call zrandg(m,1,u,m) c generate QR decomposition call zqrgen(m,n,A,m,Q,m,R,m) c update A do i = n,j,-1 call zcopy(m,A(1,i),1,A(1,i+1),1) end do call zcopy(m,u,1,A(1,j),1) c update the QR decomposition k = m if (ec == 1) k = n call zqrinc(m,n,k,Q,m,R,m,j,u,wrk) c check result if (ec == 1) k = n+1 call zqrchk(m,n+1,k,A,m,Q,m,R,m) end subroutine qrupdate-1.1.2/test/tlu1up.f0000640035452500116100000000747411262345331014674 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tlu1up integer m,n write (*,*) write (*,*) 'testing LU rank-1 update routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 write (*,*) 'slu1up test (rows > columns):' call stest(m,n) write (*,*) 'dlu1up test (rows > columns):' call dtest(m,n) write (*,*) 'clu1up test (rows > columns):' call ctest(m,n) write (*,*) 'zlu1up test (rows > columns):' call ztest(m,n) m = 40 n = 60 write (*,*) 'slu1up test (rows < columns):' call stest(m,n) write (*,*) 'dlu1up test (rows < columns):' call dtest(m,n) write (*,*) 'clu1up test (rows < columns):' call ctest(m,n) write (*,*) 'zlu1up test (rows < columns):' call ztest(m,n) call pstats end program subroutine stest(m,n) integer m,n real A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n) external srandg,slugen,sger,slu1up,sluchk integer k c set up random matrix & vectors call srandg(m,n,A,m) call srandg(m,1,u,m) call srandg(n,1,v,n) k = min(m,n) c generate LU decomposition call slugen(m,n,A,m,L,m,R,k) c update A call sger(m,n,1e0,u,1,v,1,A,m) c update the LU decomposition call slu1up(m,n,L,m,R,k,u,v) c check result call sluchk(m,n,A,m,L,m,R,k) end subroutine subroutine dtest(m,n) integer m,n double precision A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n) external drandg,dlugen,dger,dlu1up,dluchk integer k c set up random matrix & vectors call drandg(m,n,A,m) call drandg(m,1,u,m) call drandg(n,1,v,n) k = min(m,n) c generate LU decomposition call dlugen(m,n,A,m,L,m,R,k) c update A call dger(m,n,1d0,u,1,v,1,A,m) c update the LU decomposition call dlu1up(m,n,L,m,R,k,u,v) c check result call dluchk(m,n,A,m,L,m,R,k) end subroutine subroutine ctest(m,n) integer m,n complex A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n) external crandg,clugen,cgeru,clu1up,cluchk integer k c set up random matrix & vectors call crandg(m,n,A,m) call crandg(m,1,u,m) call crandg(n,1,v,n) k = min(m,n) c generate LU decomposition call clugen(m,n,A,m,L,m,R,k) c update A call cgeru(m,n,(1e0,0e0),u,1,v,1,A,m) c update the LU decomposition call clu1up(m,n,L,m,R,k,u,v) c check result call cluchk(m,n,A,m,L,m,R,k) end subroutine subroutine ztest(m,n) integer m,n double complex A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n) external zrandg,zlugen,zgeru,zlu1up,zluchk integer k c set up random matrix & vectors call zrandg(m,n,A,m) call zrandg(m,1,u,m) call zrandg(n,1,v,n) k = min(m,n) c generate LU decomposition call zlugen(m,n,A,m,L,m,R,k) c update A call zgeru(m,n,(1d0,0d0),u,1,v,1,A,m) c update the LU decomposition call zlu1up(m,n,L,m,R,k,u,v) c check result call zluchk(m,n,A,m,L,m,R,k) end subroutine qrupdate-1.1.2/test/tch1up.f0000640035452500116100000000626611132663174014650 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tch1up integer n write (*,*) write (*,*) 'testing Cholesky rank-1 update routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) n = 50 write (*,*) 'sch1up test:' call stest(n) write (*,*) 'dch1up test:' call dtest(n) write (*,*) 'cch1up test:' call ctest(n) write (*,*) 'zch1up test:' call ztest(n) call pstats end program subroutine stest(n) integer n real A(n,n),R(n,n),u(n),wrk(n) external srandg,schgen,ssyr,sch1up,schchk c set up random matrix & vectors call srandg(n,n,A,n) call srandg(n,1,u,n) c generate A'*A and its Cholesky decomposition call schgen(n,A,n,R,n) c update the matrix A call ssyr('U',n,1e0,u,1,A,n) c update the Cholesky decomposition call sch1up(n,R,n,u,wrk) c check result call schchk(n,A,n,R,n) end subroutine subroutine dtest(n) integer n double precision A(n,n),R(n,n),u(n),wrk(n) external drandg,dchgen,dsyr,dch1up,dchchk c set up random matrix & vectors call drandg(n,n,A,n) call drandg(n,1,u,n) c generate A'*A and its Cholesky decomposition call dchgen(n,A,n,R,n) c update the matrix A call dsyr('U',n,1d0,u,1,A,n) c update the Cholesky decomposition call dch1up(n,R,n,u,wrk) c check result call dchchk(n,A,n,R,n) end subroutine subroutine ctest(n) integer n complex A(n,n),R(n,n),u(n) real rwrk(n) external crandg,cchgen,cher,cch1up,cchchk c set up random matrix & vectors call crandg(n,n,A,n) call crandg(n,1,u,n) c generate A'*A and its Cholesky decomposition call cchgen(n,A,n,R,n) c update the matrix A call cher('U',n,1e0,u,1,A,n) c update the Cholesky decomposition call cch1up(n,R,n,u,rwrk) c check result call cchchk(n,A,n,R,n) end subroutine subroutine ztest(n) integer n double complex A(n,n),R(n,n),u(n) double precision rwrk(n) external zrandg,zchgen,zher,zch1up,zchchk c set up random matrix & vectors call zrandg(n,n,A,n) call zrandg(n,1,u,n) c generate A'*A and its Cholesky decomposition call zchgen(n,A,n,R,n) c update the matrix A call zher('U',n,1d0,u,1,A,n) c update the Cholesky decomposition call zch1up(n,R,n,u,rwrk) c check result call zchchk(n,A,n,R,n) end subroutine qrupdate-1.1.2/test/Makefile0000640035452500116100000000236111334737540014730 0ustar higheggeng# Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic # # Author: Jaroslav Hajek # # This file is part of qrupdate. # # qrupdate is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this software; see the file COPYING. If not, see # . # include ../Makeconf LIBS= $(BLAS) $(LAPACK) PROGS=tqr1up tqrinc tqrdec tqrshc tqrinr tqrder \ tch1up tch1dn tchinx tchdex tchshx \ tlu1up tlup1up OUTS=$(PROGS:%=%.out) tests: $(OUTS) ./report_results $(OUTS) $(OUTS): %.out: % echo > $@ ./$< | tee $@ $(PROGS): % : %.f utils.o ../libqrupdate.a $(FC) $(FFLAGS) -o $@ $^ $(LIBS) utils.o: utils.f $(FC) $(FFLAGS) -c $< ../libqrupdate.a: make -C ../ lib clean: rm -f *.o $(PROGS) $(OUTS) qrupdate-1.1.2/test/tqrder.f0000640035452500116100000000671511132663174014744 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tqrder integer m,n,j write (*,*) write (*,*) 'testing QR row delete routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 j = 30 write (*,*) 'sqrder test (full factorization):' call stest(m,n,j) write (*,*) 'dqrder test (full factorization):' call dtest(m,n,j) write (*,*) 'cqrder test (full factorization):' call ctest(m,n,j) write (*,*) 'zqrder test (full factorization):' call ztest(m,n,j) call pstats end program subroutine stest(m,n,j) integer m,n,j real A(m,max(m,n)),Q(m,m),R(m,n),wrk(2*m) external srandg,sqrgen,scopy,sqrder,sqrchk integer i c set up random matrix & vector call srandg(m,n,A,m) c generate QR decomposition call sqrgen(m,n,A,m,Q,m,R,m) c update A do i = j,m-1 call scopy(n,A(i+1,1),m,A(i,1),m) end do c update the QR decomposition call sqrder(m,n,Q,m,R,m,j,wrk) c check result call sqrchk(m-1,n,m-1,A,m,Q,m,R,m) end subroutine subroutine dtest(m,n,j) integer m,n,j double precision A(m,max(m,n)),Q(m,m),R(m,n),wrk(2*m) external drandg,dqrgen,dcopy,dqrder,dqrchk integer i c set up random matrix & vector call drandg(m,n,A,m) c generate QR decomposition call dqrgen(m,n,A,m,Q,m,R,m) c update A do i = j,m-1 call dcopy(n,A(i+1,1),m,A(i,1),m) end do c update the QR decomposition call dqrder(m,n,Q,m,R,m,j,wrk) c check result call dqrchk(m-1,n,m-1,A,m,Q,m,R,m) end subroutine subroutine ctest(m,n,j) integer m,n,j complex A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) real rwrk(m) external crandg,cqrgen,ccopy,cqrder,cqrchk integer i c set up random matrix & vector call crandg(m,n,A,m) c generate QR decomposition call cqrgen(m,n,A,m,Q,m,R,m) c update A do i = j,m-1 call ccopy(n,A(i+1,1),m,A(i,1),m) end do c update the QR decomposition call cqrder(m,n,Q,m,R,m,j,wrk,rwrk) c check result call cqrchk(m-1,n,m-1,A,m,Q,m,R,m) end subroutine subroutine ztest(m,n,j) integer m,n,j double complex A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) double precision rwrk(m) external zrandg,zqrgen,zcopy,zqrder,zqrchk integer i c set up random matrix & vector call zrandg(m,n,A,m) c generate QR decomposition call zqrgen(m,n,A,m,Q,m,R,m) c update A do i = j,m-1 call zcopy(n,A(i+1,1),m,A(i,1),m) end do c update the QR decomposition call zqrder(m,n,Q,m,R,m,j,wrk,rwrk) c check result call zqrchk(m-1,n,m-1,A,m,Q,m,R,m) end subroutine qrupdate-1.1.2/test/tchinx.f0000640035452500116100000000735011132663174014734 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tchinx integer n,j write (*,*) write (*,*) 'testing Cholesky symmetric insert routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) n = 50 j = 25 write (*,*) 'schinx test:' call stest(n,j) write (*,*) 'dchinx test:' call dtest(n,j) write (*,*) 'cchinx test:' call ctest(n,j) write (*,*) 'zchinx test:' call ztest(n,j) call pstats end program subroutine stest(n,j) integer n,j real A(n,n),R(n,n),u(n),wrk(n) external srandg,schgen,schinx,schchk integer info,i c set up random matrix & vectors call srandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call schgen(n,A,n,R,n) c save the row/column do i = 1,j u(i) = A(i,j) end do do i = j+1,n u(i) = A(j,i) end do c update the Cholesky decomposition call schdex(n,R,n,j,wrk) c put the row/column back call schinx(n-1,R,n,j,u,wrk,info) c check result call schchk(n,A,n,R,n) end subroutine subroutine dtest(n,j) integer n,j double precision A(n,n),R(n,n),u(n),wrk(n) external drandg,dchgen,dchinx,dchchk integer info,i c set up random matrix & vectors call drandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call dchgen(n,A,n,R,n) c save the row/column do i = 1,j u(i) = A(i,j) end do do i = j+1,n u(i) = A(j,i) end do c update the Cholesky decomposition call dchdex(n,R,n,j,wrk) c put the row/column back call dchinx(n-1,R,n,j,u,wrk,info) c check result call dchchk(n,A,n,R,n) end subroutine subroutine ctest(n,j) integer n,j complex A(n,n),R(n,n),u(n) real rwrk(n) external crandg,cchgen,cchinx,cchchk integer info,i c set up random matrix & vectors call crandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call cchgen(n,A,n,R,n) c save the row/column do i = 1,j u(i) = A(i,j) end do do i = j+1,n u(i) = conjg(A(j,i)) end do c update the Cholesky decomposition call cchdex(n,R,n,j,rwrk) c put the row/column back call cchinx(n-1,R,n,j,u,rwrk,info) c check result call cchchk(n,A,n,R,n) end subroutine subroutine ztest(n,j) integer n,j double complex A(n,n),R(n,n),u(n) double precision rwrk(n) external zrandg,zchgen,zchinx,zchchk integer info,i c set up random matrix & vectors call zrandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call zchgen(n,A,n,R,n) c save the row/column do i = 1,j u(i) = A(i,j) end do do i = j+1,n u(i) = conjg(A(j,i)) end do c update the Cholesky decomposition call zchdex(n,R,n,j,rwrk) c put the row/column back call zchinx(n-1,R,n,j,u,rwrk,info) c check result call zchchk(n,A,n,R,n) end subroutine qrupdate-1.1.2/test/tch1dn.f0000640035452500116100000000665011132663174014622 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tch1dn integer n write (*,*) write (*,*) 'testing Cholesky rank-1 downdate routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) n = 50 write (*,*) 'sch1dn test:' call stest(n) write (*,*) 'dch1dn test:' call dtest(n) write (*,*) 'cch1dn test:' call ctest(n) write (*,*) 'zch1dn test:' call ztest(n) call pstats end program subroutine stest(n) integer n real A(n,n),R(n,n),u(n),wrk(2*n) external srandg,scopy,schgen,sch1up,schchk integer info c set up random matrix & vectors call srandg(n,n,A,n) call srandg(n,1,u,n) call scopy(n,u,1,wrk,1) c generate A'*A and its Cholesky decomposition call schgen(n,A,n,R,n) c update the Cholesky decomposition call sch1up(n,R,n,u,wrk(1+n)) c downdate it back call sch1dn(n,R,n,wrk,wrk(1+n),info) c check result call schchk(n,A,n,R,n) end subroutine subroutine dtest(n) integer n double precision A(n,n),R(n,n),u(n),wrk(2*n) external drandg,dcopy,dchgen,dch1up,dchchk integer info c set up random matrix & vectors call drandg(n,n,A,n) call drandg(n,1,u,n) call dcopy(n,u,1,wrk,1) c generate A'*A and its Cholesky decomposition call dchgen(n,A,n,R,n) c update the Cholesky decomposition call dch1up(n,R,n,u,wrk(1+n)) c downdate it back call dch1dn(n,R,n,wrk,wrk(1+n),info) c check result call dchchk(n,A,n,R,n) end subroutine subroutine ctest(n) integer n complex A(n,n),R(n,n),u(n),wrk(n) real rwrk(n) external crandg,ccopy,cchgen,cch1up,cchchk integer info c set up random matrix & vectors call crandg(n,n,A,n) call crandg(n,1,u,n) call ccopy(n,u,1,wrk,1) c generate A'*A and its Cholesky decomposition call cchgen(n,A,n,R,n) c update the Cholesky decomposition call cch1up(n,R,n,u,rwrk) c downdate it back call cch1dn(n,R,n,wrk,rwrk,info) c check result call cchchk(n,A,n,R,n) end subroutine subroutine ztest(n) integer n double complex A(n,n),R(n,n),u(n),wrk(n) double precision rwrk(n) external zrandg,zcopy,zchgen,zch1up,zchchk integer info c set up random matrix & vectors call zrandg(n,n,A,n) call zrandg(n,1,u,n) call zcopy(n,u,1,wrk,1) c generate A'*A and its Cholesky decomposition call zchgen(n,A,n,R,n) c update the Cholesky decomposition call zch1up(n,R,n,u,rwrk) c downdate it back call zch1dn(n,R,n,wrk,rwrk,info) c check result call zchchk(n,A,n,R,n) end subroutine qrupdate-1.1.2/test/tchshx.f0000640035452500116100000000741711132663174014744 0ustar higheggeng program tchshx integer n,i,j write (*,*) write (*,*) 'testing QR column shift routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) n = 50 i = 20 j = 40 write (*,*) 'schshx test (left shift):' call stest(n,i,j) write (*,*) 'dchshx test (left shift):' call dtest(n,i,j) write (*,*) 'cchshx test (left shift):' call ctest(n,i,j) write (*,*) 'zchshx test (left shift):' call ztest(n,i,j) i = 40 j = 20 write (*,*) 'schshx test (right shift):' call stest(n,i,j) write (*,*) 'dchshx test (right shift):' call dtest(n,i,j) write (*,*) 'cchshx test (right shift):' call ctest(n,i,j) write (*,*) 'zchshx test (right shift):' call ztest(n,i,j) call pstats end program subroutine stest(n,i,j) integer n,i,j real A(n,n),R(n,n),wrk(2*n) external srandg,schgen,sswap,schshx,schchk integer k c set up random matrix call srandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call schgen(n,A,n,R,n) c update matrix if (i < j) then do k = i,j-1 call sswap(n,A(1,k),1,A(1,k+1),1) call sswap(n,A(k,1),n,A(k+1,1),n) end do else if (i > j) then do k = i,j+1,-1 call sswap(n,A(1,k),1,A(1,k-1),1) call sswap(n,A(k,1),n,A(k-1,1),n) end do end if c update factorization call schshx(n,R,n,i,j,wrk) c check result call schchk(n,A,n,R,n) end subroutine subroutine dtest(n,i,j) integer n,i,j double precision A(n,n),R(n,n),wrk(2*n) external drandg,dchgen,dswap,dchshx,dchchk integer k c set up random matrix call drandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call dchgen(n,A,n,R,n) c update matrix if (i < j) then do k = i,j-1 call dswap(n,A(1,k),1,A(1,k+1),1) call dswap(n,A(k,1),n,A(k+1,1),n) end do else if (i > j) then do k = i,j+1,-1 call dswap(n,A(1,k),1,A(1,k-1),1) call dswap(n,A(k,1),n,A(k-1,1),n) end do end if c update factorization call dchshx(n,R,n,i,j,wrk) c check result call dchchk(n,A,n,R,n) end subroutine subroutine ctest(n,i,j) integer n,i,j complex A(n,n),R(n,n),wrk(n) real rwrk(n) external crandg,cchgen,cswap,cchshx,cchchk integer k c set up random matrix call crandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call cchgen(n,A,n,R,n) c update matrix if (i < j) then do k = i,j-1 call cswap(n,A(1,k),1,A(1,k+1),1) call cswap(n,A(k,1),n,A(k+1,1),n) end do else if (i > j) then do k = i,j+1,-1 call cswap(n,A(1,k),1,A(1,k-1),1) call cswap(n,A(k,1),n,A(k-1,1),n) end do end if c update factorization call cchshx(n,R,n,i,j,wrk,rwrk) c check result call cchchk(n,A,n,R,n) end subroutine subroutine ztest(n,i,j) integer n,i,j double complex A(n,n),R(n,n),wrk(n) double precision rwrk(n) external zrandg,zchgen,zswap,zchshx,zchchk integer k c set up random matrix call zrandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call zchgen(n,A,n,R,n) c update matrix if (i < j) then do k = i,j-1 call zswap(n,A(1,k),1,A(1,k+1),1) call zswap(n,A(k,1),n,A(k+1,1),n) end do else if (i > j) then do k = i,j+1,-1 call zswap(n,A(1,k),1,A(1,k-1),1) call zswap(n,A(k,1),n,A(k-1,1),n) end do end if c update factorization call zchshx(n,R,n,i,j,wrk,rwrk) c check result call zchchk(n,A,n,R,n) end subroutine qrupdate-1.1.2/test/tlup1up.f0000640035452500116100000000770111263327111015042 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tlup1up integer m,n write (*,*) write (*,*) 'testing pivoted LU rank-1 update routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 write (*,*) 'slup1up test (rows > columns):' call stest(m,n) write (*,*) 'dlup1up test (rows > columns):' call dtest(m,n) write (*,*) 'clup1up test (rows > columns):' call ctest(m,n) write (*,*) 'zlup1up test (rows > columns):' call ztest(m,n) m = 40 n = 60 write (*,*) 'slup1up test (rows < columns):' call stest(m,n) write (*,*) 'dlup1up test (rows < columns):' call dtest(m,n) write (*,*) 'clup1up test (rows < columns):' call ctest(m,n) write (*,*) 'zlup1up test (rows < columns):' call ztest(m,n) call pstats end program subroutine stest(m,n) integer m,n real A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n),w(m) external srandg,slugen,sger,slup1up,sluchk integer k,p(m) c set up random matrix & vectors call srandg(m,n,A,m) call srandg(m,1,u,m) call srandg(n,1,v,n) k = min(m,n) c generate LU decomposition call slupgen(m,n,A,m,L,m,R,k,p) c update A call sger(m,n,1e0,u,1,v,1,A,m) c update the pivoted LU decomposition call slup1up(m,n,L,m,R,k,p,u,v,w) c check result call slupchk(m,n,A,m,L,m,R,k,p) end subroutine subroutine dtest(m,n) integer m,n double precision A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n),w(m) external drandg,dlugen,dger,dlup1up,dluchk integer k,p(m) c set up random matrix & vectors call drandg(m,n,A,m) call drandg(m,1,u,m) call drandg(n,1,v,n) k = min(m,n) c generate LU decomposition call dlupgen(m,n,A,m,L,m,R,k,p) c update A call dger(m,n,1d0,u,1,v,1,A,m) c update the pivoted LU decomposition call dlup1up(m,n,L,m,R,k,p,u,v,w) c check result call dlupchk(m,n,A,m,L,m,R,k,p) end subroutine subroutine ctest(m,n) integer m,n complex A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n),w(m) external crandg,clugen,cgeru,clup1up,cluchk integer k,p(m) c set up random matrix & vectors call crandg(m,n,A,m) call crandg(m,1,u,m) call crandg(n,1,v,n) k = min(m,n) c generate LU decomposition call clupgen(m,n,A,m,L,m,R,k,p) c update A call cgeru(m,n,(1e0,0e0),u,1,v,1,A,m) c update the pivoted LU decomposition call clup1up(m,n,L,m,R,k,p,u,v,w) c check result call clupchk(m,n,A,m,L,m,R,k,p) end subroutine subroutine ztest(m,n) integer m,n double complex A(m,n),L(m,min(m,n)),R(min(m,n),n),u(m),v(n),w(m) external zrandg,zlugen,zgeru,zlup1up,zluchk integer k,p(m) c set up random matrix & vectors call zrandg(m,n,A,m) call zrandg(m,1,u,m) call zrandg(n,1,v,n) k = min(m,n) c generate LU decomposition call zlupgen(m,n,A,m,L,m,R,k,p) c update A call zgeru(m,n,(1d0,0d0),u,1,v,1,A,m) c update the pivoted LU decomposition call zlup1up(m,n,L,m,R,k,p,u,v,w) c check result call zlupchk(m,n,A,m,L,m,R,k,p) end subroutine qrupdate-1.1.2/test/tchdex.f0000640035452500116100000000722011132663174014712 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tchdex integer n,j write (*,*) write (*,*) 'testing Cholesky symmetric delete routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) n = 50 j = 15 write (*,*) 'schdex test:' call stest(n,j) write (*,*) 'dchdex test:' call dtest(n,j) write (*,*) 'cchdex test:' call ctest(n,j) write (*,*) 'zchdex test:' call ztest(n,j) call pstats end program subroutine stest(n,j) integer n,j real A(n,n),R(n,n),wrk(n) external srandg,schgen,schdex,schchk integer i,k c set up random matrix & vectors call srandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call schgen(n,A,n,R,n) c update the matrix A do k = j,n-1 do i = 1,j-1 A(i,k) = A(i,k+1) end do do i = j,k A(i,k) = A(i+1,k+1) end do end do c update the Cholesky decomposition call schdex(n,R,n,j,wrk) c check result call schchk(n-1,A,n,R,n) end subroutine subroutine dtest(n,j) integer n,j double precision A(n,n),R(n,n),wrk(n) external drandg,dchgen,dchdex,dchchk integer i,k c set up random matrix & vectors call drandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call dchgen(n,A,n,R,n) c update the matrix A do k = j,n-1 do i = 1,j-1 A(i,k) = A(i,k+1) end do do i = j,k A(i,k) = A(i+1,k+1) end do end do c update the Cholesky decomposition call dchdex(n,R,n,j,wrk) c check result call dchchk(n-1,A,n,R,n) end subroutine subroutine ctest(n,j) integer n,j complex A(n,n),R(n,n) real rwrk(n) external crandg,cchgen,cchdex,cchchk integer i,k c set up random matrix & vectors call crandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call cchgen(n,A,n,R,n) c update the matrix A do k = j,n-1 do i = 1,j-1 A(i,k) = A(i,k+1) end do do i = j,k A(i,k) = A(i+1,k+1) end do end do c update the Cholesky decomposition call cchdex(n,R,n,j,rwrk) c check result call cchchk(n-1,A,n,R,n) end subroutine subroutine ztest(n,j) integer n,j double complex A(n,n),R(n,n) double precision rwrk(n) external zrandg,zchgen,zchdex,zchchk integer i,k c set up random matrix & vectors call zrandg(n,n,A,n) c generate A'*A and its Cholesky decomposition call zchgen(n,A,n,R,n) c update the matrix A do k = j,n-1 do i = 1,j-1 A(i,k) = A(i,k+1) end do do i = j,k A(i,k) = A(i+1,k+1) end do end do c update the Cholesky decomposition call zchdex(n,R,n,j,rwrk) c check result call zchchk(n-1,A,n,R,n) end subroutine qrupdate-1.1.2/test/tqrdec.f0000640035452500116100000001002111132663174014706 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tqrdec integer m,n,j write (*,*) write (*,*) 'testing QR column delete routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 40 j = 12 write (*,*) 'sqrdec test (full factorization):' call stest(m,n,j,0) write (*,*) 'dqrdec test (full factorization):' call dtest(m,n,j,0) write (*,*) 'cqrdec test (full factorization):' call ctest(m,n,j,0) write (*,*) 'zqrdec test (full factorization):' call ztest(m,n,j,0) write (*,*) 'sqrdec test (economized factorization):' call stest(m,n,j,1) write (*,*) 'dqrdec test (economized factorization):' call dtest(m,n,j,1) write (*,*) 'cqrdec test (economized factorization):' call ctest(m,n,j,1) write (*,*) 'zqrdec test (economized factorization):' call ztest(m,n,j,1) call pstats end program subroutine stest(m,n,j,ec) integer m,n,j,ec real A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) external srandg,sqrgen,scopy,sqrdec,sqrchk integer k,i c set up random matrix & vector call srandg(m,n,A,m) c generate QR decomposition call sqrgen(m,n,A,m,Q,m,R,m) c update A do i = j,n-1 call scopy(m,A(1,i+1),1,A(1,i),1) end do c update the QR decomposition k = m if (ec == 1) k = n call sqrdec(m,n,k,Q,m,R,m,j,wrk) c check result if (ec == 1) k = n+1 call sqrchk(m,n-1,k,A,m,Q,m,R,m) end subroutine subroutine dtest(m,n,j,ec) integer m,n,j,ec double precision A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) external drandg,dqrgen,dcopy,dqrdec,dqrchk integer k,i c set up random matrix & vector call drandg(m,n,A,m) c generate QR decomposition call dqrgen(m,n,A,m,Q,m,R,m) c update A do i = j,n-1 call dcopy(m,A(1,i+1),1,A(1,i),1) end do c update the QR decomposition k = m if (ec == 1) k = n call dqrdec(m,n,k,Q,m,R,m,j,wrk) c check result if (ec == 1) k = n+1 call dqrchk(m,n-1,k,A,m,Q,m,R,m) end subroutine subroutine ctest(m,n,j,ec) integer m,n,j,ec complex A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) external crandg,cqrgen,ccopy,cqrdec,cqrchk integer k,i c set up random matrix & vector call crandg(m,n,A,m) c generate QR decomposition call cqrgen(m,n,A,m,Q,m,R,m) c update A do i = j,n-1 call ccopy(m,A(1,i+1),1,A(1,i),1) end do c update the QR decomposition k = m if (ec == 1) k = n call cqrdec(m,n,k,Q,m,R,m,j,wrk) c check result if (ec == 1) k = n+1 call cqrchk(m,n-1,k,A,m,Q,m,R,m) end subroutine subroutine ztest(m,n,j,ec) integer m,n,j,ec double complex A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) external zrandg,zqrgen,zcopy,zqrdec,zqrchk integer k,i c set up random matrix & vector call zrandg(m,n,A,m) c generate QR decomposition call zqrgen(m,n,A,m,Q,m,R,m) c update A do i = j,n-1 call zcopy(m,A(1,i+1),1,A(1,i),1) end do c update the QR decomposition k = m if (ec == 1) k = n call zqrdec(m,n,k,Q,m,R,m,j,wrk) c check result if (ec == 1) k = n+1 call zqrchk(m,n-1,k,A,m,Q,m,R,m) end subroutine qrupdate-1.1.2/test/tqrshc.f0000640035452500116100000001236511133063167014742 0ustar higheggengc Copyright (C) 2008, 2009 VZLU Prague, a.s., Czech Republic c c Author: Jaroslav Hajek c c This file is part of qrupdate. c c qrupdate is free software; you can redistribute it and/or modify c it under the terms of the GNU General Public License as published by c the Free Software Foundation; either version 3 of the License, or c (at your option) any later version. c c This program is distributed in the hope that it will be useful, c but WITHOUT ANY WARRANTY; without even the implied warranty of c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the c GNU General Public License for more details. c c You should have received a copy of the GNU General Public License c along with this software; see the file COPYING. If not, see c . c program tqrshc integer m,n,i,j write (*,*) write (*,*) 'testing QR column shift routines.' write (*,*) 'All residual errors are expected to be small.' write (*,*) m = 60 n = 50 i = 20 j = 40 write (*,*) 'sqrshc test (left shift, full factorization):' call stest(m,n,i,j,0) write (*,*) 'dqrshc test (left shift, full factorization):' call dtest(m,n,i,j,0) write (*,*) 'cqrshc test (left shift, full factorization):' call ctest(m,n,i,j,0) write (*,*) 'zqrshc test (left shift, full factorization):' call ztest(m,n,i,j,0) i = 40 j = 20 write (*,*) 'sqrshc test (right shift, economized factorization):' call stest(m,n,i,j,1) write (*,*) 'dqrshc test (right shift, economized factorization):' call dtest(m,n,i,j,1) write (*,*) 'cqrshc test (right shift, economized factorization):' call ctest(m,n,i,j,1) write (*,*) 'zqrshc test (right shift, economized factorization):' call ztest(m,n,i,j,1) call pstats end program subroutine stest(m,n,i,j,ec) integer m,n,i,j,ec real A(m,max(m,n)),Q(m,m),R(m,n),wrk(2*m) external srandg,sqrgen,scopy,sqrshc,sqrchk integer k c set up random matrix & vector call srandg(m,n,A,m) c generate QR decomposition call sqrgen(m,n,A,m,Q,m,R,m) c update A if (i < j) then call scopy(m,A(1,i),1,wrk,1) do k = i,j-1 call scopy(m,A(1,k+1),1,A(1,k),1) end do call scopy(m,wrk,1,A(1,j),1) else call scopy(m,A(1,i),1,wrk,1) do k = i,j+1,-1 call scopy(m,A(1,k-1),1,A(1,k),1) end do call scopy(m,wrk,1,A(1,j),1) end if c update the QR decomposition k = m if (ec == 1) k = n call sqrshc(m,n,k,Q,m,R,m,i,j,wrk) c check result call sqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine dtest(m,n,i,j,ec) integer m,n,i,j,ec double precision A(m,max(m,n)),Q(m,m),R(m,n),wrk(2*m) external drandg,dqrgen,dcopy,dqrshc,dqrchk integer k c set up random matrix & vector call drandg(m,n,A,m) c generate QR decomposition call dqrgen(m,n,A,m,Q,m,R,m) c update A if (i < j) then call dcopy(m,A(1,i),1,wrk,1) do k = i,j-1 call dcopy(m,A(1,k+1),1,A(1,k),1) end do call dcopy(m,wrk,1,A(1,j),1) else call dcopy(m,A(1,i),1,wrk,1) do k = i,j+1,-1 call dcopy(m,A(1,k-1),1,A(1,k),1) end do call dcopy(m,wrk,1,A(1,j),1) end if c update the QR decomposition k = m if (ec == 1) k = n call dqrshc(m,n,k,Q,m,R,m,i,j,wrk) c check result call dqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine ctest(m,n,i,j,ec) integer m,n,i,j,ec complex A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) real rwrk(m) external crandg,cqrgen,ccopy,cqrshc,cqrchk integer k c set up random matrix & vector call crandg(m,n,A,m) c generate QR decomposition call cqrgen(m,n,A,m,Q,m,R,m) c update A if (i < j) then call ccopy(m,A(1,i),1,wrk,1) do k = i,j-1 call ccopy(m,A(1,k+1),1,A(1,k),1) end do call ccopy(m,wrk,1,A(1,j),1) else call ccopy(m,A(1,i),1,wrk,1) do k = i,j+1,-1 call ccopy(m,A(1,k-1),1,A(1,k),1) end do call ccopy(m,wrk,1,A(1,j),1) end if c update the QR decomposition k = m if (ec == 1) k = n call cqrshc(m,n,k,Q,m,R,m,i,j,wrk,rwrk) c check result call cqrchk(m,n,k,A,m,Q,m,R,m) end subroutine subroutine ztest(m,n,i,j,ec) integer m,n,i,j,ec double complex A(m,max(m,n)),Q(m,m),R(m,n),wrk(m) double precision rwrk(m) external zrandg,zqrgen,zcopy,zqrshc,zqrchk integer k c set up random matrix & vector call zrandg(m,n,A,m) c generate QR decomposition call zqrgen(m,n,A,m,Q,m,R,m) c update A if (i < j) then call zcopy(m,A(1,i),1,wrk,1) do k = i,j-1 call zcopy(m,A(1,k+1),1,A(1,k),1) end do call zcopy(m,wrk,1,A(1,j),1) else call zcopy(m,A(1,i),1,wrk,1) do k = i,j+1,-1 call zcopy(m,A(1,k-1),1,A(1,k),1) end do call zcopy(m,wrk,1,A(1,j),1) end if c update the QR decomposition k = m if (ec == 1) k = n call zqrshc(m,n,k,Q,m,R,m,i,j,wrk,rwrk) c check result call zqrchk(m,n,k,A,m,Q,m,R,m) end subroutine