zlatmr.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,215 行 · 第 1/4 页
F
1,215 行
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
IF( I.LT.1 )
$ A( J-I+1+KUU, I+N ) = CZERO
IF( MXSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN
A( MNSUB-MXSUB+KUU+1, MXSUB ) = DCONJG( CTEMP )
ELSE
A( MNSUB-MXSUB+KUU+1, MXSUB ) = CTEMP
END IF
IF( I.GE.1 .AND. MNSUB.NE.MXSUB ) THEN
IF( MNSUB.EQ.ISUB .AND. ISYM.EQ.0 ) THEN
A( MXSUB-MNSUB+1+KUU,
$ MNSUB ) = DCONJG( CTEMP )
ELSE
A( MXSUB-MNSUB+1+KUU, MNSUB ) = CTEMP
END IF
END IF
280 CONTINUE
290 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 310 J = 1, N
DO 300 I = J - KUU, J + KLL
CTEMP = ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( ISUB-JSUB+KUU+1, JSUB ) = CTEMP
300 CONTINUE
310 CONTINUE
END IF
*
END IF
*
ELSE
*
* Use ZLATM2
*
IF( IPACK.EQ.0 ) THEN
IF( ISYM.EQ.0 ) THEN
DO 330 J = 1, N
DO 320 I = 1, J
A( I, J ) = ZLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( J, I ) = DCONJG( A( I, J ) )
320 CONTINUE
330 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 350 J = 1, N
DO 340 I = 1, M
A( I, J ) = ZLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
340 CONTINUE
350 CONTINUE
ELSE IF( ISYM.EQ.2 ) THEN
DO 370 J = 1, N
DO 360 I = 1, J
A( I, J ) = ZLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( J, I ) = A( I, J )
360 CONTINUE
370 CONTINUE
END IF
*
ELSE IF( IPACK.EQ.1 ) THEN
*
DO 390 J = 1, N
DO 380 I = 1, J
A( I, J ) = ZLATM2( M, N, I, J, KL, KU, IDIST, ISEED,
$ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
IF( I.NE.J )
$ A( J, I ) = CZERO
380 CONTINUE
390 CONTINUE
*
ELSE IF( IPACK.EQ.2 ) THEN
*
DO 410 J = 1, N
DO 400 I = 1, J
IF( ISYM.EQ.0 ) THEN
A( J, I ) = DCONJG( ZLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR,
$ IPVTNG, IWORK, SPARSE ) )
ELSE
A( J, I ) = ZLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
END IF
IF( I.NE.J )
$ A( I, J ) = CZERO
400 CONTINUE
410 CONTINUE
*
ELSE IF( IPACK.EQ.3 ) THEN
*
ISUB = 0
JSUB = 1
DO 430 J = 1, N
DO 420 I = 1, J
ISUB = ISUB + 1
IF( ISUB.GT.LDA ) THEN
ISUB = 1
JSUB = JSUB + 1
END IF
A( ISUB, JSUB ) = ZLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
420 CONTINUE
430 CONTINUE
*
ELSE IF( IPACK.EQ.4 ) THEN
*
IF( ISYM.EQ.0 .OR. ISYM.EQ.2 ) THEN
DO 450 J = 1, N
DO 440 I = 1, J
*
* Compute K = location of (I,J) entry in packed array
*
IF( I.EQ.1 ) THEN
K = J
ELSE
K = N*( N+1 ) / 2 - ( N-I+1 )*( N-I+2 ) / 2 +
$ J - I + 1
END IF
*
* Convert K to (ISUB,JSUB) location
*
JSUB = ( K-1 ) / LDA + 1
ISUB = K - LDA*( JSUB-1 )
*
A( ISUB, JSUB ) = ZLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR,
$ IPVTNG, IWORK, SPARSE )
IF( ISYM.EQ.0 )
$ A( ISUB, JSUB ) = DCONJG( A( ISUB, JSUB ) )
440 CONTINUE
450 CONTINUE
ELSE
ISUB = 0
JSUB = 1
DO 470 J = 1, N
DO 460 I = J, M
ISUB = ISUB + 1
IF( ISUB.GT.LDA ) THEN
ISUB = 1
JSUB = JSUB + 1
END IF
A( ISUB, JSUB ) = ZLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR,
$ IPVTNG, IWORK, SPARSE )
460 CONTINUE
470 CONTINUE
END IF
*
ELSE IF( IPACK.EQ.5 ) THEN
*
DO 490 J = 1, N
DO 480 I = J - KUU, J
IF( I.LT.1 ) THEN
A( J-I+1, I+N ) = CZERO
ELSE
IF( ISYM.EQ.0 ) THEN
A( J-I+1, I ) = DCONJG( ZLATM2( M, N, I, J, KL,
$ KU, IDIST, ISEED, D, IGRADE, DL,
$ DR, IPVTNG, IWORK, SPARSE ) )
ELSE
A( J-I+1, I ) = ZLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR,
$ IPVTNG, IWORK, SPARSE )
END IF
END IF
480 CONTINUE
490 CONTINUE
*
ELSE IF( IPACK.EQ.6 ) THEN
*
DO 510 J = 1, N
DO 500 I = J - KUU, J
A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
500 CONTINUE
510 CONTINUE
*
ELSE IF( IPACK.EQ.7 ) THEN
*
IF( ISYM.NE.1 ) THEN
DO 530 J = 1, N
DO 520 I = J - KUU, J
A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL,
$ DR, IPVTNG, IWORK, SPARSE )
IF( I.LT.1 )
$ A( J-I+1+KUU, I+N ) = CZERO
IF( I.GE.1 .AND. I.NE.J ) THEN
IF( ISYM.EQ.0 ) THEN
A( J-I+1+KUU, I ) = DCONJG( A( I-J+KUU+1,
$ J ) )
ELSE
A( J-I+1+KUU, I ) = A( I-J+KUU+1, J )
END IF
END IF
520 CONTINUE
530 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 550 J = 1, N
DO 540 I = J - KUU, J + KLL
A( I-J+KUU+1, J ) = ZLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL,
$ DR, IPVTNG, IWORK, SPARSE )
540 CONTINUE
550 CONTINUE
END IF
*
END IF
*
END IF
*
* 5) Scaling the norm
*
IF( IPACK.EQ.0 ) THEN
ONORM = ZLANGE( 'M', M, N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.1 ) THEN
ONORM = ZLANSY( 'M', 'U', N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.2 ) THEN
ONORM = ZLANSY( 'M', 'L', N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.3 ) THEN
ONORM = ZLANSP( 'M', 'U', N, A, TEMPA )
ELSE IF( IPACK.EQ.4 ) THEN
ONORM = ZLANSP( 'M', 'L', N, A, TEMPA )
ELSE IF( IPACK.EQ.5 ) THEN
ONORM = ZLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.6 ) THEN
ONORM = ZLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.7 ) THEN
ONORM = ZLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA )
END IF
*
IF( ANORM.GE.ZERO ) THEN
*
IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN
*
* Desired scaling impossible
*
INFO = 5
RETURN
*
ELSE IF( ( ANORM.GT.ONE .AND. ONORM.LT.ONE ) .OR.
$ ( ANORM.LT.ONE .AND. ONORM.GT.ONE ) ) THEN
*
* Scale carefully to avoid over / underflow
*
IF( IPACK.LE.2 ) THEN
DO 560 J = 1, N
CALL ZDSCAL( M, ONE / ONORM, A( 1, J ), 1 )
CALL ZDSCAL( M, ANORM, A( 1, J ), 1 )
560 CONTINUE
*
ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
*
CALL ZDSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 )
CALL ZDSCAL( N*( N+1 ) / 2, ANORM, A, 1 )
*
ELSE IF( IPACK.GE.5 ) THEN
*
DO 570 J = 1, N
CALL ZDSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 )
CALL ZDSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 )
570 CONTINUE
*
END IF
*
ELSE
*
* Scale straightforwardly
*
IF( IPACK.LE.2 ) THEN
DO 580 J = 1, N
CALL ZDSCAL( M, ANORM / ONORM, A( 1, J ), 1 )
580 CONTINUE
*
ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
*
CALL ZDSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 )
*
ELSE IF( IPACK.GE.5 ) THEN
*
DO 590 J = 1, N
CALL ZDSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 )
590 CONTINUE
END IF
*
END IF
*
END IF
*
* End of ZLATMR
*
END
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?