zblat3.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,738 行 · 第 1/5 页
F
1,738 行
$ 7( '(', F4.1, ',', F4.1, ') ', : ) )
9992 FORMAT( ' FOR BETA ',
$ 7( '(', F4.1, ',', F4.1, ') ', : ) )
9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
$ /' ******* TESTS ABANDONED *******' )
9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
$ 'ESTS ABANDONED *******' )
9989 FORMAT( ' ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
$ 'ATED WRONGLY.', /' ZMMCH WAS CALLED WITH TRANSA = ', A1,
$ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
$ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
$ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
$ '*******' )
9988 FORMAT( A6, L2 )
9987 FORMAT( 1X, A6, ' WAS NOT TESTED' )
9986 FORMAT( /' END OF TESTS' )
9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
*
* End of ZBLAT3.
*
END
SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
$ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
$ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
*
* Tests ZGEMM.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- Written on 8-February-1989.
* Jack Dongarra, Argonne National Laboratory.
* Iain Duff, AERE Harwell.
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
* Sven Hammarling, Numerical Algorithms Group Ltd.
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) )
DOUBLE PRECISION RZERO
PARAMETER ( RZERO = 0.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, 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 ), B( NMAX, NMAX ),
$ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
$ C( NMAX, NMAX ), CC( NMAX*NMAX ),
$ CS( NMAX*NMAX ), CT( NMAX )
DOUBLE PRECISION G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
COMPLEX*16 ALPHA, ALS, BETA, BLS
DOUBLE PRECISION ERR, ERRMAX
INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
$ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
$ MA, MB, MS, N, NA, NARGS, NB, NC, NS
LOGICAL NULL, RESET, SAME, TRANA, TRANB
CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
CHARACTER*3 ICH
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LZE, LZERES
EXTERNAL LZE, LZERES
* .. External Subroutines ..
EXTERNAL ZGEMM, ZMAKE, ZMMCH
* .. Intrinsic Functions ..
INTRINSIC MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL LERR, OK
* .. Common blocks ..
COMMON /INFOC/INFOT, NOUTC, OK, LERR
* .. Data statements ..
DATA ICH/'NTC'/
* .. Executable Statements ..
*
NARGS = 13
NC = 0
RESET = .TRUE.
ERRMAX = RZERO
*
DO 110 IM = 1, NIDIM
M = IDIM( IM )
*
DO 100 IN = 1, NIDIM
N = IDIM( IN )
* Set LDC to 1 more than minimum value if room.
LDC = M
IF( LDC.LT.NMAX )
$ LDC = LDC + 1
* Skip tests if not enough room.
IF( LDC.GT.NMAX )
$ GO TO 100
LCC = LDC*N
NULL = N.LE.0.OR.M.LE.0
*
DO 90 IK = 1, NIDIM
K = IDIM( IK )
*
DO 80 ICA = 1, 3
TRANSA = ICH( ICA: ICA )
TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
*
IF( TRANA )THEN
MA = K
NA = M
ELSE
MA = M
NA = K
END IF
* Set LDA to 1 more than minimum value if room.
LDA = MA
IF( LDA.LT.NMAX )
$ LDA = LDA + 1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
$ GO TO 80
LAA = LDA*NA
*
* Generate the matrix A.
*
CALL ZMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
$ RESET, ZERO )
*
DO 70 ICB = 1, 3
TRANSB = ICH( ICB: ICB )
TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
*
IF( TRANB )THEN
MB = N
NB = K
ELSE
MB = K
NB = N
END IF
* Set LDB to 1 more than minimum value if room.
LDB = MB
IF( LDB.LT.NMAX )
$ LDB = LDB + 1
* Skip tests if not enough room.
IF( LDB.GT.NMAX )
$ GO TO 70
LBB = LDB*NB
*
* Generate the matrix B.
*
CALL ZMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
$ LDB, RESET, ZERO )
*
DO 60 IA = 1, NALF
ALPHA = ALF( IA )
*
DO 50 IB = 1, NBET
BETA = BET( IB )
*
* Generate the matrix C.
*
CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX,
$ CC, LDC, RESET, ZERO )
*
NC = NC + 1
*
* Save every datum before calling the
* subroutine.
*
TRANAS = TRANSA
TRANBS = TRANSB
MS = M
NS = N
KS = K
ALS = ALPHA
DO 10 I = 1, LAA
AS( I ) = AA( I )
10 CONTINUE
LDAS = LDA
DO 20 I = 1, LBB
BS( I ) = BB( I )
20 CONTINUE
LDBS = LDB
BLS = BETA
DO 30 I = 1, LCC
CS( I ) = CC( I )
30 CONTINUE
LDCS = LDC
*
* Call the subroutine.
*
IF( TRACE )
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
$ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB,
$ BETA, LDC
IF( REWI )
$ REWIND NTRA
CALL ZGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
$ AA, LDA, BB, LDB, BETA, CC, LDC )
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT = 9994 )
FATAL = .TRUE.
GO TO 120
END IF
*
* See what data changed inside subroutines.
*
ISAME( 1 ) = TRANSA.EQ.TRANAS
ISAME( 2 ) = TRANSB.EQ.TRANBS
ISAME( 3 ) = MS.EQ.M
ISAME( 4 ) = NS.EQ.N
ISAME( 5 ) = KS.EQ.K
ISAME( 6 ) = ALS.EQ.ALPHA
ISAME( 7 ) = LZE( AS, AA, LAA )
ISAME( 8 ) = LDAS.EQ.LDA
ISAME( 9 ) = LZE( BS, BB, LBB )
ISAME( 10 ) = LDBS.EQ.LDB
ISAME( 11 ) = BLS.EQ.BETA
IF( NULL )THEN
ISAME( 12 ) = LZE( CS, CC, LCC )
ELSE
ISAME( 12 ) = LZERES( 'GE', ' ', M, N, CS,
$ CC, LDC )
END IF
ISAME( 13 ) = LDCS.EQ.LDC
*
* 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
40 CONTINUE
IF( .NOT.SAME )THEN
FATAL = .TRUE.
GO TO 120
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
CALL ZMMCH( TRANSA, TRANSB, M, N, K,
$ ALPHA, A, NMAX, B, NMAX, BETA,
$ C, NMAX, CT, G, CC, LDC, EPS,
$ ERR, FATAL, NOUT, .TRUE. )
ERRMAX = MAX( ERRMAX, ERR )
* If got really bad answer, report and
* return.
IF( FATAL )
$ GO TO 120
END IF
*
50 CONTINUE
*
60 CONTINUE
*
70 CONTINUE
*
80 CONTINUE
*
90 CONTINUE
*
100 CONTINUE
*
110 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 130
*
120 CONTINUE
WRITE( NOUT, FMT = 9996 )SNAME
WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K,
$ ALPHA, LDA, LDB, BETA, LDC
*
130 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, ''',''', A1, ''',',
$ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3,
$ ',(', F4.1, ',', F4.1, '), C,', I3, ').' )
9994 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, NALF, ALF, NBET, BET, NMAX,
$ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
*
* Tests ZHEMM and ZSYMM.
*
* Auxiliary routine for test program for Level 3 Blas.
*
* -- Written on 8-February-1989.
* Jack Dongarra, Argonne National Laboratory.
* Iain Duff, AERE Harwell.
* Jeremy Du Croz, Numerical Algorithms Group Ltd.
* Sven Hammarling, Numerical Algorithms Group Ltd.
*
* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) )
DOUBLE PRECISION RZERO
PARAMETER ( RZERO = 0.0D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER NALF, NBET, NIDIM, 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 ), B( NMAX, NMAX ),
$ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
$ C( NMAX, NMAX ), CC( NMAX*NMAX ),
$ CS( NMAX*NMAX ), CT( NMAX )
DOUBLE PRECISION G( NMAX )
INTEGER IDIM( NIDIM )
* .. Local Scalars ..
COMPLEX*16 ALPHA, ALS, BETA, BLS
DOUBLE PRECISION ERR, ERRMAX
INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
$ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
$ NARGS, NC, NS
LOGICAL CONJ, LEFT, NULL, RESET, SAME
CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
CHARACTER*2 ICHS, ICHU
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?