zhetf2.f.html

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

</span><span class="comment">*</span><span class="comment">
</span>         K = 1
   50    CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        If K &gt; N, exit from loop
</span><span class="comment">*</span><span class="comment">
</span>         IF( K.GT.N )
     $      GO TO 90
         KSTEP = 1
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Determine rows and columns to be interchanged and whether
</span><span class="comment">*</span><span class="comment">        a 1-by-1 or 2-by-2 pivot block will be used
</span><span class="comment">*</span><span class="comment">
</span>         ABSAKK = ABS( DBLE( A( K, K ) ) )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        IMAX is the row-index of the largest off-diagonal element in
</span><span class="comment">*</span><span class="comment">        column K, and COLMAX is its absolute value
</span><span class="comment">*</span><span class="comment">
</span>         IF( K.LT.N ) THEN
            IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 )
            COLMAX = CABS1( A( IMAX, K ) )
         ELSE
            COLMAX = ZERO
         END IF
<span class="comment">*</span><span class="comment">
</span>         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. <a name="DISNAN.393"></a><a href="disnan.f.html#DISNAN.1">DISNAN</a>(ABSAKK) ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Column K is zero or contains a NaN: set INFO and continue
</span><span class="comment">*</span><span class="comment">
</span>            IF( INFO.EQ.0 )
     $         INFO = K
            KP = K
            A( K, K ) = DBLE( A( K, K ) )
         ELSE
            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              no interchange, use 1-by-1 pivot block
</span><span class="comment">*</span><span class="comment">
</span>               KP = K
            ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              JMAX is the column-index of the largest off-diagonal
</span><span class="comment">*</span><span class="comment">              element in row IMAX, and ROWMAX is its absolute value
</span><span class="comment">*</span><span class="comment">
</span>               JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA )
               ROWMAX = CABS1( A( IMAX, JMAX ) )
               IF( IMAX.LT.N ) THEN
                  JMAX = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
                  ROWMAX = MAX( ROWMAX, CABS1( A( JMAX, IMAX ) ) )
               END IF
<span class="comment">*</span><span class="comment">
</span>               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 no interchange, use 1-by-1 pivot block
</span><span class="comment">*</span><span class="comment">
</span>                  KP = K
               ELSE IF( ABS( DBLE( A( IMAX, IMAX ) ) ).GE.ALPHA*ROWMAX )
     $                   THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 interchange rows and columns K and IMAX, use 1-by-1
</span><span class="comment">*</span><span class="comment">                 pivot block
</span><span class="comment">*</span><span class="comment">
</span>                  KP = IMAX
               ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 interchange rows and columns K+1 and IMAX, use 2-by-2
</span><span class="comment">*</span><span class="comment">                 pivot block
</span><span class="comment">*</span><span class="comment">
</span>                  KP = IMAX
                  KSTEP = 2
               END IF
            END IF
<span class="comment">*</span><span class="comment">
</span>            KK = K + KSTEP - 1
            IF( KP.NE.KK ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Interchange rows and columns KK and KP in the trailing
</span><span class="comment">*</span><span class="comment">              submatrix A(k:n,k:n)
</span><span class="comment">*</span><span class="comment">
</span>               IF( KP.LT.N )
     $            CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
               DO 60 J = KK + 1, KP - 1
                  T = DCONJG( A( J, KK ) )
                  A( J, KK ) = DCONJG( A( KP, J ) )
                  A( KP, J ) = T
   60          CONTINUE
               A( KP, KK ) = DCONJG( A( KP, KK ) )
               R1 = DBLE( A( KK, KK ) )
               A( KK, KK ) = DBLE( A( KP, KP ) )
               A( KP, KP ) = R1
               IF( KSTEP.EQ.2 ) THEN
                  A( K, K ) = DBLE( A( K, K ) )
                  T = A( K+1, K )
                  A( K+1, K ) = A( KP, K )
                  A( KP, K ) = T
               END IF
            ELSE
               A( K, K ) = DBLE( A( K, K ) )
               IF( KSTEP.EQ.2 )
     $            A( K+1, K+1 ) = DBLE( A( K+1, K+1 ) )
            END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Update the trailing submatrix
</span><span class="comment">*</span><span class="comment">
</span>            IF( KSTEP.EQ.1 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              1-by-1 pivot block D(k): column k now holds
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              W(k) = L(k)*D(k)
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              where L(k) is the k-th column of L
</span><span class="comment">*</span><span class="comment">
</span>               IF( K.LT.N ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 Perform a rank-1 update of A(k+1:n,k+1:n) as
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
</span><span class="comment">*</span><span class="comment">
</span>                  R1 = ONE / DBLE( A( K, K ) )
                  CALL ZHER( UPLO, N-K, -R1, A( K+1, K ), 1,
     $                       A( K+1, K+1 ), LDA )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 Store L(k) in column K
</span><span class="comment">*</span><span class="comment">
</span>                  CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 )
               END IF
            ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              2-by-2 pivot block D(k)
</span><span class="comment">*</span><span class="comment">
</span>               IF( K.LT.N-1 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 Perform a rank-2 update of A(k+2:n,k+2:n) as
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )'
</span><span class="comment">*</span><span class="comment">                    = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )'
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 where L(k) and L(k+1) are the k-th and (k+1)-th
</span><span class="comment">*</span><span class="comment">                 columns of L
</span><span class="comment">*</span><span class="comment">
</span>                  D = <a name="DLAPY2.508"></a><a href="dlapy2.f.html#DLAPY2.1">DLAPY2</a>( DBLE( A( K+1, K ) ),
     $                DIMAG( A( K+1, K ) ) )
                  D11 = DBLE( A( K+1, K+1 ) ) / D
                  D22 = DBLE( A( K, K ) ) / D
                  TT = ONE / ( D11*D22-ONE )
                  D21 = A( K+1, K ) / D
                  D = TT / D
<span class="comment">*</span><span class="comment">
</span>                  DO 80 J = K + 2, N
                     WK = D*( D11*A( J, K )-D21*A( J, K+1 ) )
                     WKP1 = D*( D22*A( J, K+1 )-DCONJG( D21 )*
     $                      A( J, K ) )
                     DO 70 I = J, N
                        A( I, J ) = A( I, J ) - A( I, K )*DCONJG( WK ) -
     $                              A( I, K+1 )*DCONJG( WKP1 )
   70                CONTINUE
                     A( J, K ) = WK
                     A( J, K+1 ) = WKP1
                     A( J, J ) = DCMPLX( DBLE( A( J, J ) ), 0.0D+0 )
   80             CONTINUE
               END IF
            END IF
         END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Store details of the interchanges in IPIV
</span><span class="comment">*</span><span class="comment">
</span>         IF( KSTEP.EQ.1 ) THEN
            IPIV( K ) = KP
         ELSE
            IPIV( K ) = -KP
            IPIV( K+1 ) = -KP
         END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Increase K and return to the start of the main loop
</span><span class="comment">*</span><span class="comment">
</span>         K = K + KSTEP
         GO TO 50
<span class="comment">*</span><span class="comment">
</span>      END IF
<span class="comment">*</span><span class="comment">
</span>   90 CONTINUE
      RETURN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     End of <a name="ZHETF2.551"></a><a href="zhetf2.f.html#ZHETF2.1">ZHETF2</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>