Linear_algebra: giving DGELSY and ZGELSY their own files 09/11609/3
Paul BIGNIER [Thu, 30 May 2013 09:41:41 +0000 (11:41 +0200)]
I don't know why they were crammed in the same file.

This commit is a first step to update these functions.
See abandoned https://codereview.scilab.org/#/c/11608/

Change-Id: Iaad2ade229e5182d027a3391e15711334970f184

scilab/modules/linear_algebra/Makefile.am
scilab/modules/linear_algebra/Makefile.in
scilab/modules/linear_algebra/src/fortran/DGELSY1.f
scilab/modules/linear_algebra/src/fortran/ZGELSY1.f [new file with mode: 0644]
scilab/modules/linear_algebra/src/fortran/linear_algebra_f.vfproj
scilab/modules/linear_algebra/src/fortran/linear_algebra_f2c.vcxproj
scilab/modules/linear_algebra/src/fortran/linear_algebra_f2c.vcxproj.filters

index 32888da..7db08b7 100644 (file)
@@ -18,6 +18,7 @@ src/fortran/intgschur.f \
 src/fortran/intdgesv3.f \
 src/fortran/intdgesv4.f \
 src/fortran/DGELSY1.f \
+src/fortran/ZGELSY1.f \
 src/fortran/intozgschur.f \
 src/fortran/intdpotrf.f \
 src/fortran/intdoldsvd.f \
index fa0c767..30f21a6 100644 (file)
@@ -136,7 +136,7 @@ LTLIBRARIES = $(noinst_LTLIBRARIES) $(pkglib_LTLIBRARIES)
 libscilinear_algebra_algo_la_LIBADD =
 am__objects_1 = intdggbal.lo intzgeqpf4.lo intzgehrd.lo intzgesvd1.lo \
        intzfschur.lo intzgesvd2.lo intdgges.lo intgschur.lo \
-       intdgesv3.lo intdgesv4.lo DGELSY1.lo intozgschur.lo \
+       intdgesv3.lo intdgesv4.lo DGELSY1.lo ZGELSY1.lo intozgschur.lo \
        intdpotrf.lo intdoldsvd.lo intdgecon.lo zoldqr.lo intzgetrf.lo \
        intoschur.lo complexify.lo intzgebal.lo intzgetri.lo \
        intzggbal.lo intdgees0.lo intdgees1.lo intogschur.lo \
@@ -494,6 +494,7 @@ src/fortran/intgschur.f \
 src/fortran/intdgesv3.f \
 src/fortran/intdgesv4.f \
 src/fortran/DGELSY1.f \
+src/fortran/ZGELSY1.f \
 src/fortran/intozgschur.f \
 src/fortran/intdpotrf.f \
 src/fortran/intdoldsvd.f \
@@ -1029,6 +1030,9 @@ intdgesv4.lo: src/fortran/intdgesv4.f
 DGELSY1.lo: src/fortran/DGELSY1.f
        $(LIBTOOL)  --tag=F77 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o DGELSY1.lo `test -f 'src/fortran/DGELSY1.f' || echo '$(srcdir)/'`src/fortran/DGELSY1.f
 
+ZGELSY1.lo: src/fortran/ZGELSY1.f
+       $(LIBTOOL)  --tag=F77 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o ZGELSY1.lo `test -f 'src/fortran/ZGELSY1.f' || echo '$(srcdir)/'`src/fortran/ZGELSY1.f
+
 intozgschur.lo: src/fortran/intozgschur.f
        $(LIBTOOL)  --tag=F77 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(F77) $(AM_FFLAGS) $(FFLAGS) -c -o intozgschur.lo `test -f 'src/fortran/intozgschur.f' || echo '$(srcdir)/'`src/fortran/intozgschur.f
 
index 93e4f83..6ff16a6 100644 (file)
@@ -193,7 +193,7 @@ c     ===
       END IF
 *     
       IF( INFO.NE.0 ) THEN
-         CALL XERBLA( 'DGELSY', -INFO )
+         CALL XERBLA( 'DGELSY1', -INFO )
          RETURN
       ELSE IF( LQUERY ) THEN
          RETURN
@@ -376,388 +376,6 @@ c     *     workspace: 2*MN+NRHS.
 *     
       RETURN
 *     
-*     End of DGELSY
+*     End of DGELSY1
 *     
       END
-      SUBROUTINE ZGELSY1( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
-     $                   WORK, LWORK, RWORK, INFO )
-*
-*  -- LAPACK driver routine (version 3.0) --
-*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-*     Courant Institute, Argonne National Lab, and Rice University
-*     June 30, 1999
-*
-*     .. Scalar Arguments ..
-      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
-      DOUBLE PRECISION   RCOND
-*     ..
-*     .. Array Arguments ..
-      INTEGER            JPVT( * )
-      DOUBLE PRECISION   RWORK( * )
-      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
-*     ..
-*
-*  Purpose
-*  =======
-*
-*  ZGELSY1 computes a solution with at least N-RANK zeros to a complex 
-*  linear leastsquares problem:
-*      minimize || A * X - B ||
-*  using a complete orthogonal factorization of A.  A is an M-by-N
-*  matrix which may be rank-deficient.
-*
-*  Several right hand side vectors b and solution vectors x can be
-*  handled in a single call; they are stored as the columns of the
-*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-*  matrix X.
-*
-*  The routine first computes a QR factorization with column pivoting:
-*      A * P = Q * [ R11 R12 ]
-*                  [  0  R22 ]
-*  with R11 defined as the largest leading submatrix whose estimated
-*  condition number is less than 1/RCOND.  The order of R11, RANK,
-*  is the effective rank of A.
-*
-*  Then, R22 is considered to be negligible
-*  The returned  solution is then
-*     X = P *  [ inv(T11)*Q1'*B ]
-*              [        0       ]
-*  where Q1 consists of the first RANK columns of Q.
-*
-*  This routine is basically identical to the original xGELSX except
-*  three differences:
-*    o The permutation of matrix B (the right hand side) is faster and
-*      more simple.
-*    o The call to the subroutine xGEQPF has been substituted by the
-*      the call to the subroutine xGEQP3. This subroutine is a Blas-3
-*      version of the QR factorization with column pivoting.
-*    o Matrix B (the right hand side) is updated with Blas-3.
-*
-*  Arguments
-*  =========
-*
-*  M       (input) INTEGER
-*          The number of rows of the matrix A.  M >= 0.
-*
-*  N       (input) INTEGER
-*          The number of columns of the matrix A.  N >= 0.
-*
-*  NRHS    (input) INTEGER
-*          The number of right hand sides, i.e., the number of
-*          columns of matrices B and X. NRHS >= 0.
-*
-*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
-*          On entry, the M-by-N matrix A.
-*          On exit, A has been overwritten by details of its
-*          complete orthogonal factorization.
-*
-*  LDA     (input) INTEGER
-*          The leading dimension of the array A.  LDA >= max(1,M).
-*
-*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-*          On entry, the M-by-NRHS right hand side matrix B.
-*          On exit, the N-by-NRHS solution matrix X.
-*
-*  LDB     (input) INTEGER
-*          The leading dimension of the array B. LDB >= max(1,M,N).
-*
-*  JPVT    (input/output) INTEGER array, dimension (N)
-*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
-*          to the front of AP, otherwise column i is a free column.
-*          On exit, if JPVT(i) = k, then the i-th column of A*P
-*          was the k-th column of A.
-*
-*  RCOND   (input) DOUBLE PRECISION
-*          RCOND is used to determine the effective rank of A, which
-*          is defined as the order of the largest leading triangular
-*          submatrix R11 in the QR factorization with pivoting of A,
-*          whose estimated condition number < 1/RCOND.
-*
-*  RANK    (output) INTEGER
-*          The effective rank of A, i.e., the order of the submatrix
-*          R11.  This is the same as the order of the submatrix T11
-*          in the complete orthogonal factorization of A.
-*
-*  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
-*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-*  LWORK   (input) INTEGER
-*          The dimension of the array WORK.
-*          The unblocked strategy requires that:
-*            LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )
-*          where MN = min(M,N).
-*          The block algorithm requires that:
-*            LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )
-*          where NB is an upper bound on the blocksize returned
-*          by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR,
-*          and ZUNMRZ.
-*
-*          If LWORK = -1, then a workspace query is assumed; the routine
-*          only calculates the optimal size of the WORK array, returns
-*          this value as the first entry of the WORK array, and no error
-*          message related to LWORK is issued by XERBLA.
-*
-*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-*  INFO    (output) INTEGER
-*          = 0: successful exit
-*          < 0: if INFO = -i, the i-th argument had an illegal value
-*
-*  Further Details
-*  ===============
-*
-*  Based on contributions by
-*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*    E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-*
-*  =====================================================================
-*
-*     .. Parameters ..
-      INTEGER            IMAX, IMIN
-      PARAMETER          ( IMAX = 1, IMIN = 2 )
-      DOUBLE PRECISION   ZERO, ONE
-      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
-      COMPLEX*16         CZERO, CONE
-      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
-     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
-*     ..
-*     .. Local Scalars ..
-      LOGICAL            LQUERY
-      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKOPT, MN,
-     $                   NB, NB1, NB2, NB3, NB4
-      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, SMAX, SMAXPR, SMIN, SMINPR,
-     $                   SMLNUM, WSIZE
-      COMPLEX*16         C1, C2, S1, S2
-*     ..
-*     .. External Subroutines ..
-      EXTERNAL           DLABAD, XERBLA, ZCOPY, ZGEQP3, ZLAIC1, ZLASCL,
-     $                   ZLASET, ZTRSM, ZUNMQR 
-*     ..
-*     .. External Functions ..
-      INTEGER            ILAENV
-      DOUBLE PRECISION   DLAMCH, ZLANGE
-      EXTERNAL           ILAENV, DLAMCH, ZLANGE
-*     ..
-*     .. Intrinsic Functions ..
-      INTRINSIC          ABS, DBLE, DCMPLX, MAX, MIN
-*     ..
-*     .. Executable Statements ..
-*
-      MN = MIN( M, N )
-      ISMIN = MN + 1
-      ISMAX = 2*MN + 1
-*
-*     Test the input arguments.
-*
-      INFO = 0
-      NB1 = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
-      NB2 = ILAENV( 1, 'ZGERQF', ' ', M, N, -1, -1 )
-      NB3 = ILAENV( 1, 'ZUNMQR', ' ', M, N, NRHS, -1 )
-      NB4 = ILAENV( 1, 'ZUNMRQ', ' ', M, N, NRHS, -1 )
-      NB = MAX( NB1, NB2, NB3, NB4 )
-      LWKOPT = MAX( 1, MN+2*N+NB*( N+1 ), 2*MN+NB*NRHS )
-      WORK( 1 ) = DCMPLX( LWKOPT )
-      LQUERY = ( LWORK.EQ.-1 )
-      IF( M.LT.0 ) THEN
-         INFO = -1
-      ELSE IF( N.LT.0 ) THEN
-         INFO = -2
-      ELSE IF( NRHS.LT.0 ) THEN
-         INFO = -3
-      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
-         INFO = -5
-      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
-         INFO = -7
-      ELSE IF( LWORK.LT.( MN+MAX( 2*MN, N+1, MN+NRHS ) ) .AND. .NOT.
-     $         LQUERY ) THEN
-         INFO = -12
-      END IF
-*
-      IF( INFO.NE.0 ) THEN
-         CALL XERBLA( 'ZGELSY', -INFO )
-         RETURN
-      ELSE IF( LQUERY ) THEN
-         RETURN
-      END IF
-*
-*     Quick return if possible
-*
-      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
-         RANK = 0
-         RETURN
-      END IF
-*
-*     Get machine parameters
-*
-      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
-      BIGNUM = ONE / SMLNUM
-      CALL DLABAD( SMLNUM, BIGNUM )
-*
-*     Scale A, B if max entries outside range [SMLNUM,BIGNUM]
-*
-      ANRM = ZLANGE( 'M', M, N, A, LDA, RWORK )
-      IASCL = 0
-      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
-*
-*        Scale matrix norm up to SMLNUM
-*
-         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
-         IASCL = 1
-      ELSE IF( ANRM.GT.BIGNUM ) THEN
-*
-*        Scale matrix norm down to BIGNUM
-*
-         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
-         IASCL = 2
-      ELSE IF( ANRM.EQ.ZERO ) THEN
-*
-*        Matrix all zero. Return zero solution.
-*
-         CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
-         RANK = 0
-         GO TO 70
-      END IF
-*
-      BNRM = ZLANGE( 'M', M, NRHS, B, LDB, RWORK )
-      IBSCL = 0
-      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
-*
-*        Scale matrix norm up to SMLNUM
-*
-         CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
-         IBSCL = 1
-      ELSE IF( BNRM.GT.BIGNUM ) THEN
-*
-*        Scale matrix norm down to BIGNUM
-*
-         CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
-         IBSCL = 2
-      END IF
-*
-*     Compute QR factorization with column pivoting of A:
-*        A * P = Q * R
-*
-      CALL ZGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
-     $             LWORK-MN, RWORK, INFO )
-      WSIZE = MN + DBLE( WORK( MN+1 ) )
-*
-*     complex workspace: MN+NB*(N+1). real workspace 2*N.
-*     Details of Householder rotations stored in WORK(1:MN).
-*
-*     Determine RANK using incremental condition estimation
-*
-      WORK( ISMIN ) = CONE
-      WORK( ISMAX ) = CONE
-      SMAX = ABS( A( 1, 1 ) )
-      SMIN = SMAX
-      IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
-         RANK = 0
-         CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
-         GO TO 70
-      ELSE
-         RANK = 1
-      END IF
-*
-   10 CONTINUE
-      IF( RANK.LT.MN ) THEN
-         I = RANK + 1
-         CALL ZLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
-     $                A( I, I ), SMINPR, S1, C1 )
-         CALL ZLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
-     $                A( I, I ), SMAXPR, S2, C2 )
-*
-         IF( SMAXPR*RCOND.LE.SMINPR ) THEN
-            DO 20 I = 1, RANK
-               WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
-               WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
-   20       CONTINUE
-            WORK( ISMIN+RANK ) = C1
-            WORK( ISMAX+RANK ) = C2
-            SMIN = SMINPR
-            SMAX = SMAXPR
-            RANK = RANK + 1
-            GO TO 10
-         END IF
-      END IF
-*
-*     complex workspace: 3*MN.
-*
-*     Logically partition R = [ R11 R12 ]
-*                             [  0  R22 ]
-*     where R11 = R(1:RANK,1:RANK)
-*
-c*     [R11,R12] = [ T11, 0 ] * Y
-c*
-c      IF( RANK.LT.N )
-c     $   CALL ZTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ),
-c     $                LWORK-2*MN, INFO )
-c*
-*     complex workspace: 2*MN.
-*     Details of Householder rotations stored in WORK(MN+1:2*MN)
-*
-*     B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
-*
-      CALL ZUNMQR( 'Left', 'Conjugate transpose', M, NRHS, MN, A, LDA,
-     $             WORK( 1 ), B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
-      WSIZE = MAX( WSIZE, 2*MN+DBLE( WORK( 2*MN+1 ) ) )
-*
-*     complex workspace: 2*MN+NB*NRHS.
-*
-*     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
-*
-      CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
-     $            NRHS, CONE, A, LDA, B, LDB )
-*
-      DO 40 J = 1, NRHS
-         DO 30 I = RANK + 1, N
-            B( I, J ) = CZERO
-   30    CONTINUE
-   40 CONTINUE
-c*
-c*     B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
-c*
-c      IF( RANK.LT.N ) THEN
-c         CALL ZUNMRZ( 'Left', 'Conjugate transpose', N, NRHS, RANK,
-c     $                N-RANK, A, LDA, WORK( MN+1 ), B, LDB,
-c     $                WORK( 2*MN+1 ), LWORK-2*MN, INFO )
-c      END IF
-*
-*     complex workspace: 2*MN+NRHS.
-*
-*     B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
-*
-      DO 60 J = 1, NRHS
-         DO 50 I = 1, N
-            WORK( JPVT( I ) ) = B( I, J )
-   50    CONTINUE
-         CALL ZCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
-   60 CONTINUE
-*
-*     complex workspace: N.
-*
-*     Undo scaling
-*
-      IF( IASCL.EQ.1 ) THEN
-         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
-         CALL ZLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
-     $                INFO )
-      ELSE IF( IASCL.EQ.2 ) THEN
-         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
-         CALL ZLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
-     $                INFO )
-      END IF
-      IF( IBSCL.EQ.1 ) THEN
-         CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
-      ELSE IF( IBSCL.EQ.2 ) THEN
-         CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
-      END IF
-*
-   70 CONTINUE
-      WORK( 1 ) = DCMPLX( LWKOPT )
-*
-      RETURN
-*
-*     End of ZGELSY
-*
-      END
diff --git a/scilab/modules/linear_algebra/src/fortran/ZGELSY1.f b/scilab/modules/linear_algebra/src/fortran/ZGELSY1.f
new file mode 100644 (file)
index 0000000..22cccdb
--- /dev/null
@@ -0,0 +1,383 @@
+
+      SUBROUTINE ZGELSY1( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
+     $                   WORK, LWORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     June 30, 1999
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGELSY1 computes a solution with at least N-RANK zeros to a complex 
+*  linear leastsquares problem:
+*      minimize || A * X - B ||
+*  using a complete orthogonal factorization of A.  A is an M-by-N
+*  matrix which may be rank-deficient.
+*
+*  Several right hand side vectors b and solution vectors x can be
+*  handled in a single call; they are stored as the columns of the
+*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+*  matrix X.
+*
+*  The routine first computes a QR factorization with column pivoting:
+*      A * P = Q * [ R11 R12 ]
+*                  [  0  R22 ]
+*  with R11 defined as the largest leading submatrix whose estimated
+*  condition number is less than 1/RCOND.  The order of R11, RANK,
+*  is the effective rank of A.
+*
+*  Then, R22 is considered to be negligible
+*  The returned  solution is then
+*     X = P *  [ inv(T11)*Q1'*B ]
+*              [        0       ]
+*  where Q1 consists of the first RANK columns of Q.
+*
+*  This routine is basically identical to the original xGELSX except
+*  three differences:
+*    o The permutation of matrix B (the right hand side) is faster and
+*      more simple.
+*    o The call to the subroutine xGEQPF has been substituted by the
+*      the call to the subroutine xGEQP3. This subroutine is a Blas-3
+*      version of the QR factorization with column pivoting.
+*    o Matrix B (the right hand side) is updated with Blas-3.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of
+*          columns of matrices B and X. NRHS >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A has been overwritten by details of its
+*          complete orthogonal factorization.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
+*          On entry, the M-by-NRHS right hand side matrix B.
+*          On exit, the N-by-NRHS solution matrix X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,M,N).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+*          to the front of AP, otherwise column i is a free column.
+*          On exit, if JPVT(i) = k, then the i-th column of A*P
+*          was the k-th column of A.
+*
+*  RCOND   (input) DOUBLE PRECISION
+*          RCOND is used to determine the effective rank of A, which
+*          is defined as the order of the largest leading triangular
+*          submatrix R11 in the QR factorization with pivoting of A,
+*          whose estimated condition number < 1/RCOND.
+*
+*  RANK    (output) INTEGER
+*          The effective rank of A, i.e., the order of the submatrix
+*          R11.  This is the same as the order of the submatrix T11
+*          in the complete orthogonal factorization of A.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          The unblocked strategy requires that:
+*            LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )
+*          where MN = min(M,N).
+*          The block algorithm requires that:
+*            LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )
+*          where NB is an upper bound on the blocksize returned
+*          by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR,
+*          and ZUNMRZ.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*    E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            IMAX, IMIN
+      PARAMETER          ( IMAX = 1, IMIN = 2 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKOPT, MN,
+     $                   NB, NB1, NB2, NB3, NB4
+      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, SMAX, SMAXPR, SMIN, SMINPR,
+     $                   SMLNUM, WSIZE
+      COMPLEX*16         C1, C2, S1, S2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, XERBLA, ZCOPY, ZGEQP3, ZLAIC1, ZLASCL,
+     $                   ZLASET, ZTRSM, ZUNMQR 
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           ILAENV, DLAMCH, ZLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      MN = MIN( M, N )
+      ISMIN = MN + 1
+      ISMAX = 2*MN + 1
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      NB1 = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+      NB2 = ILAENV( 1, 'ZGERQF', ' ', M, N, -1, -1 )
+      NB3 = ILAENV( 1, 'ZUNMQR', ' ', M, N, NRHS, -1 )
+      NB4 = ILAENV( 1, 'ZUNMRQ', ' ', M, N, NRHS, -1 )
+      NB = MAX( NB1, NB2, NB3, NB4 )
+      LWKOPT = MAX( 1, MN+2*N+NB*( N+1 ), 2*MN+NB*NRHS )
+      WORK( 1 ) = DCMPLX( LWKOPT )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+         INFO = -7
+      ELSE IF( LWORK.LT.( MN+MAX( 2*MN, N+1, MN+NRHS ) ) .AND. .NOT.
+     $         LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGELSY1', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+         RANK = 0
+         RETURN
+      END IF
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A, B if max entries outside range [SMLNUM,BIGNUM]
+*
+      ANRM = ZLANGE( 'M', M, N, A, LDA, RWORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+         IASCL = 1
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+         IASCL = 2
+      ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+*        Matrix all zero. Return zero solution.
+*
+         CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
+         RANK = 0
+         GO TO 70
+      END IF
+*
+      BNRM = ZLANGE( 'M', M, NRHS, B, LDB, RWORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 1
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 2
+      END IF
+*
+*     Compute QR factorization with column pivoting of A:
+*        A * P = Q * R
+*
+      CALL ZGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
+     $             LWORK-MN, RWORK, INFO )
+      WSIZE = MN + DBLE( WORK( MN+1 ) )
+*
+*     complex workspace: MN+NB*(N+1). real workspace 2*N.
+*     Details of Householder rotations stored in WORK(1:MN).
+*
+*     Determine RANK using incremental condition estimation
+*
+      WORK( ISMIN ) = CONE
+      WORK( ISMAX ) = CONE
+      SMAX = ABS( A( 1, 1 ) )
+      SMIN = SMAX
+      IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
+         RANK = 0
+         CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
+         GO TO 70
+      ELSE
+         RANK = 1
+      END IF
+*
+   10 CONTINUE
+      IF( RANK.LT.MN ) THEN
+         I = RANK + 1
+         CALL ZLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+     $                A( I, I ), SMINPR, S1, C1 )
+         CALL ZLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
+     $                A( I, I ), SMAXPR, S2, C2 )
+*
+         IF( SMAXPR*RCOND.LE.SMINPR ) THEN
+            DO 20 I = 1, RANK
+               WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
+               WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
+   20       CONTINUE
+            WORK( ISMIN+RANK ) = C1
+            WORK( ISMAX+RANK ) = C2
+            SMIN = SMINPR
+            SMAX = SMAXPR
+            RANK = RANK + 1
+            GO TO 10
+         END IF
+      END IF
+*
+*     complex workspace: 3*MN.
+*
+*     Logically partition R = [ R11 R12 ]
+*                             [  0  R22 ]
+*     where R11 = R(1:RANK,1:RANK)
+*
+c*     [R11,R12] = [ T11, 0 ] * Y
+c*
+c      IF( RANK.LT.N )
+c     $   CALL ZTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ),
+c     $                LWORK-2*MN, INFO )
+c*
+*     complex workspace: 2*MN.
+*     Details of Householder rotations stored in WORK(MN+1:2*MN)
+*
+*     B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
+*
+      CALL ZUNMQR( 'Left', 'Conjugate transpose', M, NRHS, MN, A, LDA,
+     $             WORK( 1 ), B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
+      WSIZE = MAX( WSIZE, 2*MN+DBLE( WORK( 2*MN+1 ) ) )
+*
+*     complex workspace: 2*MN+NB*NRHS.
+*
+*     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
+*
+      CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
+     $            NRHS, CONE, A, LDA, B, LDB )
+*
+      DO 40 J = 1, NRHS
+         DO 30 I = RANK + 1, N
+            B( I, J ) = CZERO
+   30    CONTINUE
+   40 CONTINUE
+c*
+c*     B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
+c*
+c      IF( RANK.LT.N ) THEN
+c         CALL ZUNMRZ( 'Left', 'Conjugate transpose', N, NRHS, RANK,
+c     $                N-RANK, A, LDA, WORK( MN+1 ), B, LDB,
+c     $                WORK( 2*MN+1 ), LWORK-2*MN, INFO )
+c      END IF
+*
+*     complex workspace: 2*MN+NRHS.
+*
+*     B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
+*
+      DO 60 J = 1, NRHS
+         DO 50 I = 1, N
+            WORK( JPVT( I ) ) = B( I, J )
+   50    CONTINUE
+         CALL ZCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
+   60 CONTINUE
+*
+*     complex workspace: N.
+*
+*     Undo scaling
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL ZLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL ZLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+   70 CONTINUE
+      WORK( 1 ) = DCMPLX( LWKOPT )
+*
+      RETURN
+*
+*     End of ZGELSY1
+*
+      END
index 6e13c2b..23d14c5 100644 (file)
@@ -106,6 +106,7 @@ lib /DEF:&quot;$(InputDir)core_f_Import.def&quot; /SUBSYSTEM:WINDOWS /MACHINE:X6
                <Filter Name="Source Files" Filter="f90;for;f;fpp;ftn;def;odl;idl">
                <File RelativePath=".\complexify.f"/>
                <File RelativePath=".\DGELSY1.f"/>
+               <File RelativePath=".\ZGELSY1.f"/>
                <File RelativePath=".\doldqr.f"/>
                <File RelativePath=".\intddet.f"/>
                <File RelativePath=".\intdgebal.f"/>
index c29e361..d91dd0b 100644 (file)
@@ -263,6 +263,7 @@ cd ..
     <ClCompile Include="common_f2c.c" />
     <ClCompile Include="complexify.c" />
     <ClCompile Include="DGELSY1.c" />
+    <ClCompile Include="ZGELSY1.c" />
     <ClCompile Include="doldqr.c" />
     <ClCompile Include="intddet.c" />
     <ClCompile Include="intdgebal.c" />
@@ -318,6 +319,7 @@ cd ..
   <ItemGroup>
     <f2c_rule Include="complexify.f" />
     <f2c_rule Include="DGELSY1.f" />
+    <f2c_rule Include="ZGELSY1.f" />
     <f2c_rule Include="doldqr.f" />
     <f2c_rule Include="intddet.f" />
     <f2c_rule Include="intdgebal.f" />
@@ -390,4 +392,4 @@ cd ..
   <ImportGroup Label="ExtensionTargets">
     <Import Project="..\..\..\..\Visual-Studio-settings\f2c.targets" />
   </ImportGroup>
-</Project>
\ No newline at end of file
+</Project>
index 140f756..96288a6 100644 (file)
@@ -30,6 +30,9 @@
     <ClCompile Include="DGELSY1.c">
       <Filter>Source Files</Filter>
     </ClCompile>
+    <ClCompile Include="ZGELSY1.c">
+      <Filter>Source Files</Filter>
+    </ClCompile>
     <ClCompile Include="doldqr.c">
       <Filter>Source Files</Filter>
     </ClCompile>
     <f2c_rule Include="DGELSY1.f">
       <Filter>Fortran files</Filter>
     </f2c_rule>
+    <f2c_rule Include="ZGELSY1.f">
+      <Filter>Fortran files</Filter>
+    </f2c_rule>
     <f2c_rule Include="doldqr.f">
       <Filter>Fortran files</Filter>
     </f2c_rule>
       <Filter>Libraries Dependencies</Filter>
     </None>
   </ItemGroup>
-</Project>
\ No newline at end of file
+</Project>