slaexc.f.html

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

HTML
378 行
字号
12
</span><span class="comment">*</span><span class="comment">
</span>         K = N1 + N1 + N2 - 3
         GO TO ( 10, 20, 30 )K
<span class="comment">*</span><span class="comment">
</span>   10    CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        N1 = 1, N2 = 2: generate elementary reflector H so that:
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        ( scale, X11, X12 ) H = ( 0, 0, * )
</span><span class="comment">*</span><span class="comment">
</span>         U( 1 ) = SCALE
         U( 2 ) = X( 1, 1 )
         U( 3 ) = X( 1, 2 )
         CALL <a name="SLARFG.184"></a><a href="slarfg.f.html#SLARFG.1">SLARFG</a>( 3, U( 3 ), U, 1, TAU )
         U( 3 ) = ONE
         T11 = T( J1, J1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Perform swap provisionally on diagonal block in D.
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="SLARFX.190"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'L'</span>, 3, 3, U, TAU, D, LDD, WORK )
         CALL <a name="SLARFX.191"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, 3, 3, U, TAU, D, LDD, WORK )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Test whether to reject swap.
</span><span class="comment">*</span><span class="comment">
</span>         IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3,
     $       3 )-T11 ) ).GT.THRESH )GO TO 50
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Accept swap: apply transformation to the entire matrix T.
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="SLARFX.200"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'L'</span>, 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK )
         CALL <a name="SLARFX.201"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, J2, 3, U, TAU, T( 1, J1 ), LDT, WORK )
<span class="comment">*</span><span class="comment">
</span>         T( J3, J1 ) = ZERO
         T( J3, J2 ) = ZERO
         T( J3, J3 ) = T11
<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 transformation in the matrix Q.
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="SLARFX.211"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
         END IF
         GO TO 40
<span class="comment">*</span><span class="comment">
</span>   20    CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        N1 = 2, N2 = 1: generate elementary reflector H so that:
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        H (  -X11 ) = ( * )
</span><span class="comment">*</span><span class="comment">          (  -X21 ) = ( 0 )
</span><span class="comment">*</span><span class="comment">          ( scale ) = ( 0 )
</span><span class="comment">*</span><span class="comment">
</span>         U( 1 ) = -X( 1, 1 )
         U( 2 ) = -X( 2, 1 )
         U( 3 ) = SCALE
         CALL <a name="SLARFG.226"></a><a href="slarfg.f.html#SLARFG.1">SLARFG</a>( 3, U( 1 ), U( 2 ), 1, TAU )
         U( 1 ) = ONE
         T33 = T( J3, J3 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Perform swap provisionally on diagonal block in D.
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="SLARFX.232"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'L'</span>, 3, 3, U, TAU, D, LDD, WORK )
         CALL <a name="SLARFX.233"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, 3, 3, U, TAU, D, LDD, WORK )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Test whether to reject swap.
</span><span class="comment">*</span><span class="comment">
</span>         IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1,
     $       1 )-T33 ) ).GT.THRESH )GO TO 50
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Accept swap: apply transformation to the entire matrix T.
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="SLARFX.242"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, J3, 3, U, TAU, T( 1, J1 ), LDT, WORK )
         CALL <a name="SLARFX.243"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'L'</span>, 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK )
<span class="comment">*</span><span class="comment">
</span>         T( J1, J1 ) = T33
         T( J2, J1 ) = ZERO
         T( J3, J1 ) = ZERO
<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 transformation in the matrix Q.
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="SLARFX.253"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
         END IF
         GO TO 40
<span class="comment">*</span><span class="comment">
</span>   30    CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
</span><span class="comment">*</span><span class="comment">        that:
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        H(2) H(1) (  -X11  -X12 ) = (  *  * )
</span><span class="comment">*</span><span class="comment">                  (  -X21  -X22 )   (  0  * )
</span><span class="comment">*</span><span class="comment">                  ( scale    0  )   (  0  0 )
</span><span class="comment">*</span><span class="comment">                  (    0  scale )   (  0  0 )
</span><span class="comment">*</span><span class="comment">
</span>         U1( 1 ) = -X( 1, 1 )
         U1( 2 ) = -X( 2, 1 )
         U1( 3 ) = SCALE
         CALL <a name="SLARFG.270"></a><a href="slarfg.f.html#SLARFG.1">SLARFG</a>( 3, U1( 1 ), U1( 2 ), 1, TAU1 )
         U1( 1 ) = ONE
<span class="comment">*</span><span class="comment">
</span>         TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) )
         U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 )
         U2( 2 ) = -TEMP*U1( 3 )
         U2( 3 ) = SCALE
         CALL <a name="SLARFG.277"></a><a href="slarfg.f.html#SLARFG.1">SLARFG</a>( 3, U2( 1 ), U2( 2 ), 1, TAU2 )
         U2( 1 ) = ONE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Perform swap provisionally on diagonal block in D.
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="SLARFX.282"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'L'</span>, 3, 4, U1, TAU1, D, LDD, WORK )
         CALL <a name="SLARFX.283"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, 4, 3, U1, TAU1, D, LDD, WORK )
         CALL <a name="SLARFX.284"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'L'</span>, 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK )
         CALL <a name="SLARFX.285"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Test whether to reject swap.
</span><span class="comment">*</span><span class="comment">
</span>         IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ),
     $       ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Accept swap: apply transformation to the entire matrix T.
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="SLARFX.294"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'L'</span>, 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK )
         CALL <a name="SLARFX.295"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK )
         CALL <a name="SLARFX.296"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'L'</span>, 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK )
         CALL <a name="SLARFX.297"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK )
<span class="comment">*</span><span class="comment">
</span>         T( J3, J1 ) = ZERO
         T( J3, J2 ) = ZERO
         T( J4, J1 ) = ZERO
         T( J4, J2 ) = ZERO
<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 transformation in the matrix Q.
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="SLARFX.308"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK )
            CALL <a name="SLARFX.309"></a><a href="slarfx.f.html#SLARFX.1">SLARFX</a>( <span class="string">'R'</span>, N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK )
         END IF
<span class="comment">*</span><span class="comment">
</span>   40    CONTINUE
<span class="comment">*</span><span class="comment">
</span>         IF( N2.EQ.2 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Standardize new 2-by-2 block T11
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="SLANV2.318"></a><a href="slanv2.f.html#SLANV2.1">SLANV2</a>( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ),
     $                   T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN )
            CALL SROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT,
     $                 CS, SN )
            CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
            IF( WANTQ )
     $         CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
         END IF
<span class="comment">*</span><span class="comment">
</span>         IF( N1.EQ.2 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Standardize new 2-by-2 block T22
</span><span class="comment">*</span><span class="comment">
</span>            J3 = J1 + N2
            J4 = J3 + 1
            CALL <a name="SLANV2.333"></a><a href="slanv2.f.html#SLANV2.1">SLANV2</a>( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ),
     $                   T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN )
            IF( J3+2.LE.N )
     $         CALL SROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ),
     $                    LDT, CS, SN )
            CALL SROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN )
            IF( WANTQ )
     $         CALL SROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN )
         END IF
<span class="comment">*</span><span class="comment">
</span>      END IF
      RETURN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Exit with INFO = 1 if swap was rejected.
</span><span class="comment">*</span><span class="comment">
</span>   50 INFO = 1
      RETURN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     End of <a name="SLAEXC.351"></a><a href="slaexc.f.html#SLAEXC.1">SLAEXC</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>
12

slaexc.f.html - 源码说明

本页面展示了「famous linear algebra library (LAPACK) ports to windows」中的 slaexc.f.html 源码文件，采用 HTML 编程语言编写，共 378 行代码。您可以在线阅读完整代码内容，也可以返回资源详情页下载完整源码包进行本地学习和开发。

虫虫下载站收录了大量与algebra相关的技术资源，包括源代码、技术文档、电路图等，是电子工程师和嵌入式开发者的专业学习平台。

⌨️ 快捷键说明

复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?