c_dblat2.f

PROGRAM DBLAT2
*
* Test program for the DOUBLE PRECISION Level 2 Blas.
*
* The program must be driven by a short data file. The first 17 records
* of the file are read using list-directed input, the last 16 records
* are read using the format ( A12, L2 ). An annotated example of a data
* file can be obtained by deleting the first 3 characters from the
* following 33 lines:
* 'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
* F LOGICAL FLAG, T TO STOP ON FAILURES.
* T LOGICAL FLAG, T TO TEST ERROR EXITS.
* 2 0 TO TEST COLUMN-MAJOR, 1 TO TEST ROW-MAJOR, 2 TO TEST BOTH
* 16.0 THRESHOLD VALUE OF TEST RATIO
* 6 NUMBER OF VALUES OF N
* 0 1 2 3 5 9 VALUES OF N
* 4 NUMBER OF VALUES OF K
* 0 1 2 4 VALUES OF K
* 4 NUMBER OF VALUES OF INCX AND INCY
* 1 2 -1 -2 VALUES OF INCX AND INCY
* 3 NUMBER OF VALUES OF ALPHA
* 0.0 1.0 0.7 VALUES OF ALPHA
* 3 NUMBER OF VALUES OF BETA
* 0.0 1.0 0.9 VALUES OF BETA
* cblas_dgemv T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dgbmv T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dsymv T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dsbmv T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dspmv T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dtrmv T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dtbmv T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dtpmv T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dtrsv T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dtbsv T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dtpsv T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dger T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dsyr T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dspr T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dsyr2 T PUT F FOR NO TEST. SAME COLUMNS.
* cblas_dspr2 T PUT F FOR NO TEST. SAME COLUMNS.
*
* See:
*
* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
* An extended set of Fortran Basic Linear Algebra Subprograms.
*
* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
* and Computer Science Division, Argonne National Laboratory,
* 9700 South Cass Avenue, Argonne, Illinois 60439, US.
*
* Or
*
* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
*
*
* -- Written on 10-August-1987.
* Richard Hanson, Sandia National Labs.
* Jeremy Du Croz, NAG Central Office.
*
* .. Parameters ..
INTEGER NIN, NOUT
PARAMETER ( NIN =5, NOUT =6 )
INTEGER NSUBS
PARAMETER ( NSUBS =16 )
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO =0.0D0, HALF =0.5D0, ONE =1.0D0 )
INTEGER NMAX, INCMAX
PARAMETER ( NMAX =65, INCMAX =2 )
INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
PARAMETER ( NINMAX =7, NIDMAX =9, NKBMAX =7,
 $ NALMAX =7, NBEMAX =7 )
* .. Local Scalars ..
DOUBLE PRECISION EPS, ERR, THRESH
INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
 $ NTRA, LAYOUT
LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
 $ TSTERR, CORDER, RORDER
CHARACTER*1 TRANS
CHARACTER*12 SNAMET
CHARACTER*32 SNAPS
* .. Local Arrays ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ),
 $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
 $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
 $ XX( NMAX*INCMAX ), Y( NMAX ),
 $ YS( NMAX*INCMAX ), YT( NMAX ),
 $ YY( NMAX*INCMAX ), Z( 2*NMAX )
INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
LOGICAL LTEST( NSUBS )
CHARACTER*12 SNAMES( NSUBS )
* .. External Functions ..
DOUBLE PRECISION DDIFF
LOGICAL LDE
EXTERNAL DDIFF, LDE
* .. External Subroutines ..
EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHK6,
 $ CD2CHKE, DMVCH
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL OK
CHARACTER*12 SRNAMT
* .. Common blocks ..
COMMON/INFOC/INFOT, NOUTC, OK
COMMON/SRNAMC/SRNAMT
* .. Data statements ..
DATA SNAMES/'cblas_dgemv ', 'cblas_dgbmv ',
 $ 'cblas_dsymv ','cblas_dsbmv ','cblas_dspmv ',
 $ 'cblas_dtrmv ','cblas_dtbmv ','cblas_dtpmv ',
 $ 'cblas_dtrsv ','cblas_dtbsv ','cblas_dtpsv ',
 $ 'cblas_dger ','cblas_dsyr ','cblas_dspr ',
 $ 'cblas_dsyr2 ','cblas_dspr2 '/
* .. Executable Statements ..
*
 NOUTC = NOUT
*
* Read name and unit number for snapshot output file and open file.
*
READ( NIN, FMT =* )SNAPS
READ( NIN, FMT =* )NTRA
 TRACE = NTRA.GE.0
IF( TRACE )THEN
OPEN( NTRA, FILE = SNAPS )
END IF
* Read the flag that directs rewinding of the snapshot file.
READ( NIN, FMT =* )REWI
 REWI = REWI.AND.TRACE
* Read the flag that directs stopping on any failure.
READ( NIN, FMT =* )SFATAL
* Read the flag that indicates whether error exits are to be tested.
READ( NIN, FMT =* )TSTERR
* Read the flag that indicates whether row-major data layout to be tested.
READ( NIN, FMT =* )LAYOUT
* Read the threshold value of the test ratio
READ( NIN, FMT =* )THRESH
*
* Read and check the parameter values for the tests.
*
* Values of N
READ( NIN, FMT =* )NIDIM
IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
WRITE( NOUT, FMT =9997 )'N', NIDMAX
GO TO230
END IF
READ( NIN, FMT =* )( IDIM( I ), I =1, NIDIM )
DO10 I =1, NIDIM
IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
WRITE( NOUT, FMT =9996 )NMAX
GO TO230
END IF
10CONTINUE
* Values of K
READ( NIN, FMT =* )NKB
IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
WRITE( NOUT, FMT =9997 )'K', NKBMAX
GO TO230
END IF
READ( NIN, FMT =* )( KB( I ), I =1, NKB )
DO20 I =1, NKB
IF( KB( I ).LT.0 )THEN
WRITE( NOUT, FMT =9995 )
GO TO230
END IF
20CONTINUE
* Values of INCX and INCY
READ( NIN, FMT =* )NINC
IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN
WRITE( NOUT, FMT =9997 )'INCX AND INCY', NINMAX
GO TO230
END IF
READ( NIN, FMT =* )( INC( I ), I =1, NINC )
DO30 I =1, NINC
IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
WRITE( NOUT, FMT =9994 )INCMAX
GO TO230
END IF
30CONTINUE
* Values of ALPHA
READ( NIN, FMT =* )NALF
IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
WRITE( NOUT, FMT =9997 )'ALPHA', NALMAX
GO TO230
END IF
READ( NIN, FMT =* )( ALF( I ), I =1, NALF )
* Values of BETA
READ( NIN, FMT =* )NBET
IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
WRITE( NOUT, FMT =9997 )'BETA', NBEMAX
GO TO230
END IF
READ( NIN, FMT =* )( BET( I ), I =1, NBET )
*
* Report values of parameters.
*
WRITE( NOUT, FMT =9993 )
WRITE( NOUT, FMT =9992 )( IDIM( I ), I =1, NIDIM )
WRITE( NOUT, FMT =9991 )( KB( I ), I =1, NKB )
WRITE( NOUT, FMT =9990 )( INC( I ), I =1, NINC )
WRITE( NOUT, FMT =9989 )( ALF( I ), I =1, NALF )
WRITE( NOUT, FMT =9988 )( BET( I ), I =1, NBET )
IF( .NOT.TSTERR )THEN
WRITE( NOUT, FMT =* )
WRITE( NOUT, FMT =9980 )
END IF
WRITE( NOUT, FMT =* )
WRITE( NOUT, FMT =9999 )THRESH
WRITE( NOUT, FMT =* )

 RORDER =.FALSE.
 CORDER =.FALSE.
IF (LAYOUT.EQ.2) THEN
 RORDER =.TRUE.
 CORDER =.TRUE.
WRITE( *, FMT =10002 )
ELSEIF (LAYOUT.EQ.1) THEN
 RORDER =.TRUE.
WRITE( *, FMT =10001 )
ELSEIF (LAYOUT.EQ.0) THEN
 CORDER =.TRUE.
WRITE( *, FMT =10000 )
END IF
WRITE( *, FMT =* )
*
* Read names of subroutines and flags which indicate
* whether they are to be tested.
*
DO40 I =1, NSUBS
 LTEST( I ) =.FALSE.
40CONTINUE
50READ( NIN, FMT =9984, END =80 )SNAMET, LTESTT
DO60 I =1, NSUBS
IF( SNAMET.EQ.SNAMES( I ) )
 $ GO TO70
60CONTINUE
WRITE( NOUT, FMT =9986 )SNAMET
STOP
70 LTEST( I ) = LTESTT
GO TO50
*
80CONTINUE
CLOSE ( NIN )
*
* Compute EPS (the machine precision).
*
 EPS = ONE
90CONTINUE
IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO )
 $ GO TO100
 EPS = HALF*EPS
GO TO90
100CONTINUE
 EPS = EPS + EPS
WRITE( NOUT, FMT =9998 )EPS
*
* Check the reliability of DMVCH using exact data.
*
 N =MIN( 32, NMAX )
DO120 J =1, N
DO110 I =1, N
 A( I, J ) =MAX( I - J +1, 0 )
110CONTINUE
 X( J ) = J
 Y( J ) = ZERO
120CONTINUE
DO130 J =1, N
 YY( J ) = J*( ( J +1 )*J )/2- ( ( J +1 )*J*( J -1 ) )/3
130CONTINUE
* YY holds the exact result. On exit from DMVCH YT holds
* the result computed by DMVCH.
 TRANS ='N'
CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
 SAME = LDE( YY, YT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT =9985 )TRANS, SAME, ERR
STOP
END IF
 TRANS ='T'
CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
 $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
 SAME = LDE( YY, YT, N )
IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
WRITE( NOUT, FMT =9985 )TRANS, SAME, ERR
STOP
END IF
*
* Test each subroutine in turn.
*
DO210 ISNUM =1, NSUBS
WRITE( NOUT, FMT =* )
IF( .NOT.LTEST( ISNUM ) )THEN
* Subprogram is not to be tested.
WRITE( NOUT, FMT =9983 )SNAMES( ISNUM )
ELSE
 SRNAMT = SNAMES( ISNUM )
* Test error exits.
IF( TSTERR )THEN
CALL CD2CHKE( SNAMES( ISNUM ) )
WRITE( NOUT, FMT =* )
END IF
* Test computations.
 INFOT =0
 OK =.TRUE.
 FATAL =.FALSE.
GO TO ( 140, 140, 150, 150, 150, 160, 160,
 $ 160, 160, 160, 160, 170, 180, 180,
 $ 190, 190 )ISNUM
* Test DGEMV, 01, and DGBMV, 02.
140IF (CORDER) THEN
CALL DCHK1( SNAMES( ISNUM ), 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, 0 )
END IF
IF (RORDER) THEN
CALL DCHK1( SNAMES( ISNUM ), 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, 1 )
END IF
GO TO200
* Test DSYMV, 03, DSBMV, 04, and DSPMV, 05.
150IF (CORDER) THEN
CALL DCHK2( SNAMES( ISNUM ), 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, 0 )
END IF
IF (RORDER) THEN
CALL DCHK2( SNAMES( ISNUM ), 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, 1 )
END IF
GO TO200
* Test DTRMV, 06, DTBMV, 07, DTPMV, 08,
* DTRSV, 09, DTBSV, 10, and DTPSV, 11.
160IF (CORDER) THEN
CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
 $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z,
 $ 0 )
END IF
IF (RORDER) THEN
CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
 $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z,
 $ 1 )
END IF
GO TO200
* Test DGER, 12.
170IF (CORDER) THEN
CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 $ YT, G, Z, 0 )
END IF
IF (RORDER) THEN
CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 $ YT, G, Z, 1 )
END IF
GO TO200
* Test DSYR, 13, and DSPR, 14.
180IF (CORDER) THEN
CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 $ YT, G, Z, 0 )
END IF
IF (RORDER) THEN
CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 $ YT, G, Z, 1 )
END IF
GO TO200
* Test DSYR2, 15, and DSPR2, 16.
190IF (CORDER) THEN
CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 $ YT, G, Z, 0 )
END IF
IF (RORDER) THEN
CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
 $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
 $ YT, G, Z, 1 )
END IF
*
200IF( FATAL.AND.SFATAL )
 $ GO TO220
END IF
210CONTINUE
WRITE( NOUT, FMT =9982 )
GO TO240
*
220CONTINUE
WRITE( NOUT, FMT =9981 )
GO TO240
*
230CONTINUE
WRITE( NOUT, FMT =9987 )
*
240CONTINUE
IF( TRACE )
 $ CLOSE ( NTRA )
CLOSE ( NOUT )
STOP
*
10002FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
10001FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' )
10000FORMAT( ' COLUMN-MAJOR DATA LAYOUT IS TESTED' )
9999FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
 $ 'S THAN', F8.2 )
9998FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
9997FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
 $ 'THAN ', I2 )
9996FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
9995FORMAT( ' VALUE OF K IS LESS THAN 0' )
9994FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
 $ I2 )
9993FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 2 BLAS', //' THE F',
 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
9992FORMAT( ' FOR N ', 9I6 )
9991FORMAT( ' FOR K ', 7I6 )
9990FORMAT( ' FOR INCX AND INCY ', 7I6 )
9989FORMAT( ' FOR ALPHA ', 7F6.1 )
9988FORMAT( ' FOR BETA ', 7F6.1 )
9987FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
 $ /' ******* TESTS ABANDONED *******' )
9986FORMAT( ' SUBPROGRAM NAME ',A12, ' NOT RECOGNIZED', /' ******* T',
 $ 'ESTS ABANDONED *******' )
9985FORMAT( ' ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
 $ 'ATED WRONGLY.', /' DMVCH WAS CALLED WITH TRANS = ', A1,
 $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /
 $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
 $ , /' ******* TESTS ABANDONED *******' )
9984FORMAT(A12, L2 )
9983FORMAT( 1X,A12, ' WAS NOT TESTED' )
9982FORMAT( /' END OF TESTS' )
9981FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
9980FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
*
* End of DBLAT2.
*
 END
SUBROUTINEDCHK1( 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, IORDER )
*
* Tests DGEMV and DGBMV.
*
* 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 ..
DOUBLE PRECISION ZERO, HALF
PARAMETER ( ZERO =0.0D0, HALF =0.5D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
 $ NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
CHARACTER*12 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
 $ X( NMAX ), XS( NMAX*INCMAX ),
 $ XX( NMAX*INCMAX ), Y( NMAX ),
 $ YS( NMAX*INCMAX ), YT( NMAX ),
 $ YY( NMAX*INCMAX )
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
 $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
 $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
 $ NL, NS
LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
CHARACTER*1 TRANS, TRANSS
CHARACTER*14 CTRANS
CHARACTER*3 ICH
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL CDGBMV, CDGEMV, DMAKE, DMVCH
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL OK
* .. Common blocks ..
COMMON/INFOC/INFOT, NOUTC, OK
* .. Data statements ..
DATA ICH/'NTC'/
* .. Executable Statements ..
 FULL = SNAME( 9: 9 ).EQ.'e'
 BANDED = SNAME( 9: 9 ).EQ.'b'
* Define the number of arguments.
IF( FULL )THEN
 NARGS =11
ELSEIF( BANDED )THEN
 NARGS =13
END IF
*
 NC =0
 RESET =.TRUE.
 ERRMAX = ZERO
*
DO120IN=1, NIDIM
 N = IDIM( IN )
 ND = N/2+1
*
DO110 IM =1, 2
IF( IM.EQ.1 )
 $ M =MAX( N - ND, 0 )
IF( IM.EQ.2 )
 $ M =MIN( N + ND, NMAX )
*
IF( BANDED )THEN
 NK = NKB
ELSE
 NK =1
END IF
DO100 IKU =1, NK
IF( BANDED )THEN
 KU = KB( IKU )
 KL =MAX( KU -1, 0 )
ELSE
 KU = N -1
 KL = M -1
END IF
* Set LDA to 1 more than minimum value if room.
IF( BANDED )THEN
 LDA = KL + KU +1
ELSE
 LDA = M
END IF
IF( LDA.LT.NMAX )
 $ LDA = LDA +1
* Skip tests if not enough room.
IF( LDA.GT.NMAX )
 $ GO TO100
 LAA = LDA*N
 NULL = N.LE.0.OR.M.LE.0
*
* Generate the matrix A.
*
 TRANSL = ZERO
CALL DMAKE( SNAME( 8: 9 ), '', '', M, N, A, NMAX, AA,
 $ LDA, KL, KU, RESET, TRANSL )
*
DO90 IC =1, 3
 TRANS = ICH( IC: IC )
IF (TRANS.EQ.'N')THEN
 CTRANS =' CblasNoTrans'
ELSEIF (TRANS.EQ.'T')THEN
 CTRANS =' CblasTrans'
ELSE
 CTRANS ='CblasConjTrans'
END IF
 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
*
IF( TRAN )THEN
 ML = N
 NL = M
ELSE
 ML = M
 NL = N
END IF
*
DO80 IX =1, NINC
 INCX = INC( IX )
 LX =ABS( INCX )*NL
*
* Generate the vector X.
*
 TRANSL = HALF
CALL DMAKE( 'ge', '', '', 1, NL, X, 1, XX,
 $ ABS( INCX ), 0, NL -1, RESET, TRANSL )
IF( NL.GT.1 )THEN
 X( NL/2 ) = ZERO
 XX( 1+ABS( INCX )*( NL/2-1 ) ) = ZERO
END IF
*
DO70 IY =1, NINC
 INCY = INC( IY )
 LY =ABS( INCY )*ML
*
DO60 IA =1, NALF
 ALPHA = ALF( IA )
*
DO50 IB =1, NBET
 BETA = BET( IB )
*
* Generate the vector Y.
*
 TRANSL = ZERO
CALL DMAKE( 'ge', '', '', 1, ML, Y, 1,
 $ YY, ABS( INCY ), 0, ML -1,
 $ RESET, TRANSL )
*
 NC = NC +1
*
* Save every datum before calling the
* subroutine.
*
 TRANSS = TRANS
 MS = M
 NS = N
 KLS = KL
 KUS = KU
 ALS = ALPHA
DO10 I =1, LAA
 AS( I ) = AA( I )
10CONTINUE
 LDAS = LDA
DO20 I =1, LX
 XS( I ) = XX( I )
20CONTINUE
 INCXS = INCX
 BLS = BETA
DO30 I =1, LY
 YS( I ) = YY( I )
30CONTINUE
 INCYS = INCY
*
* Call the subroutine.
*
IF( FULL )THEN
IF( TRACE )
 $ WRITE( NTRA, FMT =9994 )NC, SNAME,
 $ CTRANS, M, N, ALPHA, LDA, INCX,
 $ BETA, INCY
IF( REWI )
 $ REWIND NTRA
CALL CDGEMV( IORDER, TRANS, M, N,
 $ ALPHA, AA, LDA, XX, INCX,
 $ BETA, YY, INCY )
ELSEIF( BANDED )THEN
IF( TRACE )
 $ WRITE( NTRA, FMT =9995 )NC, SNAME,
 $ CTRANS, M, N, KL, KU, ALPHA, LDA,
 $ INCX, BETA, INCY
IF( REWI )
 $ REWIND NTRA
CALL CDGBMV( IORDER, TRANS, M, N, KL,
 $ KU, ALPHA, AA, LDA, XX,
 $ INCX, BETA, YY, INCY )
END IF
*
* Check if error-exit was taken incorrectly.
*
IF( .NOT.OK )THEN
WRITE( NOUT, FMT =9993 )
 FATAL =.TRUE.
GO TO130
END IF
*
* See what data changed inside subroutines.
*
 ISAME( 1 ) = TRANS.EQ.TRANSS
 ISAME( 2 ) = MS.EQ.M
 ISAME( 3 ) = NS.EQ.N
IF( FULL )THEN
 ISAME( 4 ) = ALS.EQ.ALPHA
 ISAME( 5 ) = LDE( AS, AA, LAA )
 ISAME( 6 ) = LDAS.EQ.LDA
 ISAME( 7 ) = LDE( XS, XX, LX )
 ISAME( 8 ) = INCXS.EQ.INCX
 ISAME( 9 ) = BLS.EQ.BETA
IF( NULL )THEN
 ISAME( 10 ) = LDE( YS, YY, LY )
ELSE
 ISAME( 10 ) = LDERES( 'ge', '', 1,
 $ ML, YS, YY,
 $ ABS( INCY ) )
END IF
 ISAME( 11 ) = INCYS.EQ.INCY
ELSEIF( BANDED )THEN
 ISAME( 4 ) = KLS.EQ.KL
 ISAME( 5 ) = KUS.EQ.KU
 ISAME( 6 ) = ALS.EQ.ALPHA
 ISAME( 7 ) = LDE( AS, AA, LAA )
 ISAME( 8 ) = LDAS.EQ.LDA
 ISAME( 9 ) = LDE( XS, XX, LX )
 ISAME( 10 ) = INCXS.EQ.INCX
 ISAME( 11 ) = BLS.EQ.BETA
IF( NULL )THEN
 ISAME( 12 ) = LDE( YS, YY, LY )
ELSE
 ISAME( 12 ) = LDERES( 'ge', '', 1,
 $ ML, YS, YY,
 $ ABS( INCY ) )
END IF
 ISAME( 13 ) = INCYS.EQ.INCY
END IF
*
* If data was incorrectly changed, report
* and return.
*
 SAME =.TRUE.
DO40 I =1, NARGS
 SAME = SAME.AND.ISAME( I )
IF( .NOT.ISAME( I ) )
 $ WRITE( NOUT, FMT =9998 )I
40CONTINUE
IF( .NOT.SAME )THEN
 FATAL =.TRUE.
GO TO130
END IF
*
IF( .NOT.NULL )THEN
*
* Check the result.
*
CALL DMVCH( 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 TO130
ELSE
* Avoid repeating tests with M.le.0 or
* N.le.0.
GO TO110
END IF
*
50CONTINUE
*
60CONTINUE
*
70CONTINUE
*
80CONTINUE
*
90CONTINUE
*
100CONTINUE
*
110CONTINUE
*
120CONTINUE
*
* Report result.
*
IF( ERRMAX.LT.THRESH )THEN
IF ( IORDER.EQ.0) WRITE( NOUT, FMT =10000 )SNAME, NC
IF ( IORDER.EQ.1) WRITE( NOUT, FMT =10001 )SNAME, NC
ELSE
IF ( IORDER.EQ.0) WRITE( NOUT, FMT =10002 )SNAME, NC, ERRMAX
IF ( IORDER.EQ.1) WRITE( NOUT, FMT =10003 )SNAME, NC, ERRMAX
END IF
GO TO140
*
130CONTINUE
WRITE( NOUT, FMT =9996 )SNAME
IF( FULL )THEN
WRITE( NOUT, FMT =9994 )NC, SNAME, CTRANS, M, N, ALPHA, LDA,
 $ INCX, BETA, INCY
ELSEIF( BANDED )THEN
WRITE( NOUT, FMT =9995 )NC, SNAME, CTRANS, M, N, KL, KU,
 $ ALPHA, LDA, INCX, BETA, INCY
END IF
*
140CONTINUE
RETURN
*
10003FORMAT( '', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
10002FORMAT( '', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
 $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
 $ 'RATIO ', F8.2, ' - SUSPECT *******' )
10001FORMAT( '', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
 $ ' (', I6, ' CALL', 'S)' )
10000FORMAT( '', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
 $ ' (', I6, ' CALL', 'S)' )
9998FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
 $ 'ANGED INCORRECTLY *******' )
9997FORMAT( '',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
 $ ' - SUSPECT *******' )
9996FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
9995FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 4( I3, ',' ), F4.1,
 $ ', A,', I3, ',',/10x,'X,', I2, ',', F4.1, ', Y,',
 $ I2, ') .' )
9994FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), F4.1,
 $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
 $ ') .' )
9993FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
 $ '******' )
*
* End of DCHK1.
*
END
SUBROUTINEDCHK2( 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, IORDER )
*
* Tests DSYMV, DSBMV and DSPMV.
*
* 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 ..
DOUBLE PRECISION ZERO, HALF
PARAMETER ( ZERO =0.0D0, HALF =0.5D0 )
* .. Scalar Arguments ..
DOUBLE PRECISION EPS, THRESH
INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
 $ NOUT, NTRA, IORDER
LOGICAL FATAL, REWI, TRACE
CHARACTER*12 SNAME
* .. Array Arguments ..
DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
 $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
 $ X( NMAX ), XS( NMAX*INCMAX ),
 $ XX( NMAX*INCMAX ), Y( NMAX ),
 $ YS( NMAX*INCMAX ), YT( NMAX ),
 $ YY( NMAX*INCMAX )
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
* .. Local Scalars ..
DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
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*14 CUPLO
CHARACTER*2 ICH
* .. Local Arrays ..
LOGICAL ISAME( 13 )
* .. External Functions ..
LOGICAL LDE, LDERES
EXTERNAL LDE, LDERES
* .. External Subroutines ..
EXTERNAL DMAKE, DMVCH, CDSBMV, CDSPMV, CDSYMV
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* .. Scalars in Common ..
INTEGER INFOT, NOUTC
LOGICAL OK
* .. Common blocks ..
COMMON/INFOC/INFOT, NOUTC, OK
* .. Data statements ..
DATA ICH/'UL'/
* .. Executable Statements ..
 FULL = SNAME( 9: 9 ).EQ.'y'
 BANDED = SNAME( 9: 9 ).EQ.'b'
 PACKED = SNAME( 9: 9 ).EQ.'p'
* Define the number of arguments.
IF( FULL )THEN
 NARGS =10
ELSEIF( BANDED )THEN
 NARGS =11
ELSEIF( PACKED )THEN
 NARGS =9
END IF
*
 NC =0
 RESET =.TRUE.
 ERRMAX = ZERO
*
DO110IN=1, NIDIM
 N = IDIM( IN )
*
IF( BANDED )THEN
 NK = NKB
ELSE
 NK =1
END IF
DO100 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 TO100
IF( PACKED )THEN
 LAA = ( N*( N +1 ) )/2
ELSE
 LAA = LDA*N
END IF
 NULL = N.LE.0
*
DO90 IC =1, 2
 UPLO = ICH( IC: IC )
IF (UPLO.EQ.'U')THEN
 CUPLO =' CblasUpper'
ELSE
 CUPLO =' CblasLower'
END IF
*
* Generate the matrix A.
*
 TRANSL = ZERO
CALL DMAKE( SNAME( 8: 9 ), UPLO, '', N, N, A, NMAX, AA,
 $ LDA, K, K, RESET, TRANSL )
*
DO80 IX =1, NINC
 INCX = INC( IX )
 LX =ABS( INCX )*N
*
* Generate the vector X.
*
 TRANSL = HALF
CALL DMAKE( '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
*
DO70 IY =1, NINC
 INCY = INC( IY )
 LY =ABS( INCY )*N
*
DO60 IA =1, NALF
 ALPHA = ALF( IA )
*
DO50 IB =1, NBET
 BETA = BET( IB )
*
* Generate the vector Y.
*
 TRANSL = ZERO
CALL DMAKE( '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
DO10 I =1, LAA
 AS( I ) = AA( I )
10CONTINUE
 LDAS = LDA
DO20 I =1, LX
 XS( I ) = XX( I )
20CONTINUE
 INCXS = INCX
 BLS = BETA
DO30 I =1, LY
 YS( I ) = YY( I )
30CONTINUE
 INCYS = INCY
*
* Call the subroutine.
*
IF( FULL )THEN
IF( TRACE )
 $ WRITE( NTRA, FMT =9993 )NC, SNAME,
 $ CUPLO, N, ALPHA, LDA, INCX, BETA, INCY
IF( REWI )
 $ REWIND NTRA
CALL CDSYMV( IORDER, UPLO, N, ALPHA, AA,
 $ LDA, XX, INCX, BETA, YY, INCY )
ELSEIF( BANDED )THEN
IF( TRACE )
 $ WRITE( NTRA, FMT =9994 )NC, SNAME,