zggglm.f.html

来自「famous linear algebra library (LAPACK) p」· HTML 代码 · 共 284 行 · 第 1/2 页

</span>      EXTERNAL           <a name="XERBLA.124"></a><a href="xerbla.f.html#XERBLA.1">XERBLA</a>, ZCOPY, ZGEMV, <a name="ZGGQRF.124"></a><a href="zggqrf.f.html#ZGGQRF.1">ZGGQRF</a>, <a name="ZTRTRS.124"></a><a href="ztrtrs.f.html#ZTRTRS.1">ZTRTRS</a>, <a name="ZUNMQR.124"></a><a href="zunmqr.f.html#ZUNMQR.1">ZUNMQR</a>,
     $                   <a name="ZUNMRQ.125"></a><a href="zunmrq.f.html#ZUNMRQ.1">ZUNMRQ</a>
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. External Functions ..
</span>      INTEGER            <a name="ILAENV.128"></a><a href="hfy-index.html#ILAENV">ILAENV</a>
      EXTERNAL           <a name="ILAENV.129"></a><a href="hfy-index.html#ILAENV">ILAENV</a> 
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Intrinsic Functions ..
</span>      INTRINSIC          INT, MAX, MIN
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Executable Statements ..
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Test the input parameters
</span><span class="comment">*</span><span class="comment">
</span>      INFO = 0
      NP = MIN( N, P )
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
         INFO = -2
      ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Calculate workspace
</span><span class="comment">*</span><span class="comment">
</span>      IF( INFO.EQ.0) THEN
         IF( N.EQ.0 ) THEN
            LWKMIN = 1
            LWKOPT = 1
         ELSE
            NB1 = <a name="ILAENV.160"></a><a href="hfy-index.html#ILAENV">ILAENV</a>( 1, <span class="string">'<a name="ZGEQRF.160"></a><a href="zgeqrf.f.html#ZGEQRF.1">ZGEQRF</a>'</span>, <span class="string">' '</span>, N, M, -1, -1 )
            NB2 = <a name="ILAENV.161"></a><a href="hfy-index.html#ILAENV">ILAENV</a>( 1, <span class="string">'<a name="ZGERQF.161"></a><a href="zgerqf.f.html#ZGERQF.1">ZGERQF</a>'</span>, <span class="string">' '</span>, N, M, -1, -1 )
            NB3 = <a name="ILAENV.162"></a><a href="hfy-index.html#ILAENV">ILAENV</a>( 1, <span class="string">'<a name="ZUNMQR.162"></a><a href="zunmqr.f.html#ZUNMQR.1">ZUNMQR</a>'</span>, <span class="string">' '</span>, N, M, P, -1 )
            NB4 = <a name="ILAENV.163"></a><a href="hfy-index.html#ILAENV">ILAENV</a>( 1, <span class="string">'<a name="ZUNMRQ.163"></a><a href="zunmrq.f.html#ZUNMRQ.1">ZUNMRQ</a>'</span>, <span class="string">' '</span>, N, M, P, -1 )
            NB = MAX( NB1, NB2, NB3, NB4 )
            LWKMIN = M + N + P
            LWKOPT = M + NP + MAX( N, P )*NB
         END IF
         WORK( 1 ) = LWKOPT
<span class="comment">*</span><span class="comment">
</span>         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
            INFO = -12
         END IF
      END IF
<span class="comment">*</span><span class="comment">
</span>      IF( INFO.NE.0 ) THEN
         CALL <a name="XERBLA.176"></a><a href="xerbla.f.html#XERBLA.1">XERBLA</a>( <span class="string">'<a name="ZGGGLM.176"></a><a href="zggglm.f.html#ZGGGLM.1">ZGGGLM</a>'</span>, -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Quick return if possible
</span><span class="comment">*</span><span class="comment">
</span>      IF( N.EQ.0 )
     $   RETURN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Compute the GQR factorization of matrices A and B:
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">            Q'*A = ( R11 ) M,    Q'*B*Z' = ( T11   T12 ) M
</span><span class="comment">*</span><span class="comment">                   (  0  ) N-M             (  0    T22 ) N-M
</span><span class="comment">*</span><span class="comment">                      M                     M+P-N  N-M
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     where R11 and T22 are upper triangular, and Q and Z are
</span><span class="comment">*</span><span class="comment">     unitary.
</span><span class="comment">*</span><span class="comment">
</span>      CALL <a name="ZGGQRF.196"></a><a href="zggqrf.f.html#ZGGQRF.1">ZGGQRF</a>( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ),
     $             WORK( M+NP+1 ), LWORK-M-NP, INFO )
      LOPT = WORK( M+NP+1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Update left-hand-side vector d = Q'*d = ( d1 ) M
</span><span class="comment">*</span><span class="comment">                                             ( d2 ) N-M
</span><span class="comment">*</span><span class="comment">
</span>      CALL <a name="ZUNMQR.203"></a><a href="zunmqr.f.html#ZUNMQR.1">ZUNMQR</a>( <span class="string">'Left'</span>, <span class="string">'Conjugate transpose'</span>, N, 1, M, A, LDA, WORK,
     $             D, MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
      LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Solve T22*y2 = d2 for y2
</span><span class="comment">*</span><span class="comment">
</span>      IF( N.GT.M ) THEN
         CALL <a name="ZTRTRS.210"></a><a href="ztrtrs.f.html#ZTRTRS.1">ZTRTRS</a>( <span class="string">'Upper'</span>, <span class="string">'No transpose'</span>, <span class="string">'Non unit'</span>, N-M, 1,
     $                B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO )
<span class="comment">*</span><span class="comment">
</span>         IF( INFO.GT.0 ) THEN
            INFO = 1
            RETURN
         END IF
<span class="comment">*</span><span class="comment">
</span>         CALL ZCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 )
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Set y1 = 0
</span><span class="comment">*</span><span class="comment">
</span>      DO 10 I = 1, M + P - N
         Y( I ) = CZERO
   10 CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Update d1 = d1 - T12*y2
</span><span class="comment">*</span><span class="comment">
</span>      CALL ZGEMV( <span class="string">'No transpose'</span>, M, N-M, -CONE, B( 1, M+P-N+1 ), LDB,
     $            Y( M+P-N+1 ), 1, CONE, D, 1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Solve triangular system: R11*x = d1
</span><span class="comment">*</span><span class="comment">
</span>      IF( M.GT.0 ) THEN
         CALL <a name="ZTRTRS.235"></a><a href="ztrtrs.f.html#ZTRTRS.1">ZTRTRS</a>( <span class="string">'Upper'</span>, <span class="string">'No Transpose'</span>, <span class="string">'Non unit'</span>, M, 1, A, LDA,
     $                D, M, INFO )
<span class="comment">*</span><span class="comment">
</span>         IF( INFO.GT.0 ) THEN
            INFO = 2
            RETURN
         END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Copy D to X
</span><span class="comment">*</span><span class="comment">
</span>         CALL ZCOPY( M, D, 1, X, 1 )
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Backward transformation y = Z'*y
</span><span class="comment">*</span><span class="comment">
</span>      CALL <a name="ZUNMRQ.250"></a><a href="zunmrq.f.html#ZUNMRQ.1">ZUNMRQ</a>( <span class="string">'Left'</span>, <span class="string">'Conjugate transpose'</span>, P, 1, NP,
     $             B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y,
     $             MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
      WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) )
<span class="comment">*</span><span class="comment">
</span>      RETURN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     End of <a name="ZGGGLM.257"></a><a href="zggglm.f.html#ZGGGLM.1">ZGGGLM</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>