dsbtrd.f.html

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

<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Reduce i-th row of matrix to tridiagonal form
</span><span class="comment">*</span><span class="comment">
</span>               DO 80 K = KDN + 1, 2, -1
                  J1 = J1 + KDN
                  J2 = J2 + KDN
<span class="comment">*</span><span class="comment">
</span>                  IF( NR.GT.0 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    generate plane rotations to annihilate nonzero
</span><span class="comment">*</span><span class="comment">                    elements which have been created outside the band
</span><span class="comment">*</span><span class="comment">
</span>                     CALL <a name="DLARGV.187"></a><a href="dlargv.f.html#DLARGV.1">DLARGV</a>( NR, AB( 1, J1-1 ), INCA, WORK( J1 ),
     $                            KD1, D( J1 ), KD1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    apply rotations from the right
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    Dependent on the the number of diagonals either
</span><span class="comment">*</span><span class="comment">                    <a name="DLARTV.194"></a><a href="dlartv.f.html#DLARTV.1">DLARTV</a> or DROT is used
</span><span class="comment">*</span><span class="comment">
</span>                     IF( NR.GE.2*KD-1 ) THEN
                        DO 10 L = 1, KD - 1
                           CALL <a name="DLARTV.198"></a><a href="dlartv.f.html#DLARTV.1">DLARTV</a>( NR, AB( L+1, J1-1 ), INCA,
     $                                  AB( L, J1 ), INCA, D( J1 ),
     $                                  WORK( J1 ), KD1 )
   10                   CONTINUE
<span class="comment">*</span><span class="comment">
</span>                     ELSE
                        JEND = J1 + ( NR-1 )*KD1
                        DO 20 JINC = J1, JEND, KD1
                           CALL DROT( KDM1, AB( 2, JINC-1 ), 1,
     $                                AB( 1, JINC ), 1, D( JINC ),
     $                                WORK( JINC ) )
   20                   CONTINUE
                     END IF
                  END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">
</span>                  IF( K.GT.2 ) THEN
                     IF( K.LE.N-I+1 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                       generate plane rotation to annihilate a(i,i+k-1)
</span><span class="comment">*</span><span class="comment">                       within the band
</span><span class="comment">*</span><span class="comment">
</span>                        CALL <a name="DLARTG.220"></a><a href="dlartg.f.html#DLARTG.1">DLARTG</a>( AB( KD-K+3, I+K-2 ),
     $                               AB( KD-K+2, I+K-1 ), D( I+K-1 ),
     $                               WORK( I+K-1 ), TEMP )
                        AB( KD-K+3, I+K-2 ) = TEMP
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                       apply rotation from the right
</span><span class="comment">*</span><span class="comment">
</span>                        CALL DROT( K-3, AB( KD-K+4, I+K-2 ), 1,
     $                             AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ),
     $                             WORK( I+K-1 ) )
                     END IF
                     NR = NR + 1
                     J1 = J1 - KDN - 1
                  END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 apply plane rotations from both sides to diagonal
</span><span class="comment">*</span><span class="comment">                 blocks
</span><span class="comment">*</span><span class="comment">
</span>                  IF( NR.GT.0 )
     $               CALL <a name="DLAR2V.239"></a><a href="dlar2v.f.html#DLAR2V.1">DLAR2V</a>( NR, AB( KD1, J1-1 ), AB( KD1, J1 ),
     $                            AB( KD, J1 ), INCA, D( J1 ),
     $                            WORK( J1 ), KD1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 apply plane rotations from the left
</span><span class="comment">*</span><span class="comment">
</span>                  IF( NR.GT.0 ) THEN
                     IF( 2*KD-1.LT.NR ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    Dependent on the the number of diagonals either
</span><span class="comment">*</span><span class="comment">                    <a name="DLARTV.249"></a><a href="dlartv.f.html#DLARTV.1">DLARTV</a> or DROT is used
</span><span class="comment">*</span><span class="comment">
</span>                        DO 30 L = 1, KD - 1
                           IF( J2+L.GT.N ) THEN
                              NRT = NR - 1
                           ELSE
                              NRT = NR
                           END IF
                           IF( NRT.GT.0 )
     $                        CALL <a name="DLARTV.258"></a><a href="dlartv.f.html#DLARTV.1">DLARTV</a>( NRT, AB( KD-L, J1+L ), INCA,
     $                                     AB( KD-L+1, J1+L ), INCA,
     $                                     D( J1 ), WORK( J1 ), KD1 )
   30                   CONTINUE
                     ELSE
                        J1END = J1 + KD1*( NR-2 )
                        IF( J1END.GE.J1 ) THEN
                           DO 40 JIN = J1, J1END, KD1
                              CALL DROT( KD-1, AB( KD-1, JIN+1 ), INCX,
     $                                   AB( KD, JIN+1 ), INCX,
     $                                   D( JIN ), WORK( JIN ) )
   40                      CONTINUE
                        END IF
                        LEND = MIN( KDM1, N-J2 )
                        LAST = J1END + KD1
                        IF( LEND.GT.0 )
     $                     CALL DROT( LEND, AB( KD-1, LAST+1 ), INCX,
     $                                AB( KD, LAST+1 ), INCX, D( LAST ),
     $                                WORK( LAST ) )
                     END IF
                  END IF
<span class="comment">*</span><span class="comment">
</span>                  IF( WANTQ ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    accumulate product of plane rotations in Q
</span><span class="comment">*</span><span class="comment">
</span>                     IF( INITQ ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 take advantage of the fact that Q was
</span><span class="comment">*</span><span class="comment">                 initially the Identity matrix
</span><span class="comment">*</span><span class="comment">
</span>                        IQEND = MAX( IQEND, J2 )
                        I2 = MAX( 0, K-3 )
                        IQAEND = 1 + I*KD
                        IF( K.EQ.2 )
     $                     IQAEND = IQAEND + KD
                        IQAEND = MIN( IQAEND, IQEND )
                        DO 50 J = J1, J2, KD1
                           IBL = I - I2 / KDM1
                           I2 = I2 + 1
                           IQB = MAX( 1, J-IBL )
                           NQ = 1 + IQAEND - IQB
                           IQAEND = MIN( IQAEND+KD, IQEND )
                           CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
     $                                1, D( J ), WORK( J ) )
   50                   CONTINUE
                     ELSE
<span class="comment">*</span><span class="comment">
</span>                        DO 60 J = J1, J2, KD1
                           CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
     $                                D( J ), WORK( J ) )
   60                   CONTINUE
                     END IF
<span class="comment">*</span><span class="comment">
</span>                  END IF
<span class="comment">*</span><span class="comment">
</span>                  IF( J2+KDN.GT.N ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    adjust J2 to keep within the bounds of the matrix
</span><span class="comment">*</span><span class="comment">
</span>                     NR = NR - 1
                     J2 = J2 - KDN - 1
                  END IF
<span class="comment">*</span><span class="comment">
</span>                  DO 70 J = J1, J2, KD1
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    create nonzero element a(j-1,j+kd) outside the band
</span><span class="comment">*</span><span class="comment">                    and store it in WORK
</span><span class="comment">*</span><span class="comment">
</span>                     WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
                     AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
   70             CONTINUE
   80          CONTINUE
   90       CONTINUE
         END IF
<span class="comment">*</span><span class="comment">
</span>         IF( KD.GT.0 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           copy off-diagonal elements to E
</span><span class="comment">*</span><span class="comment">
</span>            DO 100 I = 1, N - 1
               E( I ) = AB( KD, I+1 )
  100       CONTINUE
         ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           set E to zero if original matrix was diagonal
</span><span class="comment">*</span><span class="comment">
</span>            DO 110 I = 1, N - 1
               E( I ) = ZERO
  110       CONTINUE
         END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        copy diagonal elements to D
</span><span class="comment">*</span><span class="comment">
</span>         DO 120 I = 1, N
            D( I ) = AB( KD1, I )
  120    CONTINUE
<span class="comment">*</span><span class="comment">
</span>      ELSE
<span class="comment">*</span><span class="comment">
</span>         IF( KD.GT.1 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Reduce to tridiagonal form, working with lower triangle
</span><span class="comment">*</span><span class="comment">
</span>            NR = 0
            J1 = KDN + 2
            J2 = 1
<span class="comment">*</span><span class="comment">
</span>            DO 210 I = 1, N - 2
<span class="comment">*</span><span class="comment">