zblat2.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,682 行 · 第 1/5 页
F
1,682 行
*
CALL ZMVCH( TRANS, M, N, ALPHA, A,
$ NMAX, X, INCX, BETA, Y,
$ INCY, YT, G, YY, EPS, ERR,
$ FATAL, NOUT, .TRUE. )
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 130
ELSE
* Avoid repeating tests with M.le.0 or
* N.le.0.
GO TO 110
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 CONTINUE
*
120 CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
WRITE( NOUT, FMT = 9999 )SNAME, NC
ELSE
WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
END IF
GO TO 140
*
130 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA,
$ INCX, BETA, INCY
ELSE IF( BANDED )THEN
WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU,
$ ALPHA, LDA, INCX, BETA, INCY
END IF
*
140 CONTINUE
RETURN
*
9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
$ 'S)' )
9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
$ 'ANGED INCORRECTLY *******' )
9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
$ ' - SUSPECT *******' )
9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), '(',
$ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',
$ F4.1, '), Y,', I2, ') .' )
9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(',
$ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',',
$ F4.1, '), Y,', I2, ') .' )
9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
$ '******' )
*
* End of ZCHK1.
*
END
SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
$ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
$ XS, Y, YY, YS, YT, G )
*
* Tests ZHEMV, ZHBMV and ZHPMV.
*
* Auxiliary routine for test program for Level 2 Blas.
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
COMPLEX*16 ZERO, HALF
PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ),
$ HALF = ( 0.5D0, 0.0D0 ) )
DOUBLE PRECISION RZERO
PARAMETER ( RZERO = 0.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
$ NOUT, NTRA
LOGICAL FATAL, REWI, TRACE
CHARACTER*6 SNAME
* .. Array Arguments ..
COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
$ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ),
$ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
$ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
$ YY( NMAX*INCMAX )
DOUBLE PRECISION G( NMAX )
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
* .. Local Scalars ..
COMPLEX*16 ALPHA, ALS, BETA, BLS, TRANSL
DOUBLE PRECISION ERR, ERRMAX
INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
$ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
$ N, NARGS, NC, NK, NS
LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
CHARACTER*1 UPLO, UPLOS
CHARACTER*2 ICH
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LZE, LZERES
EXTERNAL LZE, LZERES
* .. External Subroutines ..
EXTERNAL ZHBMV, ZHEMV, ZHPMV, ZMAKE, ZMVCH
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'UL'/
* .. Executable Statements ..
FULL = SNAME( 3: 3 ).EQ.'E'
BANDED = SNAME( 3: 3 ).EQ.'B'
PACKED = SNAME( 3: 3 ).EQ.'P'
* Define the number of arguments.
IF( FULL )THEN
NARGS = 10
ELSE IF( BANDED )THEN
NARGS = 11
ELSE IF( PACKED )THEN
NARGS = 9
END IF
*
NC = 0
RESET = .TRUE.
ERRMAX = RZERO
*
DO 110 IN = 1, NIDIM
N = IDIM( IN )
*
IF( BANDED )THEN
NK = NKB
ELSE
NK = 1
END IF
DO 100 IK = 1, NK
IF( BANDED )THEN
K = KB( IK )
ELSE
K = N - 1
END IF
* Set LDA to 1 more than minimum value if room.
IF( BANDED )THEN
LDA = K + 1
ELSE
LDA = N
END IF
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 100
IF( PACKED )THEN
LAA = ( N*( N + 1 ) )/2
ELSE
LAA = LDA*N
END IF
NULL = N.LE.0
*
DO 90 IC = 1, 2
UPLO = ICH( IC: IC )
*
* Generate the matrix A.
*
TRANSL = ZERO
CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA,
$ LDA, K, K, RESET, TRANSL )
*
DO 80 IX = 1, NINC
INCX = INC( IX )
LX = ABS( INCX )*N
*
* Generate the vector X.
*
TRANSL = HALF
CALL ZMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
$ ABS( INCX ), 0, N - 1, RESET, TRANSL )
IF( N.GT.1 )THEN
X( N/2 ) = ZERO
XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
END IF
*
DO 70 IY = 1, NINC
INCY = INC( IY )
LY = ABS( INCY )*N
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the vector Y.
*
TRANSL = ZERO
CALL ZMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
$ ABS( INCY ), 0, N - 1, RESET,
$ TRANSL )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
UPLOS = UPLO
NS = N
KS = K
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LX
XS( I ) = XX( I )
20 CONTINUE
INCXS = INCX
BLS = BETA
DO 30 I = 1, LY
YS( I ) = YY( I )
30 CONTINUE
INCYS = INCY
*
* Call the subroutine.
*
IF( FULL )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9993 )NC, SNAME,
$ UPLO, N, ALPHA, LDA, INCX, BETA, INCY
IF( REWI )
$ REWIND NTRA
CALL ZHEMV( UPLO, N, ALPHA, AA, LDA, XX,
$ INCX, BETA, YY, INCY )
ELSE IF( BANDED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
$ UPLO, N, K, ALPHA, LDA, INCX, BETA,
$ INCY
IF( REWI )
$ REWIND NTRA
CALL ZHBMV( UPLO, N, K, ALPHA, AA, LDA,
$ XX, INCX, BETA, YY, INCY )
ELSE IF( PACKED )THEN
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ UPLO, N, ALPHA, INCX, BETA, INCY
IF( REWI )
$ REWIND NTRA
CALL ZHPMV( UPLO, N, ALPHA, AA, XX, INCX,
$ BETA, YY, INCY )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9992 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = UPLO.EQ.UPLOS
ISAME( 2 ) = NS.EQ.N
IF( FULL )THEN
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LZE( AS, AA, LAA )
ISAME( 5 ) = LDAS.EQ.LDA
ISAME( 6 ) = LZE( XS, XX, LX )
ISAME( 7 ) = INCXS.EQ.INCX
ISAME( 8 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 9 ) = LZE( YS, YY, LY )
ELSE
ISAME( 9 ) = LZERES( 'GE', ' ', 1, N,
$ YS, YY, ABS( INCY ) )
END IF
ISAME( 10 ) = INCYS.EQ.INCY
ELSE IF( BANDED )THEN
ISAME( 3 ) = KS.EQ.K
ISAME( 4 ) = ALS.EQ.ALPHA
ISAME( 5 ) = LZE( AS, AA, LAA )
ISAME( 6 ) = LDAS.EQ.LDA
ISAME( 7 ) = LZE( XS, XX, LX )
ISAME( 8 ) = INCXS.EQ.INCX
ISAME( 9 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 10 ) = LZE( YS, YY, LY )
ELSE
ISAME( 10 ) = LZERES( 'GE', ' ', 1, N,
$ YS, YY, ABS( INCY ) )
END IF
ISAME( 11 ) = INCYS.EQ.INCY
ELSE IF( PACKED )THEN
ISAME( 3 ) = ALS.EQ.ALPHA
ISAME( 4 ) = LZE( AS, AA, LAA )
ISAME( 5 ) = LZE( XS, XX, LX )
ISAME( 6 ) = INCXS.EQ.INCX
ISAME( 7 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 8 ) = LZE( YS, YY, LY )
ELSE
ISAME( 8 ) = LZERES( 'GE', ' ', 1, N,
$ YS, YY, ABS( INCY ) )
END IF
ISAME( 9 ) = INCYS.EQ.INCY
END IF
*
* If data was incorrectly changed, report and
* return.
*
SAME = .TRUE.
DO 40 I = 1, NARGS
SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
$ WRITE( NOUT, FMT = 9998 )I
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?