# HG changeset patch
# User John W. Eaton <jwe@octave.org>
# Date 1205872765 14400
# Node ID 461d6bfba85ac049339c6979ae7f79141982d578
# Parent  a89b3fa632eea5051fedcb0fb5fca1ea0d41638a
use xzdotc instead of zdotc

diff --git a/libcruft/ChangeLog b/libcruft/ChangeLog
--- a/libcruft/ChangeLog
+++ b/libcruft/ChangeLog
@@ -1,3 +1,10 @@
+2008-03-18  John W. Eaton  <jwe@octave.org>
+
+	* qrupdate/zqrqhv.f (zqrqhv): Call xzdotc instead of zdotc.
+	* blas-xtra/xzdotu.f: Eliminate local zdotu variable.
+	* blas-xtra/xzdotc.f: New file.
+	* blas-xtra/Makefile.in (FSRC): Add it to the list.
+
 2008-03-10  John W. Eaton  <jwe@octave.org>
 
 	* blas/zdrot.f, odepack/dlsode.f, odepack/ewset.f,
diff --git a/libcruft/blas-xtra/Makefile.in b/libcruft/blas-xtra/Makefile.in
--- a/libcruft/blas-xtra/Makefile.in
+++ b/libcruft/blas-xtra/Makefile.in
@@ -26,7 +26,7 @@
 
 EXTERNAL_DISTFILES = $(DISTFILES)
 
-FSRC = xddot.f xdnrm2.f xdznrm2.f xerbla.f xzdotu.f
+FSRC = xddot.f xdnrm2.f xdznrm2.f xerbla.f xzdotc.f xzdotu.f
 
 include $(TOPDIR)/Makeconf
 
diff --git a/libcruft/blas-xtra/xzdotc.f b/libcruft/blas-xtra/xzdotc.f
new file mode 100644
--- /dev/null
+++ b/libcruft/blas-xtra/xzdotc.f
@@ -0,0 +1,46 @@
+*** This subroutine includes all of the ZDOTC function instead of simply
+*** wrapping it in a subroutine to avoid possible differences in the way
+*** complex values are returned by various Fortran compilers.  For
+*** example, if we simply wrap the function and compile this file with
+*** gfortran and the library that provides ZDOTC is compiled with a
+*** compiler that uses the g77 (f2c-compatible) calling convention for
+*** complex-valued functions, all hell will break loose.
+
+      subroutine xzdotc(n,zx,incx,zy,incy,ztemp)
+
+***   double complex function zdotc(n,zx,incx,zy,incy)
+c
+c     forms the dot product of a vector.
+c     jack dongarra, 3/11/78.
+c     modified 12/3/93, array(1) declarations changed to array(*)
+c
+      double complex zx(*),zy(*),ztemp
+      integer i,incx,incy,ix,iy,n
+      ztemp = (0.0d0,0.0d0)
+***   zdotc = (0.0d0,0.0d0)
+      if(n.le.0)return
+      if(incx.eq.1.and.incy.eq.1)go to 20
+c
+c        code for unequal increments or equal increments
+c          not equal to 1
+c
+      ix = 1
+      iy = 1
+      if(incx.lt.0)ix = (-n+1)*incx + 1
+      if(incy.lt.0)iy = (-n+1)*incy + 1
+      do 10 i = 1,n
+        ztemp = ztemp + dconjg(zx(ix))*zy(iy)
+        ix = ix + incx
+        iy = iy + incy
+   10 continue
+***   zdotc = ztemp
+      return
+c
+c        code for both increments equal to 1
+c
+   20 do 30 i = 1,n
+        ztemp = ztemp + dconjg(zx(i))*zy(i)
+   30 continue
+****  zdotc = ztemp
+      return
+      end
diff --git a/libcruft/blas-xtra/xzdotu.f b/libcruft/blas-xtra/xzdotu.f
--- a/libcruft/blas-xtra/xzdotu.f
+++ b/libcruft/blas-xtra/xzdotu.f
@@ -17,7 +17,7 @@
       double complex zx(*),zy(*),ztemp
       integer i,incx,incy,ix,iy,n
       ztemp = (0.0d0,0.0d0)
-      zdotu = (0.0d0,0.0d0)
+***   zdotu = (0.0d0,0.0d0)
       if(n.le.0)return
       if(incx.eq.1.and.incy.eq.1)go to 20
 c
@@ -33,7 +33,7 @@
         ix = ix + incx
         iy = iy + incy
    10 continue
-      zdotu = ztemp
+***   zdotu = ztemp
       return
 c
 c        code for both increments equal to 1
diff --git a/libcruft/qrupdate/zqrqhv.f b/libcruft/qrupdate/zqrqhv.f
--- a/libcruft/qrupdate/zqrqhv.f
+++ b/libcruft/qrupdate/zqrqhv.f
@@ -41,7 +41,7 @@
       integer m,n,k,ldq,ldr
       double complex Q(ldq,*),R(ldr,*),u(*),rr
       double precision c
-      double complex s,w,w1,zdotc
+      double complex s,w,w1
       external zdotc,zlartg,zrot
       integer i,info
 c quick return if possible.
@@ -59,10 +59,10 @@
         call xerbla('ZQRQHV',info)
       end if
 c form each element of w = Q'*u when necessary.
-      rr = zdotc(m,Q(1,k),1,u,1)
+      call xzdotc(m,Q(1,k),1,u,1,rr)
       do i = k-1,1,-1
         w1 = rr
-        w = zdotc(m,Q(1,i),1,u,1)
+        call xzdotc(m,Q(1,i),1,u,1,w)
         call zlartg(w,w1,c,s,rr)
 c apply rotation to rows of R if necessary        
         if (i <= n) then