# HG changeset patch
# User Jaroslav Hajek <address@hidden>
# Date 1209370491 -7200
# Node ID ec4a042c2bb91eac879e0899640bac845a6b3a35
# Parent  1e224fa7f5bc560280c704cf14385fd65e59a4d7
corrections to qrupdate single precision routines

diff --git a/libcruft/ChangeLog b/libcruft/ChangeLog
--- a/libcruft/ChangeLog
+++ b/libcruft/ChangeLog
@@ -1,3 +1,15 @@
+2008-04-28  Jaroslav Hajek <address@hidden>
+
+	* qrupdate/cch1dn.f, qrupdate/cchinx.f, qrupdate/cqhqr.f, 
+	qrupdate/cqrinc.f, qrupdate/cqrinr.f, qrupdate/cqrqhu.f, 
+	qrupdate/cqrqhv.f, qrupdate/sch1dn.f, qrupdate/schinx.f, 
+	qrupdate/sqhqr.f, qrupdate/sqrinc.f, qrupdate/sqrinr.f, 
+	qrupdate/sqrqhu.f: Convert DOUBLE PRECISION constants to REAL.
+	* qrupdate/cqrinr.f, qrupdate/sqrinr.f: Correct EXTERNAL
+	declarations.
+	* qrupdate/sqrinr.f: Convert DOUBLE PRECISION calls to
+	REAL counterparts.
+
 2008-04-27  David Bateman  <address@hidden>
 
 	* Makefile.in (MISC_OBJ): Add misc/smachar.o
diff --git a/libcruft/qrupdate/cch1dn.f b/libcruft/qrupdate/cch1dn.f
--- a/libcruft/qrupdate/cch1dn.f
+++ b/libcruft/qrupdate/cch1dn.f
@@ -45,7 +45,7 @@
       if (n <= 0) return
 c check for singularity of R
       do i = 1,n
-        if (R(i,i) == 0d0) then
+        if (R(i,i) == 0e0) then
           info = 2
           return
         end if
@@ -55,7 +55,7 @@
       rho = scnrm2(n,u,1)
 c check positive definiteness      
       rho = 1 - rho**2
-      if (rho <= 0d0) then
+      if (rho <= 0e0) then
         info = 1
         return
       end if
@@ -69,7 +69,7 @@
       end do
 c apply rotations
       do i = n,1,-1
-        ui = 0d0
+        ui = 0e0
         do j = i,1,-1
           t = w(j)*ui + u(j)*R(j,i)
           R(j,i) = w(j)*R(j,i) - conjg(u(j))*ui
diff --git a/libcruft/qrupdate/cchinx.f b/libcruft/qrupdate/cchinx.f
--- a/libcruft/qrupdate/cchinx.f
+++ b/libcruft/qrupdate/cchinx.f
@@ -72,7 +72,7 @@
       
 c check for singularity of R
       do i = 1,n
-        if (R(i,i) == 0d0) then
+        if (R(i,i) == 0e0) then
           info = 2
           return
         end if
@@ -82,7 +82,7 @@
       rho = scnrm2(n,R1(1,j),1)
 c check positive definiteness      
       rho = u(j) - rho**2
-      if (rho <= 0d0) then
+      if (rho <= 0e0) then
         info = 1
         return
       end if
@@ -90,7 +90,7 @@
 
 c setup the new matrix R1
       do i = 1,n+1
-        R1(n+1,i) = 0d0
+        R1(n+1,i) = 0e0
       end do
       if (j > 1) then
         call clacpy('0',j-1,n,R(1,1),n,R1(1,1),n+1)
@@ -102,7 +102,7 @@
         call cqrqhu(0,n+1-j,n-j,Qdum,1,R1(j,jj),n+1,R1(j,j),w)
         R1(j,j) = w
         do jj = j+1,n
-          R1(jj,j) = 0d0
+          R1(jj,j) = 0e0
         end do
       end if
 
diff --git a/libcruft/qrupdate/cqhqr.f b/libcruft/qrupdate/cqhqr.f
--- a/libcruft/qrupdate/cqhqr.f
+++ b/libcruft/qrupdate/cqhqr.f
@@ -56,7 +56,7 @@
       do i = 1,min(k-1,n)
         call clartg(R(i,i),R(i+1,i),c,s,rr)
         R(i,i) = rr
-        R(i+1,i) = 0d0
+        R(i+1,i) = 0e0
         if (i < n) then
           call crot(n-i,R(i,i+1),ldr,R(i+1,i+1),ldr,c,s)
         end if
diff --git a/libcruft/qrupdate/cqrinc.f b/libcruft/qrupdate/cqrinc.f
--- a/libcruft/qrupdate/cqrinc.f
+++ b/libcruft/qrupdate/cqrinc.f
@@ -59,8 +59,8 @@
       if (j <= n) then
         call ccopy(k*(n+1-j),R(1,j),1,R1(1,j+1),1)
       end if
-      call cgemv('C',m,min(k,j-1),cmplx(1d0),Q,m,x,1,
-     +           cmplx(0d0),R1(1,j),1)
+      call cgemv('C',m,min(k,j-1),cmplx(1e0),Q,m,x,1,
+     +           cmplx(0e0),R1(1,j),1)
       if (j < k) then
 c eliminate tail, updating Q(:,j:k) and R1(j:k,j+1:n+1)
         jj = min(j,n)+1
@@ -68,7 +68,7 @@
 c assemble inserted column        
         R1(j,j) = w
         do i = j+1,k
-          R1(i,j) = 0d0
+          R1(i,j) = 0e0
         end do 
       end if
       end 
diff --git a/libcruft/qrupdate/cqrinr.f b/libcruft/qrupdate/cqrinr.f
--- a/libcruft/qrupdate/cqrinr.f
+++ b/libcruft/qrupdate/cqrinr.f
@@ -38,7 +38,7 @@
 c
       integer m,n,j
       complex Q(m,m),Q1(m+1,m+1),R(m,n),R1(m+1,n),x(n)
-      external xerbla,clacpy,dcopy,dqhqr
+      external xerbla,clacpy,ccopy,cqhqr
       integer i
 c check arguments      
       info = 0
@@ -61,10 +61,10 @@
       end if
 c zero the rest of Q1      
       do i = 1,m+1
-        Q1(i,1) = 0d0
-        Q1(j,i) = 0d0
+        Q1(i,1) = 0e0
+        Q1(j,i) = 0e0
       end do
-      Q1(j,1) = 1d0
+      Q1(j,1) = 1e0
 c setup the new matrix R1
       call ccopy(n,x,1,R1(1,1),m+1)
       call clacpy('0',m,n,R(1,1),m,R1(2,1),m+1)
diff --git a/libcruft/qrupdate/cqrqhu.f b/libcruft/qrupdate/cqrqhu.f
--- a/libcruft/qrupdate/cqrqhu.f
+++ b/libcruft/qrupdate/cqrqhu.f
@@ -59,7 +59,7 @@
       rr = u(k)
       do i = k-1,1,-1
         w = rr
-        if (w /= cmplx(0d0,0d0)) then
+        if (w /= cmplx(0e0,0e0)) then
           call clartg(u(i),w,c,s,rr)
 c apply rotation to rows of R if necessary        
           if (i <= n) then
diff --git a/libcruft/qrupdate/cqrqhv.f b/libcruft/qrupdate/cqrqhv.f
--- a/libcruft/qrupdate/cqrqhv.f
+++ b/libcruft/qrupdate/cqrqhv.f
@@ -41,7 +41,7 @@
       integer m,n,k,ldq,ldr
       complex Q(ldq,*),R(ldr,*),u(*),rr
       real c
-      complex s,w,w1,zdotc
+      complex s,w,w1,cdotc
       external xerbla,cdotc,clartg,crot
       integer i,info
 c quick return if possible.
diff --git a/libcruft/qrupdate/sch1dn.f b/libcruft/qrupdate/sch1dn.f
--- a/libcruft/qrupdate/sch1dn.f
+++ b/libcruft/qrupdate/sch1dn.f
@@ -45,7 +45,7 @@
       if (n <= 0) return
 c check for singularity of R
       do i = 1,n
-        if (R(i,i) == 0d0) then
+        if (R(i,i) == 0e0) then
           info = 2
           return
         end if
@@ -55,7 +55,7 @@
       rho = snrm2(n,u,1)
 c check positive definiteness      
       rho = 1 - rho**2
-      if (rho <= 0d0) then
+      if (rho <= 0e0) then
         info = 1
         return
       end if
@@ -69,7 +69,7 @@
       end do
 c apply rotations
       do i = n,1,-1
-        ui = 0d0
+        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
diff --git a/libcruft/qrupdate/schinx.f b/libcruft/qrupdate/schinx.f
--- a/libcruft/qrupdate/schinx.f
+++ b/libcruft/qrupdate/schinx.f
@@ -71,7 +71,7 @@
       
 c check for singularity of R
       do i = 1,n
-        if (R(i,i) == 0d0) then
+        if (R(i,i) == 0e0) then
           info = 2
           return
         end if
@@ -81,7 +81,7 @@
       rho = snrm2(n,R1(1,j),1)
 c check positive definiteness      
       rho = u(j) - rho**2
-      if (rho <= 0d0) then
+      if (rho <= 0e0) then
         info = 1
         return
       end if
@@ -89,7 +89,7 @@
 
 c setup the new matrix R1
       do i = 1,n+1
-        R1(n+1,i) = 0d0
+        R1(n+1,i) = 0e0
       end do
       if (j > 1) then
         call slacpy('0',n,j-1,R(1,1),n,R1(1,1),n+1)
@@ -101,7 +101,7 @@
         call sqrqhu(0,n+1-j,n-j,Qdum,1,R1(j,jj),n+1,R1(j,j),w)
         R1(j,j) = w
         do jj = j+1,n
-          R1(jj,j) = 0d0
+          R1(jj,j) = 0e0
         end do
       end if
 
diff --git a/libcruft/qrupdate/sqhqr.f b/libcruft/qrupdate/sqhqr.f
--- a/libcruft/qrupdate/sqhqr.f
+++ b/libcruft/qrupdate/sqhqr.f
@@ -56,7 +56,7 @@
       do i = 1,min(k-1,n)
         call slartg(R(i,i),R(i+1,i),c,s,rr)
         R(i,i) = rr
-        R(i+1,i) = 0d0
+        R(i+1,i) = 0e0
         if (i < n) then
           call srot(n-i,R(i,i+1),ldr,R(i+1,i+1),ldr,c,s)
         end if
diff --git a/libcruft/qrupdate/sqrinc.f b/libcruft/qrupdate/sqrinc.f
--- a/libcruft/qrupdate/sqrinc.f
+++ b/libcruft/qrupdate/sqrinc.f
@@ -61,7 +61,7 @@
       if (j <= n) then
         call scopy(k*(n+1-j),R(1,j),1,R1(1,j+1),1)
       end if
-      call sgemv('T',m,min(k,j-1),1d0,Q,m,x,1,0d0,R1(1,j),1)
+      call sgemv('T',m,min(k,j-1),1e0,Q,m,x,1,0e0,R1(1,j),1)
       if (j < k) then
 c eliminate tail, updating Q(:,j:k) and R1(j:k,j+1:n+1)
         jj = min(j,n)+1
@@ -69,7 +69,7 @@
 c assemble inserted column        
         R1(j,j) = w
         do i = j+1,k
-          R1(i,j) = 0d0
+          R1(i,j) = 0e0
         end do 
       end if
       end 
diff --git a/libcruft/qrupdate/sqrinr.f b/libcruft/qrupdate/sqrinr.f
--- a/libcruft/qrupdate/sqrinr.f
+++ b/libcruft/qrupdate/sqrinr.f
@@ -37,8 +37,8 @@
 c x (in)        the row being added
 c
       integer m,n,j
-      double precision Q(m,m),Q1(m+1,m+1),R(m,n),R1(m+1,n),x(n)
-      external xerbla,dlacpy,dcopy,dqhqr
+      real Q(m,m),Q1(m+1,m+1),R(m,n),R1(m+1,n),x(n)
+      external xerbla,slacpy,scopy,sqhqr
       integer i
 c check arguments      
       info = 0
@@ -48,26 +48,26 @@
         info = 7
       end if
       if (info /= 0) then
-        call xerbla('DQRINR',info)
+        call xerbla('SQRINR',info)
       end if
 c setup the new matrix Q1
 c permute the columns of Q1 and rows of R1 so that c the new row ends 
 c up being the topmost row.      
       if (j > 1) then
-        call dlacpy('0',j-1,m,Q(1,1),m,Q1(1,2),m+1)
+        call slacpy('0',j-1,m,Q(1,1),m,Q1(1,2),m+1)
       end if
       if (j <= m) then
-        call dlacpy('0',m-j+1,m,Q(j,1),m,Q1(j+1,2),m+1)
+        call slacpy('0',m-j+1,m,Q(j,1),m,Q1(j+1,2),m+1)
       end if
 c zero the rest of Q1      
       do i = 1,m+1
-        Q1(i,1) = 0d0
-        Q1(j,i) = 0d0
+        Q1(i,1) = 0e0
+        Q1(j,i) = 0e0
       end do
-      Q1(j,1) = 1d0
+      Q1(j,1) = 1e0
 c setup the new matrix R1
-      call dcopy(n,x,1,R1(1,1),m+1)
-      call dlacpy('0',m,n,R(1,1),m,R1(2,1),m+1)
+      call scopy(n,x,1,R1(1,1),m+1)
+      call slacpy('0',m,n,R(1,1),m,R1(2,1),m+1)
 c rotate to form proper QR      
-      call dqhqr(m+1,n,m+1,Q1,m+1,R1,m+1)
+      call sqhqr(m+1,n,m+1,Q1,m+1,R1,m+1)
       end 
diff --git a/libcruft/qrupdate/sqrqhu.f b/libcruft/qrupdate/sqrqhu.f
--- a/libcruft/qrupdate/sqrqhu.f
+++ b/libcruft/qrupdate/sqrqhu.f
@@ -59,7 +59,7 @@
       rr = u(k)
       do i = k-1,1,-1
         w = rr
-        if (w /= 0d0) then
+        if (w /= 0e0) then
           call slartg(u(i),w,c,s,rr)
 c apply rotation to rows of R if necessary        
           if (i <= n) then