chptrf.f.html

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

</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.GT.1 ) THEN
            IMAX = ICAMAX( K-1, AP( KC ), 1 )
            COLMAX = CABS1( AP( KC+IMAX-1 ) )
         ELSE
            COLMAX = ZERO
         END IF
<span class="comment">*</span><span class="comment">
</span>         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Column K is zero: set INFO and continue
</span><span class="comment">*</span><span class="comment">
</span>            IF( INFO.EQ.0 )
     $         INFO = K
            KP = K
            AP( KC+K-1 ) = REAL( AP( KC+K-1 ) )
         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>               ROWMAX = ZERO
               JMAX = IMAX
               KX = IMAX*( IMAX+1 ) / 2 + IMAX
               DO 20 J = IMAX + 1, K
                  IF( CABS1( AP( KX ) ).GT.ROWMAX ) THEN
                     ROWMAX = CABS1( AP( KX ) )
                     JMAX = J
                  END IF
                  KX = KX + J
   20          CONTINUE
               KPC = ( IMAX-1 )*IMAX / 2 + 1
               IF( IMAX.GT.1 ) THEN
                  JMAX = ICAMAX( IMAX-1, AP( KPC ), 1 )
                  ROWMAX = MAX( ROWMAX, CABS1( AP( KPC+JMAX-1 ) ) )
               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( REAL( AP( KPC+IMAX-1 ) ) ).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( KSTEP.EQ.2 )
     $         KNC = KNC - K + 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 leading
</span><span class="comment">*</span><span class="comment">              submatrix A(1:k,1:k)
</span><span class="comment">*</span><span class="comment">
</span>               CALL CSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
               KX = KPC + KP - 1
               DO 30 J = KP + 1, KK - 1
                  KX = KX + J - 1
                  T = CONJG( AP( KNC+J-1 ) )
                  AP( KNC+J-1 ) = CONJG( AP( KX ) )
                  AP( KX ) = T
   30          CONTINUE
               AP( KX+KK-1 ) = CONJG( AP( KX+KK-1 ) )
               R1 = REAL( AP( KNC+KK-1 ) )
               AP( KNC+KK-1 ) = REAL( AP( KPC+KP-1 ) )
               AP( KPC+KP-1 ) = R1
               IF( KSTEP.EQ.2 ) THEN
                  AP( KC+K-1 ) = REAL( AP( KC+K-1 ) )
                  T = AP( KC+K-2 )
                  AP( KC+K-2 ) = AP( KC+KP-1 )
                  AP( KC+KP-1 ) = T
               END IF
            ELSE
               AP( KC+K-1 ) = REAL( AP( KC+K-1 ) )
               IF( KSTEP.EQ.2 )
     $            AP( KC-1 ) = REAL( AP( KC-1 ) )
            END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Update the leading 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) = U(k)*D(k)
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              where U(k) is the k-th column of U
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Perform a rank-1 update of A(1:k-1,1:k-1) as
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
</span><span class="comment">*</span><span class="comment">
</span>               R1 = ONE / REAL( AP( KC+K-1 ) )
               CALL CHPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Store U(k) in column k
</span><span class="comment">*</span><span class="comment">
</span>               CALL CSSCAL( K-1, R1, AP( KC ), 1 )
            ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              2-by-2 pivot block D(k): columns k and k-1 now hold
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              where U(k) and U(k-1) are the k-th and (k-1)-th columns
</span><span class="comment">*</span><span class="comment">              of U
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Perform a rank-2 update of A(1:k-2,1:k-2) as
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
</span><span class="comment">*</span><span class="comment">                 = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
</span><span class="comment">*</span><span class="comment">
</span>               IF( K.GT.2 ) THEN
<span class="comment">*</span><span class="comment">
</span>                  D = <a name="SLAPY2.319"></a><a href="slapy2.f.html#SLAPY2.1">SLAPY2</a>( REAL( AP( K-1+( K-1 )*K / 2 ) ),
     $                AIMAG( AP( K-1+( K-1 )*K / 2 ) ) )
                  D22 = REAL( AP( K-1+( K-2 )*( K-1 ) / 2 ) ) / D
                  D11 = REAL( AP( K+( K-1 )*K / 2 ) ) / D
                  TT = ONE / ( D11*D22-ONE )
                  D12 = AP( K-1+( K-1 )*K / 2 ) / D
                  D = TT / D
<span class="comment">*</span><span class="comment">
</span>                  DO 50 J = K - 2, 1, -1
                     WKM1 = D*( D11*AP( J+( K-2 )*( K-1 ) / 2 )-
     $                      CONJG( D12 )*AP( J+( K-1 )*K / 2 ) )
                     WK = D*( D22*AP( J+( K-1 )*K / 2 )-D12*
     $                    AP( J+( K-2 )*( K-1 ) / 2 ) )
                     DO 40 I = J, 1, -1
                        AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) -
     $                     AP( I+( K-1 )*K / 2 )*CONJG( WK ) -
     $                     AP( I+( K-2 )*( K-1 ) / 2 )*CONJG( WKM1 )
   40                CONTINUE
                     AP( J+( K-1 )*K / 2 ) = WK
                     AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
                     AP( J+( J-1 )*J / 2 ) = CMPLX( REAL( AP( J+( J-1 )*
     $                                       J / 2 ) ), 0.0E+0 )
   50             CONTINUE
<span class="comment">*</span><span class="comment">
</span>               END IF
<span class="comment">*</span><span class="comment">
</span>            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">        Decrease K and return to the start of the main loop
</span><span class="comment">*</span><span class="comment">
</span>         K = K - KSTEP
         KC = KNC - K
         GO TO 10
<span class="comment">*</span><span class="comment">
</span>      ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Factorize A as L*D*L' using the lower triangle of A
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        K is the main loop index, increasing from 1 to N in steps of
</span><span class="comment">*</span><span class="comment">        1 or 2
</span><span class="comment">*</span><span class="comment">
</span>         K = 1
         KC = 1
         NPP = N*( N+1 ) / 2
   60    CONTINUE
         KNC = KC
<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 110
         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( REAL( AP( KC ) ) )