dlatmr.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,101 行 · 第 1/3 页
F
1,101 行
*
ELSE IF( IPACK.EQ.2 ) THEN
*
DO 160 J = 1, N
DO 150 I = 1, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MXSUB, MNSUB ) = TEMP
IF( MNSUB.NE.MXSUB )
$ A( MNSUB, MXSUB ) = ZERO
150 CONTINUE
160 CONTINUE
*
ELSE IF( IPACK.EQ.3 ) THEN
*
DO 180 J = 1, N
DO 170 I = 1, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
*
* Compute K = location of (ISUB,JSUB) entry in packed
* array
*
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
K = MXSUB*( MXSUB-1 ) / 2 + MNSUB
*
* Convert K to (IISUB,JJSUB) location
*
JJSUB = ( K-1 ) / LDA + 1
IISUB = K - LDA*( JJSUB-1 )
*
A( IISUB, JJSUB ) = TEMP
170 CONTINUE
180 CONTINUE
*
ELSE IF( IPACK.EQ.4 ) THEN
*
DO 200 J = 1, N
DO 190 I = 1, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
*
* Compute K = location of (I,J) entry in packed array
*
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
IF( MNSUB.EQ.1 ) THEN
K = MXSUB
ELSE
K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) /
$ 2 + MXSUB - MNSUB + 1
END IF
*
* Convert K to (IISUB,JJSUB) location
*
JJSUB = ( K-1 ) / LDA + 1
IISUB = K - LDA*( JJSUB-1 )
*
A( IISUB, JJSUB ) = TEMP
190 CONTINUE
200 CONTINUE
*
ELSE IF( IPACK.EQ.5 ) THEN
*
DO 220 J = 1, N
DO 210 I = J - KUU, J
IF( I.LT.1 ) THEN
A( J-I+1, I+N ) = ZERO
ELSE
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MXSUB-MNSUB+1, MNSUB ) = TEMP
END IF
210 CONTINUE
220 CONTINUE
*
ELSE IF( IPACK.EQ.6 ) THEN
*
DO 240 J = 1, N
DO 230 I = J - KUU, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
$ SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP
230 CONTINUE
240 CONTINUE
*
ELSE IF( IPACK.EQ.7 ) THEN
*
IF( ISYM.EQ.0 ) THEN
DO 260 J = 1, N
DO 250 I = J - KUU, J
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
MNSUB = MIN( ISUB, JSUB )
MXSUB = MAX( ISUB, JSUB )
A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP
IF( I.LT.1 )
$ A( J-I+1+KUU, I+N ) = ZERO
IF( I.GE.1 .AND. MNSUB.NE.MXSUB )
$ A( MXSUB-MNSUB+1+KUU, MNSUB ) = TEMP
250 CONTINUE
260 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 280 J = 1, N
DO 270 I = J - KUU, J + KLL
TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( ISUB-JSUB+KUU+1, JSUB ) = TEMP
270 CONTINUE
280 CONTINUE
END IF
*
END IF
*
ELSE
*
* Use DLATM2
*
IF( IPACK.EQ.0 ) THEN
IF( ISYM.EQ.0 ) THEN
DO 300 J = 1, N
DO 290 I = 1, J
A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
A( J, I ) = A( I, J )
290 CONTINUE
300 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 320 J = 1, N
DO 310 I = 1, M
A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
310 CONTINUE
320 CONTINUE
END IF
*
ELSE IF( IPACK.EQ.1 ) THEN
*
DO 340 J = 1, N
DO 330 I = 1, J
A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, ISEED,
$ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
IF( I.NE.J )
$ A( J, I ) = ZERO
330 CONTINUE
340 CONTINUE
*
ELSE IF( IPACK.EQ.2 ) THEN
*
DO 360 J = 1, N
DO 350 I = 1, J
A( J, I ) = DLATM2( M, N, I, J, KL, KU, IDIST, ISEED,
$ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
IF( I.NE.J )
$ A( I, J ) = ZERO
350 CONTINUE
360 CONTINUE
*
ELSE IF( IPACK.EQ.3 ) THEN
*
ISUB = 0
JSUB = 1
DO 380 J = 1, N
DO 370 I = 1, J
ISUB = ISUB + 1
IF( ISUB.GT.LDA ) THEN
ISUB = 1
JSUB = JSUB + 1
END IF
A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
370 CONTINUE
380 CONTINUE
*
ELSE IF( IPACK.EQ.4 ) THEN
*
IF( ISYM.EQ.0 ) THEN
DO 400 J = 1, N
DO 390 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 ) = DLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR,
$ IPVTNG, IWORK, SPARSE )
390 CONTINUE
400 CONTINUE
ELSE
ISUB = 0
JSUB = 1
DO 420 J = 1, N
DO 410 I = J, M
ISUB = ISUB + 1
IF( ISUB.GT.LDA ) THEN
ISUB = 1
JSUB = JSUB + 1
END IF
A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL, DR,
$ IPVTNG, IWORK, SPARSE )
410 CONTINUE
420 CONTINUE
END IF
*
ELSE IF( IPACK.EQ.5 ) THEN
*
DO 440 J = 1, N
DO 430 I = J - KUU, J
IF( I.LT.1 ) THEN
A( J-I+1, I+N ) = ZERO
ELSE
A( J-I+1, I ) = DLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
END IF
430 CONTINUE
440 CONTINUE
*
ELSE IF( IPACK.EQ.6 ) THEN
*
DO 460 J = 1, N
DO 450 I = J - KUU, J
A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU, IDIST,
$ ISEED, D, IGRADE, DL, DR, IPVTNG,
$ IWORK, SPARSE )
450 CONTINUE
460 CONTINUE
*
ELSE IF( IPACK.EQ.7 ) THEN
*
IF( ISYM.EQ.0 ) THEN
DO 480 J = 1, N
DO 470 I = J - KUU, J
A( I-J+KUU+1, J ) = DLATM2( 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 ) = ZERO
IF( I.GE.1 .AND. I.NE.J )
$ A( J-I+1+KUU, I ) = A( I-J+KUU+1, J )
470 CONTINUE
480 CONTINUE
ELSE IF( ISYM.EQ.1 ) THEN
DO 500 J = 1, N
DO 490 I = J - KUU, J + KLL
A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU,
$ IDIST, ISEED, D, IGRADE, DL,
$ DR, IPVTNG, IWORK, SPARSE )
490 CONTINUE
500 CONTINUE
END IF
*
END IF
*
END IF
*
* 5) Scaling the norm
*
IF( IPACK.EQ.0 ) THEN
ONORM = DLANGE( 'M', M, N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.1 ) THEN
ONORM = DLANSY( 'M', 'U', N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.2 ) THEN
ONORM = DLANSY( 'M', 'L', N, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.3 ) THEN
ONORM = DLANSP( 'M', 'U', N, A, TEMPA )
ELSE IF( IPACK.EQ.4 ) THEN
ONORM = DLANSP( 'M', 'L', N, A, TEMPA )
ELSE IF( IPACK.EQ.5 ) THEN
ONORM = DLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.6 ) THEN
ONORM = DLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA )
ELSE IF( IPACK.EQ.7 ) THEN
ONORM = DLANGB( '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 510 J = 1, N
CALL DSCAL( M, ONE / ONORM, A( 1, J ), 1 )
CALL DSCAL( M, ANORM, A( 1, J ), 1 )
510 CONTINUE
*
ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
*
CALL DSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 )
CALL DSCAL( N*( N+1 ) / 2, ANORM, A, 1 )
*
ELSE IF( IPACK.GE.5 ) THEN
*
DO 520 J = 1, N
CALL DSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 )
CALL DSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 )
520 CONTINUE
*
END IF
*
ELSE
*
* Scale straightforwardly
*
IF( IPACK.LE.2 ) THEN
DO 530 J = 1, N
CALL DSCAL( M, ANORM / ONORM, A( 1, J ), 1 )
530 CONTINUE
*
ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
*
CALL DSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 )
*
ELSE IF( IPACK.GE.5 ) THEN
*
DO 540 J = 1, N
CALL DSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 )
540 CONTINUE
END IF
*
END IF
*
END IF
*
* End of DLATMR
*
END
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?