Hans Johnson
9dafba6d41
This is mostly a long term maintenance improvement.
Many coding styles require elimination of trailing whitespace, and
many editors and source code management configurations automatically
gobble up whitespace. When these tools gobble up whitespace, it
complicates reviewing the meaningful code changes.
By removing whitespace on one patch, it makes future
code reviews much easier.
=SCRIPT====================================================================
if which tempfile &>/dev/null; then
TEMPMAKER=tempfile
elif which mktemp &>/dev/null; then
TEMPMAKER=mktemp
else
echo "Cannot find tempfile program." 2>&1
exit 1
fi
MYTEMP=$($TEMPMAKER)
trap 'rm -f $MYTEMP' SIGINT SIGTERM
stripit() {
echo "stripping $1"
sed 's/[ \t]*$//' "$1" > $MYTEMP
cp $MYTEMP "$1"
}
if [ $# -gt 0 ]; then
while [ "$1" != "" ]; do
stripit $1
shift
done
else
while read -t 2; do
stripit $REPLY
done
fi
rm $MYTEMP
=================================================
2933 lines
102 KiB
FortranFixed
2933 lines
102 KiB
FortranFixed
PROGRAM CBLAT2
|
|
*
|
|
* Test program for the COMPLEX 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 17 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 34 lines:
|
|
* 'CBLAT2.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,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
|
|
* 3 NUMBER OF VALUES OF BETA
|
|
* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
|
|
* cblas_cgemv T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_cgbmv T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_chemv T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_chbmv T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_chpmv T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_ctrmv T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_ctbmv T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_ctpmv T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_ctrsv T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_ctbsv T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_ctpsv T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_cgerc T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_cgeru T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_cher T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_chpr T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_cher2 T PUT F FOR NO TEST. SAME COLUMNS.
|
|
* cblas_chpr2 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 = 17 )
|
|
COMPLEX ZERO, ONE
|
|
PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
|
|
REAL RZERO, RHALF, RONE
|
|
PARAMETER ( RZERO = 0.0, RHALF = 0.5, RONE = 1.0 )
|
|
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 ..
|
|
REAL 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 ..
|
|
COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ),
|
|
$ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
|
|
$ X( NMAX ), XS( NMAX*INCMAX ),
|
|
$ XX( NMAX*INCMAX ), Y( NMAX ),
|
|
$ YS( NMAX*INCMAX ), YT( NMAX ),
|
|
$ YY( NMAX*INCMAX ), Z( 2*NMAX )
|
|
REAL G( NMAX )
|
|
INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
|
|
LOGICAL LTEST( NSUBS )
|
|
CHARACTER*12 SNAMES( NSUBS )
|
|
* .. External Functions ..
|
|
REAL SDIFF
|
|
LOGICAL LCE
|
|
EXTERNAL SDIFF, LCE
|
|
* .. External Subroutines ..
|
|
EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6,
|
|
$ CC2CHKE, CMVCH
|
|
* .. 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_cgemv ', 'cblas_cgbmv ',
|
|
$ 'cblas_chemv ','cblas_chbmv ','cblas_chpmv ',
|
|
$ 'cblas_ctrmv ','cblas_ctbmv ','cblas_ctpmv ',
|
|
$ 'cblas_ctrsv ','cblas_ctbsv ','cblas_ctpsv ',
|
|
$ 'cblas_cgerc ','cblas_cgeru ','cblas_cher ',
|
|
$ 'cblas_chpr ','cblas_cher2 ','cblas_chpr2 '/
|
|
* .. Executable Statements ..
|
|
*
|
|
NOUTC = NOUT
|
|
*
|
|
* Read name and unit number for summary 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 TO 230
|
|
END IF
|
|
READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
|
|
DO 10 I = 1, NIDIM
|
|
IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
|
|
WRITE( NOUT, FMT = 9996 )NMAX
|
|
GO TO 230
|
|
END IF
|
|
10 CONTINUE
|
|
* Values of K
|
|
READ( NIN, FMT = * )NKB
|
|
IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
|
|
WRITE( NOUT, FMT = 9997 )'K', NKBMAX
|
|
GO TO 230
|
|
END IF
|
|
READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
|
|
DO 20 I = 1, NKB
|
|
IF( KB( I ).LT.0 )THEN
|
|
WRITE( NOUT, FMT = 9995 )
|
|
GO TO 230
|
|
END IF
|
|
20 CONTINUE
|
|
* 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 TO 230
|
|
END IF
|
|
READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
|
|
DO 30 I = 1, NINC
|
|
IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
|
|
WRITE( NOUT, FMT = 9994 )INCMAX
|
|
GO TO 230
|
|
END IF
|
|
30 CONTINUE
|
|
* Values of ALPHA
|
|
READ( NIN, FMT = * )NALF
|
|
IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
|
|
WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
|
|
GO TO 230
|
|
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 TO 230
|
|
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 )
|
|
ELSE IF (LAYOUT.EQ.1) THEN
|
|
RORDER = .TRUE.
|
|
WRITE( *, FMT = 10001 )
|
|
ELSE IF (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.
|
|
*
|
|
DO 40 I = 1, NSUBS
|
|
LTEST( I ) = .FALSE.
|
|
40 CONTINUE
|
|
50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
|
|
DO 60 I = 1, NSUBS
|
|
IF( SNAMET.EQ.SNAMES( I ) )
|
|
$ GO TO 70
|
|
60 CONTINUE
|
|
WRITE( NOUT, FMT = 9986 )SNAMET
|
|
STOP
|
|
70 LTEST( I ) = LTESTT
|
|
GO TO 50
|
|
*
|
|
80 CONTINUE
|
|
CLOSE ( NIN )
|
|
*
|
|
* Compute EPS (the machine precision).
|
|
*
|
|
EPS = RONE
|
|
90 CONTINUE
|
|
IF( SDIFF( RONE + EPS, RONE ).EQ.RZERO )
|
|
$ GO TO 100
|
|
EPS = RHALF*EPS
|
|
GO TO 90
|
|
100 CONTINUE
|
|
EPS = EPS + EPS
|
|
WRITE( NOUT, FMT = 9998 )EPS
|
|
*
|
|
* Check the reliability of CMVCH using exact data.
|
|
*
|
|
N = MIN( 32, NMAX )
|
|
DO 120 J = 1, N
|
|
DO 110 I = 1, N
|
|
A( I, J ) = MAX( I - J + 1, 0 )
|
|
110 CONTINUE
|
|
X( J ) = J
|
|
Y( J ) = ZERO
|
|
120 CONTINUE
|
|
DO 130 J = 1, N
|
|
YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
|
|
130 CONTINUE
|
|
* YY holds the exact result. On exit from CMVCH YT holds
|
|
* the result computed by CMVCH.
|
|
TRANS = 'N'
|
|
CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
|
|
$ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
|
|
SAME = LCE( YY, YT, N )
|
|
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
|
|
WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
|
|
STOP
|
|
END IF
|
|
TRANS = 'T'
|
|
CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
|
|
$ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
|
|
SAME = LCE( YY, YT, N )
|
|
IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN
|
|
WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
|
|
STOP
|
|
END IF
|
|
*
|
|
* Test each subroutine in turn.
|
|
*
|
|
DO 210 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 CC2CHKE( 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, 170, 180,
|
|
$ 180, 190, 190 )ISNUM
|
|
* Test CGEMV, 01, and CGBMV, 02.
|
|
140 IF (CORDER) THEN
|
|
CALL CCHK1( 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 CCHK1( 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 TO 200
|
|
* Test CHEMV, 03, CHBMV, 04, and CHPMV, 05.
|
|
150 IF (CORDER) THEN
|
|
CALL CCHK2( 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 CCHK2( 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 TO 200
|
|
* Test CTRMV, 06, CTBMV, 07, CTPMV, 08,
|
|
* CTRSV, 09, CTBSV, 10, and CTPSV, 11.
|
|
160 IF (CORDER) THEN
|
|
CALL CCHK3( 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 CCHK3( 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 TO 200
|
|
* Test CGERC, 12, CGERU, 13.
|
|
170 IF (CORDER) THEN
|
|
CALL CCHK4( 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 CCHK4( 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 TO 200
|
|
* Test CHER, 14, and CHPR, 15.
|
|
180 IF (CORDER) THEN
|
|
CALL CCHK5( 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 CCHK5( 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 TO 200
|
|
* Test CHER2, 16, and CHPR2, 17.
|
|
190 IF (CORDER) THEN
|
|
CALL CCHK6( 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 CCHK6( 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
|
|
*
|
|
200 IF( FATAL.AND.SFATAL )
|
|
$ GO TO 220
|
|
END IF
|
|
210 CONTINUE
|
|
WRITE( NOUT, FMT = 9982 )
|
|
GO TO 240
|
|
*
|
|
220 CONTINUE
|
|
WRITE( NOUT, FMT = 9981 )
|
|
GO TO 240
|
|
*
|
|
230 CONTINUE
|
|
WRITE( NOUT, FMT = 9987 )
|
|
*
|
|
240 CONTINUE
|
|
IF( TRACE )
|
|
$ CLOSE ( NTRA )
|
|
CLOSE ( NOUT )
|
|
STOP
|
|
*
|
|
10002 FORMAT( ' COLUMN-MAJOR AND ROW-MAJOR DATA LAYOUTS ARE TESTED' )
|
|
10001 FORMAT( ' ROW-MAJOR DATA LAYOUT IS TESTED' )
|
|
10000 FORMAT( ' COLUMN-MAJOR DATA LAYOUT IS TESTED' )
|
|
9999 FORMAT(' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
|
|
$ 'S THAN', F8.2 )
|
|
9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 )
|
|
9997 FORMAT(' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
|
|
$ 'THAN ', I2 )
|
|
9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
|
|
9995 FORMAT( ' VALUE OF K IS LESS THAN 0' )
|
|
9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
|
|
$ I2 )
|
|
9993 FORMAT(' TESTS OF THE COMPLEX LEVEL 2 BLAS', //' THE F',
|
|
$ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
|
|
9992 FORMAT( ' FOR N ', 9I6 )
|
|
9991 FORMAT( ' FOR K ', 7I6 )
|
|
9990 FORMAT( ' FOR INCX AND INCY ', 7I6 )
|
|
9989 FORMAT( ' FOR ALPHA ',
|
|
$ 7('(', F4.1, ',', F4.1, ') ', : ) )
|
|
9988 FORMAT( ' FOR BETA ',
|
|
$ 7('(', F4.1, ',', F4.1, ') ', : ) )
|
|
9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
|
|
$ /' ******* TESTS ABANDONED *******' )
|
|
9986 FORMAT(' SUBPROGRAM NAME ',A12, ' NOT RECOGNIZED', /' ******* T',
|
|
$ 'ESTS ABANDONED *******' )
|
|
9985 FORMAT(' ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
|
|
$ 'ATED WRONGLY.', /' CMVCH 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 *******' )
|
|
9984 FORMAT(A12, L2 )
|
|
9983 FORMAT( 1X,A12, ' WAS NOT TESTED' )
|
|
9982 FORMAT( /' END OF TESTS' )
|
|
9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
|
|
9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
|
|
*
|
|
* End of CBLAT2.
|
|
*
|
|
END
|
|
SUBROUTINE CCHK1( 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 CGEMV and CGBMV.
|
|
*
|
|
* 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 ZERO, HALF
|
|
PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) )
|
|
REAL RZERO
|
|
PARAMETER ( RZERO = 0.0 )
|
|
* .. Scalar Arguments ..
|
|
REAL EPS, THRESH
|
|
INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
|
|
$ NOUT, NTRA, IORDER
|
|
LOGICAL FATAL, REWI, TRACE
|
|
CHARACTER*12 SNAME
|
|
* .. Array Arguments ..
|
|
COMPLEX 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 )
|
|
REAL G( NMAX )
|
|
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
|
|
* .. Local Scalars ..
|
|
COMPLEX ALPHA, ALS, BETA, BLS, TRANSL
|
|
REAL ERR, ERRMAX
|
|
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 LCE, LCERES
|
|
EXTERNAL LCE, LCERES
|
|
* .. External Subroutines ..
|
|
EXTERNAL CCGBMV, CCGEMV, CMAKE, CMVCH
|
|
* .. 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
|
|
ELSE IF( BANDED )THEN
|
|
NARGS = 13
|
|
END IF
|
|
*
|
|
NC = 0
|
|
RESET = .TRUE.
|
|
ERRMAX = RZERO
|
|
*
|
|
DO 120 IN = 1, NIDIM
|
|
N = IDIM( IN )
|
|
ND = N/2 + 1
|
|
*
|
|
DO 110 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
|
|
DO 100 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 TO 100
|
|
LAA = LDA*N
|
|
NULL = N.LE.0.OR.M.LE.0
|
|
*
|
|
* Generate the matrix A.
|
|
*
|
|
TRANSL = ZERO
|
|
CALL CMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, AA,
|
|
$ LDA, KL, KU, RESET, TRANSL )
|
|
*
|
|
DO 90 IC = 1, 3
|
|
TRANS = ICH( IC: IC )
|
|
IF (TRANS.EQ.'N')THEN
|
|
CTRANS = ' CblasNoTrans'
|
|
ELSE IF (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
|
|
*
|
|
DO 80 IX = 1, NINC
|
|
INCX = INC( IX )
|
|
LX = ABS( INCX )*NL
|
|
*
|
|
* Generate the vector X.
|
|
*
|
|
TRANSL = HALF
|
|
CALL CMAKE( '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
|
|
*
|
|
DO 70 IY = 1, NINC
|
|
INCY = INC( IY )
|
|
LY = ABS( INCY )*ML
|
|
*
|
|
DO 60 IA = 1, NALF
|
|
ALPHA = ALF( IA )
|
|
*
|
|
DO 50 IB = 1, NBET
|
|
BETA = BET( IB )
|
|
*
|
|
* Generate the vector Y.
|
|
*
|
|
TRANSL = ZERO
|
|
CALL CMAKE( '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
|
|
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 = 9994 )NC, SNAME,
|
|
$ CTRANS, M, N, ALPHA, LDA, INCX, BETA,
|
|
$ INCY
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCGEMV( IORDER, TRANS, M, N,
|
|
$ ALPHA, AA, LDA, XX, INCX,
|
|
$ BETA, YY, INCY )
|
|
ELSE IF( 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 CCGBMV( 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 TO 130
|
|
END IF
|
|
*
|
|
* See what data changed inside subroutines.
|
|
*
|
|
* IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN
|
|
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 ) = LCE( AS, AA, LAA )
|
|
ISAME( 6 ) = LDAS.EQ.LDA
|
|
ISAME( 7 ) = LCE( XS, XX, LX )
|
|
ISAME( 8 ) = INCXS.EQ.INCX
|
|
ISAME( 9 ) = BLS.EQ.BETA
|
|
IF( NULL )THEN
|
|
ISAME( 10 ) = LCE( YS, YY, LY )
|
|
ELSE
|
|
ISAME( 10 ) = LCERES( 'ge', ' ', 1,
|
|
$ ML, YS, YY,
|
|
$ ABS( INCY ) )
|
|
END IF
|
|
ISAME( 11 ) = INCYS.EQ.INCY
|
|
ELSE IF( BANDED )THEN
|
|
ISAME( 4 ) = KLS.EQ.KL
|
|
ISAME( 5 ) = KUS.EQ.KU
|
|
ISAME( 6 ) = ALS.EQ.ALPHA
|
|
ISAME( 7 ) = LCE( AS, AA, LAA )
|
|
ISAME( 8 ) = LDAS.EQ.LDA
|
|
ISAME( 9 ) = LCE( XS, XX, LX )
|
|
ISAME( 10 ) = INCXS.EQ.INCX
|
|
ISAME( 11 ) = BLS.EQ.BETA
|
|
IF( NULL )THEN
|
|
ISAME( 12 ) = LCE( YS, YY, LY )
|
|
ELSE
|
|
ISAME( 12 ) = LCERES( '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.
|
|
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 130
|
|
END IF
|
|
*
|
|
IF( .NOT.NULL )THEN
|
|
*
|
|
* Check the result.
|
|
*
|
|
CALL CMVCH( 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
|
|
* 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, CTRANS, M, N, ALPHA, LDA,
|
|
$ INCX, BETA, INCY
|
|
ELSE IF( BANDED )THEN
|
|
WRITE( NOUT, FMT = 9995 )NC, SNAME, CTRANS, M, N, KL, KU,
|
|
$ ALPHA, LDA, INCX, BETA, INCY
|
|
END IF
|
|
*
|
|
140 CONTINUE
|
|
RETURN
|
|
*
|
|
9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
|
|
$ 'S)' )
|
|
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
|
|
$ 'ANGED INCORRECTLY *******' )
|
|
9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
|
|
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
|
|
$ ' - SUSPECT *******' )
|
|
9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
|
|
9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 4( I3, ',' ), '(',
|
|
$ F4.1, ',', F4.1, '), A,',/ 10x, I3, ', X,', I2, ',(',
|
|
$ F4.1, ',', F4.1, '), Y,', I2, ') .' )
|
|
9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), '(',
|
|
$ F4.1, ',', F4.1, '), A,',/ 10x, I3, ', X,', I2, ',(',
|
|
$ F4.1, ',', F4.1, '), Y,', I2, ') .' )
|
|
9993 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
|
|
$ '******' )
|
|
*
|
|
* End of CCHK1.
|
|
*
|
|
END
|
|
SUBROUTINE CCHK2( 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 CHEMV, CHBMV and CHPMV.
|
|
*
|
|
* 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 ZERO, HALF
|
|
PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) )
|
|
REAL RZERO
|
|
PARAMETER ( RZERO = 0.0 )
|
|
* .. Scalar Arguments ..
|
|
REAL EPS, THRESH
|
|
INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
|
|
$ NOUT, NTRA, IORDER
|
|
LOGICAL FATAL, REWI, TRACE
|
|
CHARACTER*12 SNAME
|
|
* .. Array Arguments ..
|
|
COMPLEX 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 )
|
|
REAL G( NMAX )
|
|
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
|
|
* .. Local Scalars ..
|
|
COMPLEX ALPHA, ALS, BETA, BLS, TRANSL
|
|
REAL 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*14 CUPLO
|
|
CHARACTER*2 ICH
|
|
* .. Local Arrays ..
|
|
LOGICAL ISAME( 13 )
|
|
* .. External Functions ..
|
|
LOGICAL LCE, LCERES
|
|
EXTERNAL LCE, LCERES
|
|
* .. External Subroutines ..
|
|
EXTERNAL CCHBMV, CCHEMV, CCHPMV, CMAKE, CMVCH
|
|
* .. 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.'e'
|
|
BANDED = SNAME( 9: 9 ).EQ.'b'
|
|
PACKED = SNAME( 9: 9 ).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 )
|
|
IF (UPLO.EQ.'U')THEN
|
|
CUPLO = ' CblasUpper'
|
|
ELSE
|
|
CUPLO = ' CblasLower'
|
|
END IF
|
|
*
|
|
* Generate the matrix A.
|
|
*
|
|
TRANSL = ZERO
|
|
CALL CMAKE( SNAME( 8: 9 ), 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 CMAKE( '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 CMAKE( '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,
|
|
$ CUPLO, N, ALPHA, LDA, INCX, BETA, INCY
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCHEMV( IORDER, UPLO, N, ALPHA, AA,
|
|
$ LDA, XX, INCX, BETA, YY,
|
|
$ INCY )
|
|
ELSE IF( BANDED )THEN
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
|
|
$ CUPLO, N, K, ALPHA, LDA, INCX, BETA,
|
|
$ INCY
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCHBMV( IORDER, UPLO, N, K, ALPHA,
|
|
$ AA, LDA, XX, INCX, BETA,
|
|
$ YY, INCY )
|
|
ELSE IF( PACKED )THEN
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
|
|
$ CUPLO, N, ALPHA, INCX, BETA, INCY
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCHPMV( IORDER, 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 ) = LCE( AS, AA, LAA )
|
|
ISAME( 5 ) = LDAS.EQ.LDA
|
|
ISAME( 6 ) = LCE( XS, XX, LX )
|
|
ISAME( 7 ) = INCXS.EQ.INCX
|
|
ISAME( 8 ) = BLS.EQ.BETA
|
|
IF( NULL )THEN
|
|
ISAME( 9 ) = LCE( YS, YY, LY )
|
|
ELSE
|
|
ISAME( 9 ) = LCERES( '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 ) = LCE( AS, AA, LAA )
|
|
ISAME( 6 ) = LDAS.EQ.LDA
|
|
ISAME( 7 ) = LCE( XS, XX, LX )
|
|
ISAME( 8 ) = INCXS.EQ.INCX
|
|
ISAME( 9 ) = BLS.EQ.BETA
|
|
IF( NULL )THEN
|
|
ISAME( 10 ) = LCE( YS, YY, LY )
|
|
ELSE
|
|
ISAME( 10 ) = LCERES( '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 ) = LCE( AS, AA, LAA )
|
|
ISAME( 5 ) = LCE( XS, XX, LX )
|
|
ISAME( 6 ) = INCXS.EQ.INCX
|
|
ISAME( 7 ) = BLS.EQ.BETA
|
|
IF( NULL )THEN
|
|
ISAME( 8 ) = LCE( YS, YY, LY )
|
|
ELSE
|
|
ISAME( 8 ) = LCERES( '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
|
|
40 CONTINUE
|
|
IF( .NOT.SAME )THEN
|
|
FATAL = .TRUE.
|
|
GO TO 120
|
|
END IF
|
|
*
|
|
IF( .NOT.NULL )THEN
|
|
*
|
|
* Check the result.
|
|
*
|
|
CALL CMVCH( 'N', N, 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 120
|
|
ELSE
|
|
* Avoid repeating tests with N.le.0
|
|
GO TO 110
|
|
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
|
|
IF( FULL )THEN
|
|
WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, LDA, INCX,
|
|
$ BETA, INCY
|
|
ELSE IF( BANDED )THEN
|
|
WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, K, ALPHA, LDA,
|
|
$ INCX, BETA, INCY
|
|
ELSE IF( PACKED )THEN
|
|
WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, N, ALPHA, INCX,
|
|
$ BETA, INCY
|
|
END IF
|
|
*
|
|
130 CONTINUE
|
|
RETURN
|
|
*
|
|
9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
|
|
$ 'S)' )
|
|
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
|
|
$ 'ANGED INCORRECTLY *******' )
|
|
9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
|
|
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
|
|
$ ' - SUSPECT *******' )
|
|
9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
|
|
9995 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',',
|
|
$ F4.1, '), AP, X,',/ 10x, I2, ',(', F4.1, ',', F4.1,
|
|
$ '), Y,', I2, ') .' )
|
|
9994 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', 2( I3, ',' ), '(',
|
|
$ F4.1, ',', F4.1, '), A,', I3, ', X,',/ 10x, I2, ',(',
|
|
$ F4.1, ',', F4.1, '), Y,', I2, ') .' )
|
|
9993 FORMAT( 1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',',
|
|
$ F4.1, '), A,', I3, ', X,',/ 10x, I2, ',(', F4.1, ',',
|
|
$ F4.1, '), ', 'Y,', I2, ') .' )
|
|
9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
|
|
$ '******' )
|
|
*
|
|
* End of CCHK2.
|
|
*
|
|
END
|
|
SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
|
|
$ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
|
|
$ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z, IORDER )
|
|
*
|
|
* Tests CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV.
|
|
*
|
|
* 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 ZERO, HALF, ONE
|
|
PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ),
|
|
$ ONE = ( 1.0, 0.0 ) )
|
|
REAL RZERO
|
|
PARAMETER ( RZERO = 0.0 )
|
|
* .. Scalar Arguments ..
|
|
REAL EPS, THRESH
|
|
INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA,
|
|
$ IORDER
|
|
LOGICAL FATAL, REWI, TRACE
|
|
CHARACTER*12 SNAME
|
|
* .. Array Arguments ..
|
|
COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ),
|
|
$ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
|
|
$ XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX )
|
|
REAL G( NMAX )
|
|
INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
|
|
* .. Local Scalars ..
|
|
COMPLEX TRANSL
|
|
REAL ERR, ERRMAX
|
|
INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
|
|
$ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
|
|
LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
|
|
CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
|
|
CHARACTER*14 CUPLO,CTRANS,CDIAG
|
|
CHARACTER*2 ICHD, ICHU
|
|
CHARACTER*3 ICHT
|
|
* .. Local Arrays ..
|
|
LOGICAL ISAME( 13 )
|
|
* .. External Functions ..
|
|
LOGICAL LCE, LCERES
|
|
EXTERNAL LCE, LCERES
|
|
* .. External Subroutines ..
|
|
EXTERNAL CMAKE, CMVCH, CCTBMV, CCTBSV, CCTPMV,
|
|
$ CCTPSV, CCTRMV, CCTRSV
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, MAX
|
|
* .. Scalars in Common ..
|
|
INTEGER INFOT, NOUTC
|
|
LOGICAL OK
|
|
* .. Common blocks ..
|
|
COMMON /INFOC/INFOT, NOUTC, OK
|
|
* .. Data statements ..
|
|
DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/
|
|
* .. Executable Statements ..
|
|
FULL = SNAME( 9: 9 ).EQ.'r'
|
|
BANDED = SNAME( 9: 9 ).EQ.'b'
|
|
PACKED = SNAME( 9: 9 ).EQ.'p'
|
|
* Define the number of arguments.
|
|
IF( FULL )THEN
|
|
NARGS = 8
|
|
ELSE IF( BANDED )THEN
|
|
NARGS = 9
|
|
ELSE IF( PACKED )THEN
|
|
NARGS = 7
|
|
END IF
|
|
*
|
|
NC = 0
|
|
RESET = .TRUE.
|
|
ERRMAX = RZERO
|
|
* Set up zero vector for CMVCH.
|
|
DO 10 I = 1, NMAX
|
|
Z( I ) = ZERO
|
|
10 CONTINUE
|
|
*
|
|
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 ICU = 1, 2
|
|
UPLO = ICHU( ICU: ICU )
|
|
IF (UPLO.EQ.'U')THEN
|
|
CUPLO = ' CblasUpper'
|
|
ELSE
|
|
CUPLO = ' CblasLower'
|
|
END IF
|
|
*
|
|
DO 80 ICT = 1, 3
|
|
TRANS = ICHT( ICT: ICT )
|
|
IF (TRANS.EQ.'N')THEN
|
|
CTRANS = ' CblasNoTrans'
|
|
ELSE IF (TRANS.EQ.'T')THEN
|
|
CTRANS = ' CblasTrans'
|
|
ELSE
|
|
CTRANS = 'CblasConjTrans'
|
|
END IF
|
|
*
|
|
DO 70 ICD = 1, 2
|
|
DIAG = ICHD( ICD: ICD )
|
|
IF (DIAG.EQ.'N')THEN
|
|
CDIAG = ' CblasNonUnit'
|
|
ELSE
|
|
CDIAG = ' CblasUnit'
|
|
END IF
|
|
*
|
|
* Generate the matrix A.
|
|
*
|
|
TRANSL = ZERO
|
|
CALL CMAKE( SNAME( 8: 9 ), UPLO, DIAG, N, N, A,
|
|
$ NMAX, AA, LDA, K, K, RESET, TRANSL )
|
|
*
|
|
DO 60 IX = 1, NINC
|
|
INCX = INC( IX )
|
|
LX = ABS( INCX )*N
|
|
*
|
|
* Generate the vector X.
|
|
*
|
|
TRANSL = HALF
|
|
CALL CMAKE( '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
|
|
*
|
|
NC = NC + 1
|
|
*
|
|
* Save every datum before calling the subroutine.
|
|
*
|
|
UPLOS = UPLO
|
|
TRANSS = TRANS
|
|
DIAGS = DIAG
|
|
NS = N
|
|
KS = K
|
|
DO 20 I = 1, LAA
|
|
AS( I ) = AA( I )
|
|
20 CONTINUE
|
|
LDAS = LDA
|
|
DO 30 I = 1, LX
|
|
XS( I ) = XX( I )
|
|
30 CONTINUE
|
|
INCXS = INCX
|
|
*
|
|
* Call the subroutine.
|
|
*
|
|
IF( SNAME( 10: 11 ).EQ.'mv' )THEN
|
|
IF( FULL )THEN
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9993 )NC, SNAME,
|
|
$ CUPLO, CTRANS, CDIAG, N, LDA, INCX
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCTRMV( IORDER, UPLO, TRANS, DIAG,
|
|
$ N, AA, LDA, XX, INCX )
|
|
ELSE IF( BANDED )THEN
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
|
|
$ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCTBMV( IORDER, UPLO, TRANS, DIAG,
|
|
$ N, K, AA, LDA, XX, INCX )
|
|
ELSE IF( PACKED )THEN
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
|
|
$ CUPLO, CTRANS, CDIAG, N, INCX
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCTPMV( IORDER, UPLO, TRANS, DIAG,
|
|
$ N, AA, XX, INCX )
|
|
END IF
|
|
ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN
|
|
IF( FULL )THEN
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9993 )NC, SNAME,
|
|
$ CUPLO, CTRANS, CDIAG, N, LDA, INCX
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCTRSV( IORDER, UPLO, TRANS, DIAG,
|
|
$ N, AA, LDA, XX, INCX )
|
|
ELSE IF( BANDED )THEN
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9994 )NC, SNAME,
|
|
$ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCTBSV( IORDER, UPLO, TRANS, DIAG,
|
|
$ N, K, AA, LDA, XX, INCX )
|
|
ELSE IF( PACKED )THEN
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9995 )NC, SNAME,
|
|
$ CUPLO, CTRANS, CDIAG, N, INCX
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCTPSV( IORDER, UPLO, TRANS, DIAG,
|
|
$ N, AA, XX, INCX )
|
|
END IF
|
|
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 ) = TRANS.EQ.TRANSS
|
|
ISAME( 3 ) = DIAG.EQ.DIAGS
|
|
ISAME( 4 ) = NS.EQ.N
|
|
IF( FULL )THEN
|
|
ISAME( 5 ) = LCE( AS, AA, LAA )
|
|
ISAME( 6 ) = LDAS.EQ.LDA
|
|
IF( NULL )THEN
|
|
ISAME( 7 ) = LCE( XS, XX, LX )
|
|
ELSE
|
|
ISAME( 7 ) = LCERES( 'ge', ' ', 1, N, XS,
|
|
$ XX, ABS( INCX ) )
|
|
END IF
|
|
ISAME( 8 ) = INCXS.EQ.INCX
|
|
ELSE IF( BANDED )THEN
|
|
ISAME( 5 ) = KS.EQ.K
|
|
ISAME( 6 ) = LCE( AS, AA, LAA )
|
|
ISAME( 7 ) = LDAS.EQ.LDA
|
|
IF( NULL )THEN
|
|
ISAME( 8 ) = LCE( XS, XX, LX )
|
|
ELSE
|
|
ISAME( 8 ) = LCERES( 'ge', ' ', 1, N, XS,
|
|
$ XX, ABS( INCX ) )
|
|
END IF
|
|
ISAME( 9 ) = INCXS.EQ.INCX
|
|
ELSE IF( PACKED )THEN
|
|
ISAME( 5 ) = LCE( AS, AA, LAA )
|
|
IF( NULL )THEN
|
|
ISAME( 6 ) = LCE( XS, XX, LX )
|
|
ELSE
|
|
ISAME( 6 ) = LCERES( 'ge', ' ', 1, N, XS,
|
|
$ XX, ABS( INCX ) )
|
|
END IF
|
|
ISAME( 7 ) = INCXS.EQ.INCX
|
|
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
|
|
40 CONTINUE
|
|
IF( .NOT.SAME )THEN
|
|
FATAL = .TRUE.
|
|
GO TO 120
|
|
END IF
|
|
*
|
|
IF( .NOT.NULL )THEN
|
|
IF( SNAME( 10: 11 ).EQ.'mv' )THEN
|
|
*
|
|
* Check the result.
|
|
*
|
|
CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X,
|
|
$ INCX, ZERO, Z, INCX, XT, G,
|
|
$ XX, EPS, ERR, FATAL, NOUT,
|
|
$ .TRUE. )
|
|
ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN
|
|
*
|
|
* Compute approximation to original vector.
|
|
*
|
|
DO 50 I = 1, N
|
|
Z( I ) = XX( 1 + ( I - 1 )*
|
|
$ ABS( INCX ) )
|
|
XX( 1 + ( I - 1 )*ABS( INCX ) )
|
|
$ = X( I )
|
|
50 CONTINUE
|
|
CALL CMVCH( TRANS, N, N, ONE, A, NMAX, Z,
|
|
$ INCX, ZERO, X, INCX, XT, G,
|
|
$ XX, EPS, ERR, FATAL, NOUT,
|
|
$ .FALSE. )
|
|
END IF
|
|
ERRMAX = MAX( ERRMAX, ERR )
|
|
* If got really bad answer, report and return.
|
|
IF( FATAL )
|
|
$ GO TO 120
|
|
ELSE
|
|
* Avoid repeating tests with N.le.0.
|
|
GO TO 110
|
|
END IF
|
|
*
|
|
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
|
|
IF( FULL )THEN
|
|
WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, CTRANS, CDIAG, N,
|
|
$ LDA, INCX
|
|
ELSE IF( BANDED )THEN
|
|
WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, K,
|
|
$ LDA, INCX
|
|
ELSE IF( PACKED )THEN
|
|
WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, CTRANS, CDIAG, N,
|
|
$ INCX
|
|
END IF
|
|
*
|
|
130 CONTINUE
|
|
RETURN
|
|
*
|
|
9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
|
|
$ 'S)' )
|
|
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
|
|
$ 'ANGED INCORRECTLY *******' )
|
|
9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
|
|
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
|
|
$ ' - SUSPECT *******' )
|
|
9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
|
|
9995 FORMAT(1X, I6, ': ',A12, '(', 3( A14, ',' ),/ 10x, I3, ', AP, ',
|
|
$ 'X,', I2, ') .' )
|
|
9994 FORMAT(1X, I6, ': ',A12, '(', 3( A14, ',' ),/ 10x, 2( I3, ',' ),
|
|
$ ' A,', I3, ', X,', I2, ') .' )
|
|
9993 FORMAT( 1X, I6, ': ',A12, '(', 3( A14, ',' ),/ 10x, I3, ', A,',
|
|
$ I3, ', X,', I2, ') .' )
|
|
9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
|
|
$ '******' )
|
|
*
|
|
* End of CCHK3.
|
|
*
|
|
END
|
|
SUBROUTINE CCHK4( SNAME, 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, IORDER )
|
|
*
|
|
* Tests CGERC and CGERU.
|
|
*
|
|
* 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 ZERO, HALF, ONE
|
|
PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ),
|
|
$ ONE = ( 1.0, 0.0 ) )
|
|
REAL RZERO
|
|
PARAMETER ( RZERO = 0.0 )
|
|
* .. Scalar Arguments ..
|
|
REAL EPS, THRESH
|
|
INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
|
|
$ IORDER
|
|
LOGICAL FATAL, REWI, TRACE
|
|
CHARACTER*12 SNAME
|
|
* .. Array Arguments ..
|
|
COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
|
|
$ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
|
|
$ XX( NMAX*INCMAX ), Y( NMAX ),
|
|
$ YS( NMAX*INCMAX ), YT( NMAX ),
|
|
$ YY( NMAX*INCMAX ), Z( NMAX )
|
|
REAL G( NMAX )
|
|
INTEGER IDIM( NIDIM ), INC( NINC )
|
|
* .. Local Scalars ..
|
|
COMPLEX ALPHA, ALS, TRANSL
|
|
REAL ERR, ERRMAX
|
|
INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
|
|
$ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
|
|
$ NC, ND, NS
|
|
LOGICAL CONJ, NULL, RESET, SAME
|
|
* .. Local Arrays ..
|
|
COMPLEX W( 1 )
|
|
LOGICAL ISAME( 13 )
|
|
* .. External Functions ..
|
|
LOGICAL LCE, LCERES
|
|
EXTERNAL LCE, LCERES
|
|
* .. External Subroutines ..
|
|
EXTERNAL CCGERC, CCGERU, CMAKE, CMVCH
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, CONJG, MAX, MIN
|
|
* .. Scalars in Common ..
|
|
INTEGER INFOT, NOUTC
|
|
LOGICAL OK
|
|
* .. Common blocks ..
|
|
COMMON /INFOC/INFOT, NOUTC, OK
|
|
* .. Executable Statements ..
|
|
CONJ = SNAME( 11: 11 ).EQ.'c'
|
|
* Define the number of arguments.
|
|
NARGS = 9
|
|
*
|
|
NC = 0
|
|
RESET = .TRUE.
|
|
ERRMAX = RZERO
|
|
*
|
|
DO 120 IN = 1, NIDIM
|
|
N = IDIM( IN )
|
|
ND = N/2 + 1
|
|
*
|
|
DO 110 IM = 1, 2
|
|
IF( IM.EQ.1 )
|
|
$ M = MAX( N - ND, 0 )
|
|
IF( IM.EQ.2 )
|
|
$ M = MIN( N + ND, NMAX )
|
|
*
|
|
* Set LDA to 1 more than minimum value if room.
|
|
LDA = M
|
|
IF( LDA.LT.NMAX )
|
|
$ LDA = LDA + 1
|
|
* Skip tests if not enough room.
|
|
IF( LDA.GT.NMAX )
|
|
$ GO TO 110
|
|
LAA = LDA*N
|
|
NULL = N.LE.0.OR.M.LE.0
|
|
*
|
|
DO 100 IX = 1, NINC
|
|
INCX = INC( IX )
|
|
LX = ABS( INCX )*M
|
|
*
|
|
* Generate the vector X.
|
|
*
|
|
TRANSL = HALF
|
|
CALL CMAKE( 'ge', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
|
|
$ 0, M - 1, RESET, TRANSL )
|
|
IF( M.GT.1 )THEN
|
|
X( M/2 ) = ZERO
|
|
XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
|
|
END IF
|
|
*
|
|
DO 90 IY = 1, NINC
|
|
INCY = INC( IY )
|
|
LY = ABS( INCY )*N
|
|
*
|
|
* Generate the vector Y.
|
|
*
|
|
TRANSL = ZERO
|
|
CALL CMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
|
|
$ ABS( INCY ), 0, N - 1, RESET, TRANSL )
|
|
IF( N.GT.1 )THEN
|
|
Y( N/2 ) = ZERO
|
|
YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
|
|
END IF
|
|
*
|
|
DO 80 IA = 1, NALF
|
|
ALPHA = ALF( IA )
|
|
*
|
|
* Generate the matrix A.
|
|
*
|
|
TRANSL = ZERO
|
|
CALL CMAKE(SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX,
|
|
$ AA, LDA, M - 1, N - 1, RESET, TRANSL )
|
|
*
|
|
NC = NC + 1
|
|
*
|
|
* Save every datum before calling the subroutine.
|
|
*
|
|
MS = M
|
|
NS = N
|
|
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
|
|
DO 30 I = 1, LY
|
|
YS( I ) = YY( I )
|
|
30 CONTINUE
|
|
INCYS = INCY
|
|
*
|
|
* Call the subroutine.
|
|
*
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
|
|
$ ALPHA, INCX, INCY, LDA
|
|
IF( CONJ )THEN
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCGERC( IORDER, M, N, ALPHA, XX, INCX,
|
|
$ YY, INCY, AA, LDA )
|
|
ELSE
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCGERU( IORDER, M, N, ALPHA, XX, INCX,
|
|
$ YY, INCY, AA, LDA )
|
|
END IF
|
|
*
|
|
* Check if error-exit was taken incorrectly.
|
|
*
|
|
IF( .NOT.OK )THEN
|
|
WRITE( NOUT, FMT = 9993 )
|
|
FATAL = .TRUE.
|
|
GO TO 140
|
|
END IF
|
|
*
|
|
* See what data changed inside subroutine.
|
|
*
|
|
ISAME( 1 ) = MS.EQ.M
|
|
ISAME( 2 ) = NS.EQ.N
|
|
ISAME( 3 ) = ALS.EQ.ALPHA
|
|
ISAME( 4 ) = LCE( XS, XX, LX )
|
|
ISAME( 5 ) = INCXS.EQ.INCX
|
|
ISAME( 6 ) = LCE( YS, YY, LY )
|
|
ISAME( 7 ) = INCYS.EQ.INCY
|
|
IF( NULL )THEN
|
|
ISAME( 8 ) = LCE( AS, AA, LAA )
|
|
ELSE
|
|
ISAME( 8 ) = LCERES( 'ge', ' ', M, N, AS, AA,
|
|
$ LDA )
|
|
END IF
|
|
ISAME( 9 ) = LDAS.EQ.LDA
|
|
*
|
|
* 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 140
|
|
END IF
|
|
*
|
|
IF( .NOT.NULL )THEN
|
|
*
|
|
* Check the result column by column.
|
|
*
|
|
IF( INCX.GT.0 )THEN
|
|
DO 50 I = 1, M
|
|
Z( I ) = X( I )
|
|
50 CONTINUE
|
|
ELSE
|
|
DO 60 I = 1, M
|
|
Z( I ) = X( M - I + 1 )
|
|
60 CONTINUE
|
|
END IF
|
|
DO 70 J = 1, N
|
|
IF( INCY.GT.0 )THEN
|
|
W( 1 ) = Y( J )
|
|
ELSE
|
|
W( 1 ) = Y( N - J + 1 )
|
|
END IF
|
|
IF( CONJ )
|
|
$ W( 1 ) = CONJG( W( 1 ) )
|
|
CALL CMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1,
|
|
$ ONE, A( 1, J ), 1, YT, G,
|
|
$ AA( 1 + ( J - 1 )*LDA ), EPS,
|
|
$ ERR, FATAL, NOUT, .TRUE. )
|
|
ERRMAX = MAX( ERRMAX, ERR )
|
|
* If got really bad answer, report and return.
|
|
IF( FATAL )
|
|
$ GO TO 130
|
|
70 CONTINUE
|
|
ELSE
|
|
* Avoid repeating tests with M.le.0 or N.le.0.
|
|
GO TO 110
|
|
END IF
|
|
*
|
|
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 150
|
|
*
|
|
130 CONTINUE
|
|
WRITE( NOUT, FMT = 9995 )J
|
|
*
|
|
140 CONTINUE
|
|
WRITE( NOUT, FMT = 9996 )SNAME
|
|
WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
|
|
*
|
|
150 CONTINUE
|
|
RETURN
|
|
*
|
|
9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
|
|
$ 'S)' )
|
|
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
|
|
$ 'ANGED INCORRECTLY *******' )
|
|
9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
|
|
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
|
|
$ ' - SUSPECT *******' )
|
|
9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
|
|
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
|
|
9994 FORMAT(1X, I6, ': ',A12, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1,
|
|
$ '), X,', I2, ', Y,', I2, ', A,', I3, ') .' )
|
|
9993 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
|
|
$ '******' )
|
|
*
|
|
* End of CCHK4.
|
|
*
|
|
END
|
|
SUBROUTINE CCHK5( SNAME, 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, IORDER )
|
|
*
|
|
* Tests CHER and CHPR.
|
|
*
|
|
* 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 ZERO, HALF, ONE
|
|
PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ),
|
|
$ ONE = ( 1.0, 0.0 ) )
|
|
REAL RZERO
|
|
PARAMETER ( RZERO = 0.0 )
|
|
* .. Scalar Arguments ..
|
|
REAL EPS, THRESH
|
|
INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
|
|
$ IORDER
|
|
LOGICAL FATAL, REWI, TRACE
|
|
CHARACTER*12 SNAME
|
|
* .. Array Arguments ..
|
|
COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
|
|
$ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
|
|
$ XX( NMAX*INCMAX ), Y( NMAX ),
|
|
$ YS( NMAX*INCMAX ), YT( NMAX ),
|
|
$ YY( NMAX*INCMAX ), Z( NMAX )
|
|
REAL G( NMAX )
|
|
INTEGER IDIM( NIDIM ), INC( NINC )
|
|
* .. Local Scalars ..
|
|
COMPLEX ALPHA, TRANSL
|
|
REAL ERR, ERRMAX, RALPHA, RALS
|
|
INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
|
|
$ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
|
|
LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
|
|
CHARACTER*1 UPLO, UPLOS
|
|
CHARACTER*14 CUPLO
|
|
CHARACTER*2 ICH
|
|
* .. Local Arrays ..
|
|
COMPLEX W( 1 )
|
|
LOGICAL ISAME( 13 )
|
|
* .. External Functions ..
|
|
LOGICAL LCE, LCERES
|
|
EXTERNAL LCE, LCERES
|
|
* .. External Subroutines ..
|
|
EXTERNAL CCHER, CCHPR, CMAKE, CMVCH
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, CMPLX, CONJG, MAX, REAL
|
|
* .. 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.'e'
|
|
PACKED = SNAME( 9: 9 ).EQ.'p'
|
|
* Define the number of arguments.
|
|
IF( FULL )THEN
|
|
NARGS = 7
|
|
ELSE IF( PACKED )THEN
|
|
NARGS = 6
|
|
END IF
|
|
*
|
|
NC = 0
|
|
RESET = .TRUE.
|
|
ERRMAX = RZERO
|
|
*
|
|
DO 100 IN = 1, NIDIM
|
|
N = IDIM( IN )
|
|
* Set LDA to 1 more than minimum value if room.
|
|
LDA = N
|
|
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
|
|
*
|
|
DO 90 IC = 1, 2
|
|
UPLO = ICH( IC: IC )
|
|
IF (UPLO.EQ.'U')THEN
|
|
CUPLO = ' CblasUpper'
|
|
ELSE
|
|
CUPLO = ' CblasLower'
|
|
END IF
|
|
UPPER = UPLO.EQ.'U'
|
|
*
|
|
DO 80 IX = 1, NINC
|
|
INCX = INC( IX )
|
|
LX = ABS( INCX )*N
|
|
*
|
|
* Generate the vector X.
|
|
*
|
|
TRANSL = HALF
|
|
CALL CMAKE( '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 IA = 1, NALF
|
|
RALPHA = REAL( ALF( IA ) )
|
|
ALPHA = CMPLX( RALPHA, RZERO )
|
|
NULL = N.LE.0.OR.RALPHA.EQ.RZERO
|
|
*
|
|
* Generate the matrix A.
|
|
*
|
|
TRANSL = ZERO
|
|
CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A, NMAX,
|
|
$ AA, LDA, N - 1, N - 1, RESET, TRANSL )
|
|
*
|
|
NC = NC + 1
|
|
*
|
|
* Save every datum before calling the subroutine.
|
|
*
|
|
UPLOS = UPLO
|
|
NS = N
|
|
RALS = RALPHA
|
|
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
|
|
*
|
|
* Call the subroutine.
|
|
*
|
|
IF( FULL )THEN
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9993 )NC, SNAME, CUPLO, N,
|
|
$ RALPHA, INCX, LDA
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCHER( IORDER, UPLO, N, RALPHA, XX,
|
|
$ INCX, AA, LDA )
|
|
ELSE IF( PACKED )THEN
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N,
|
|
$ RALPHA, INCX
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCHPR( IORDER, UPLO, N, RALPHA,
|
|
$ XX, INCX, AA )
|
|
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
|
|
ISAME( 3 ) = RALS.EQ.RALPHA
|
|
ISAME( 4 ) = LCE( XS, XX, LX )
|
|
ISAME( 5 ) = INCXS.EQ.INCX
|
|
IF( NULL )THEN
|
|
ISAME( 6 ) = LCE( AS, AA, LAA )
|
|
ELSE
|
|
ISAME( 6 ) = LCERES( SNAME( 8: 9 ), UPLO, N, N, AS,
|
|
$ AA, LDA )
|
|
END IF
|
|
IF( .NOT.PACKED )THEN
|
|
ISAME( 7 ) = LDAS.EQ.LDA
|
|
END IF
|
|
*
|
|
* If data was incorrectly changed, report and return.
|
|
*
|
|
SAME = .TRUE.
|
|
DO 30 I = 1, NARGS
|
|
SAME = SAME.AND.ISAME( I )
|
|
IF( .NOT.ISAME( I ) )
|
|
$ WRITE( NOUT, FMT = 9998 )I
|
|
30 CONTINUE
|
|
IF( .NOT.SAME )THEN
|
|
FATAL = .TRUE.
|
|
GO TO 120
|
|
END IF
|
|
*
|
|
IF( .NOT.NULL )THEN
|
|
*
|
|
* Check the result column by column.
|
|
*
|
|
IF( INCX.GT.0 )THEN
|
|
DO 40 I = 1, N
|
|
Z( I ) = X( I )
|
|
40 CONTINUE
|
|
ELSE
|
|
DO 50 I = 1, N
|
|
Z( I ) = X( N - I + 1 )
|
|
50 CONTINUE
|
|
END IF
|
|
JA = 1
|
|
DO 60 J = 1, N
|
|
W( 1 ) = CONJG( Z( J ) )
|
|
IF( UPPER )THEN
|
|
JJ = 1
|
|
LJ = J
|
|
ELSE
|
|
JJ = J
|
|
LJ = N - J + 1
|
|
END IF
|
|
CALL CMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
|
|
$ 1, ONE, A( JJ, J ), 1, YT, G,
|
|
$ AA( JA ), EPS, ERR, FATAL, NOUT,
|
|
$ .TRUE. )
|
|
IF( FULL )THEN
|
|
IF( UPPER )THEN
|
|
JA = JA + LDA
|
|
ELSE
|
|
JA = JA + LDA + 1
|
|
END IF
|
|
ELSE
|
|
JA = JA + LJ
|
|
END IF
|
|
ERRMAX = MAX( ERRMAX, ERR )
|
|
* If got really bad answer, report and return.
|
|
IF( FATAL )
|
|
$ GO TO 110
|
|
60 CONTINUE
|
|
ELSE
|
|
* Avoid repeating tests if N.le.0.
|
|
IF( N.LE.0 )
|
|
$ GO TO 100
|
|
END IF
|
|
*
|
|
70 CONTINUE
|
|
*
|
|
80 CONTINUE
|
|
*
|
|
90 CONTINUE
|
|
*
|
|
100 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
|
|
*
|
|
110 CONTINUE
|
|
WRITE( NOUT, FMT = 9995 )J
|
|
*
|
|
120 CONTINUE
|
|
WRITE( NOUT, FMT = 9996 )SNAME
|
|
IF( FULL )THEN
|
|
WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, RALPHA, INCX, LDA
|
|
ELSE IF( PACKED )THEN
|
|
WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, RALPHA, INCX
|
|
END IF
|
|
*
|
|
130 CONTINUE
|
|
RETURN
|
|
*
|
|
9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
|
|
$ 'S)' )
|
|
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
|
|
$ 'ANGED INCORRECTLY *******' )
|
|
9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
|
|
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
|
|
$ ' - SUSPECT *******' )
|
|
9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
|
|
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
|
|
9994 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,',
|
|
$ I2, ', AP) .' )
|
|
9993 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',', F4.1, ', X,',
|
|
$ I2, ', A,', I3, ') .' )
|
|
9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
|
|
$ '******' )
|
|
*
|
|
* End of CCHK5.
|
|
*
|
|
END
|
|
SUBROUTINE CCHK6( SNAME, 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, IORDER )
|
|
*
|
|
* Tests CHER2 and CHPR2.
|
|
*
|
|
* 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 ZERO, HALF, ONE
|
|
PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ),
|
|
$ ONE = ( 1.0, 0.0 ) )
|
|
REAL RZERO
|
|
PARAMETER ( RZERO = 0.0 )
|
|
* .. Scalar Arguments ..
|
|
REAL EPS, THRESH
|
|
INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
|
|
$ IORDER
|
|
LOGICAL FATAL, REWI, TRACE
|
|
CHARACTER*12 SNAME
|
|
* .. Array Arguments ..
|
|
COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
|
|
$ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
|
|
$ XX( NMAX*INCMAX ), Y( NMAX ),
|
|
$ YS( NMAX*INCMAX ), YT( NMAX ),
|
|
$ YY( NMAX*INCMAX ), Z( NMAX, 2 )
|
|
REAL G( NMAX )
|
|
INTEGER IDIM( NIDIM ), INC( NINC )
|
|
* .. Local Scalars ..
|
|
COMPLEX ALPHA, ALS, TRANSL
|
|
REAL ERR, ERRMAX
|
|
INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
|
|
$ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
|
|
$ NARGS, NC, NS
|
|
LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
|
|
CHARACTER*1 UPLO, UPLOS
|
|
CHARACTER*14 CUPLO
|
|
CHARACTER*2 ICH
|
|
* .. Local Arrays ..
|
|
COMPLEX W( 2 )
|
|
LOGICAL ISAME( 13 )
|
|
* .. External Functions ..
|
|
LOGICAL LCE, LCERES
|
|
EXTERNAL LCE, LCERES
|
|
* .. External Subroutines ..
|
|
EXTERNAL CCHER2, CCHPR2, CMAKE, CMVCH
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, CONJG, 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.'e'
|
|
PACKED = SNAME( 9: 9 ).EQ.'p'
|
|
* Define the number of arguments.
|
|
IF( FULL )THEN
|
|
NARGS = 9
|
|
ELSE IF( PACKED )THEN
|
|
NARGS = 8
|
|
END IF
|
|
*
|
|
NC = 0
|
|
RESET = .TRUE.
|
|
ERRMAX = RZERO
|
|
*
|
|
DO 140 IN = 1, NIDIM
|
|
N = IDIM( IN )
|
|
* Set LDA to 1 more than minimum value if room.
|
|
LDA = N
|
|
IF( LDA.LT.NMAX )
|
|
$ LDA = LDA + 1
|
|
* Skip tests if not enough room.
|
|
IF( LDA.GT.NMAX )
|
|
$ GO TO 140
|
|
IF( PACKED )THEN
|
|
LAA = ( N*( N + 1 ) )/2
|
|
ELSE
|
|
LAA = LDA*N
|
|
END IF
|
|
*
|
|
DO 130 IC = 1, 2
|
|
UPLO = ICH( IC: IC )
|
|
IF (UPLO.EQ.'U')THEN
|
|
CUPLO = ' CblasUpper'
|
|
ELSE
|
|
CUPLO = ' CblasLower'
|
|
END IF
|
|
UPPER = UPLO.EQ.'U'
|
|
*
|
|
DO 120 IX = 1, NINC
|
|
INCX = INC( IX )
|
|
LX = ABS( INCX )*N
|
|
*
|
|
* Generate the vector X.
|
|
*
|
|
TRANSL = HALF
|
|
CALL CMAKE( '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 110 IY = 1, NINC
|
|
INCY = INC( IY )
|
|
LY = ABS( INCY )*N
|
|
*
|
|
* Generate the vector Y.
|
|
*
|
|
TRANSL = ZERO
|
|
CALL CMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY,
|
|
$ ABS( INCY ), 0, N - 1, RESET, TRANSL )
|
|
IF( N.GT.1 )THEN
|
|
Y( N/2 ) = ZERO
|
|
YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
|
|
END IF
|
|
*
|
|
DO 100 IA = 1, NALF
|
|
ALPHA = ALF( IA )
|
|
NULL = N.LE.0.OR.ALPHA.EQ.ZERO
|
|
*
|
|
* Generate the matrix A.
|
|
*
|
|
TRANSL = ZERO
|
|
CALL CMAKE( SNAME( 8: 9 ), UPLO, ' ', N, N, A,
|
|
$ NMAX, AA, LDA, N - 1, N - 1, RESET,
|
|
$ TRANSL )
|
|
*
|
|
NC = NC + 1
|
|
*
|
|
* Save every datum before calling the subroutine.
|
|
*
|
|
UPLOS = UPLO
|
|
NS = N
|
|
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
|
|
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, CUPLO, N,
|
|
$ ALPHA, INCX, INCY, LDA
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCHER2( IORDER, UPLO, N, ALPHA, XX, INCX,
|
|
$ YY, INCY, AA, LDA )
|
|
ELSE IF( PACKED )THEN
|
|
IF( TRACE )
|
|
$ WRITE( NTRA, FMT = 9994 )NC, SNAME, CUPLO, N,
|
|
$ ALPHA, INCX, INCY
|
|
IF( REWI )
|
|
$ REWIND NTRA
|
|
CALL CCHPR2( IORDER, UPLO, N, ALPHA, XX, INCX,
|
|
$ YY, INCY, AA )
|
|
END IF
|
|
*
|
|
* Check if error-exit was taken incorrectly.
|
|
*
|
|
IF( .NOT.OK )THEN
|
|
WRITE( NOUT, FMT = 9992 )
|
|
FATAL = .TRUE.
|
|
GO TO 160
|
|
END IF
|
|
*
|
|
* See what data changed inside subroutines.
|
|
*
|
|
ISAME( 1 ) = UPLO.EQ.UPLOS
|
|
ISAME( 2 ) = NS.EQ.N
|
|
ISAME( 3 ) = ALS.EQ.ALPHA
|
|
ISAME( 4 ) = LCE( XS, XX, LX )
|
|
ISAME( 5 ) = INCXS.EQ.INCX
|
|
ISAME( 6 ) = LCE( YS, YY, LY )
|
|
ISAME( 7 ) = INCYS.EQ.INCY
|
|
IF( NULL )THEN
|
|
ISAME( 8 ) = LCE( AS, AA, LAA )
|
|
ELSE
|
|
ISAME( 8 ) = LCERES( SNAME( 8: 9 ), UPLO, N, N,
|
|
$ AS, AA, LDA )
|
|
END IF
|
|
IF( .NOT.PACKED )THEN
|
|
ISAME( 9 ) = LDAS.EQ.LDA
|
|
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
|
|
40 CONTINUE
|
|
IF( .NOT.SAME )THEN
|
|
FATAL = .TRUE.
|
|
GO TO 160
|
|
END IF
|
|
*
|
|
IF( .NOT.NULL )THEN
|
|
*
|
|
* Check the result column by column.
|
|
*
|
|
IF( INCX.GT.0 )THEN
|
|
DO 50 I = 1, N
|
|
Z( I, 1 ) = X( I )
|
|
50 CONTINUE
|
|
ELSE
|
|
DO 60 I = 1, N
|
|
Z( I, 1 ) = X( N - I + 1 )
|
|
60 CONTINUE
|
|
END IF
|
|
IF( INCY.GT.0 )THEN
|
|
DO 70 I = 1, N
|
|
Z( I, 2 ) = Y( I )
|
|
70 CONTINUE
|
|
ELSE
|
|
DO 80 I = 1, N
|
|
Z( I, 2 ) = Y( N - I + 1 )
|
|
80 CONTINUE
|
|
END IF
|
|
JA = 1
|
|
DO 90 J = 1, N
|
|
W( 1 ) = ALPHA*CONJG( Z( J, 2 ) )
|
|
W( 2 ) = CONJG( ALPHA )*CONJG( Z( J, 1 ) )
|
|
IF( UPPER )THEN
|
|
JJ = 1
|
|
LJ = J
|
|
ELSE
|
|
JJ = J
|
|
LJ = N - J + 1
|
|
END IF
|
|
CALL CMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ),
|
|
$ NMAX, W, 1, ONE, A( JJ, J ), 1,
|
|
$ YT, G, AA( JA ), EPS, ERR, FATAL,
|
|
$ NOUT, .TRUE. )
|
|
IF( FULL )THEN
|
|
IF( UPPER )THEN
|
|
JA = JA + LDA
|
|
ELSE
|
|
JA = JA + LDA + 1
|
|
END IF
|
|
ELSE
|
|
JA = JA + LJ
|
|
END IF
|
|
ERRMAX = MAX( ERRMAX, ERR )
|
|
* If got really bad answer, report and return.
|
|
IF( FATAL )
|
|
$ GO TO 150
|
|
90 CONTINUE
|
|
ELSE
|
|
* Avoid repeating tests with N.le.0.
|
|
IF( N.LE.0 )
|
|
$ GO TO 140
|
|
END IF
|
|
*
|
|
100 CONTINUE
|
|
*
|
|
110 CONTINUE
|
|
*
|
|
120 CONTINUE
|
|
*
|
|
130 CONTINUE
|
|
*
|
|
140 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 170
|
|
*
|
|
150 CONTINUE
|
|
WRITE( NOUT, FMT = 9995 )J
|
|
*
|
|
160 CONTINUE
|
|
WRITE( NOUT, FMT = 9996 )SNAME
|
|
IF( FULL )THEN
|
|
WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, N, ALPHA, INCX,
|
|
$ INCY, LDA
|
|
ELSE IF( PACKED )THEN
|
|
WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, N, ALPHA, INCX, INCY
|
|
END IF
|
|
*
|
|
170 CONTINUE
|
|
RETURN
|
|
*
|
|
9999 FORMAT(' ',A12, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
|
|
$ 'S)' )
|
|
9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
|
|
$ 'ANGED INCORRECTLY *******' )
|
|
9997 FORMAT(' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
|
|
$ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
|
|
$ ' - SUSPECT *******' )
|
|
9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' )
|
|
9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
|
|
9994 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',',
|
|
$ F4.1, '), X,', I2, ', Y,', I2, ', AP) .' )
|
|
9993 FORMAT(1X, I6, ': ',A12, '(', A14, ',', I3, ',(', F4.1, ',',
|
|
$ F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ') .' )
|
|
9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
|
|
$ '******' )
|
|
*
|
|
* End of CCHK6.
|
|
*
|
|
END
|
|
SUBROUTINE CMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
|
|
$ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
|
|
*
|
|
* Checks the results of the computational tests.
|
|
*
|
|
* 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 ZERO
|
|
PARAMETER ( ZERO = ( 0.0, 0.0 ) )
|
|
REAL RZERO, RONE
|
|
PARAMETER ( RZERO = 0.0, RONE = 1.0 )
|
|
* .. Scalar Arguments ..
|
|
COMPLEX ALPHA, BETA
|
|
REAL EPS, ERR
|
|
INTEGER INCX, INCY, M, N, NMAX, NOUT
|
|
LOGICAL FATAL, MV
|
|
CHARACTER*1 TRANS
|
|
* .. Array Arguments ..
|
|
COMPLEX A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * )
|
|
REAL G( * )
|
|
* .. Local Scalars ..
|
|
COMPLEX C
|
|
REAL ERRI
|
|
INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
|
|
LOGICAL CTRAN, TRAN
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT
|
|
* .. Statement Functions ..
|
|
REAL ABS1
|
|
* .. Statement Function definitions ..
|
|
ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) )
|
|
* .. Executable Statements ..
|
|
TRAN = TRANS.EQ.'T'
|
|
CTRAN = TRANS.EQ.'C'
|
|
IF( TRAN.OR.CTRAN )THEN
|
|
ML = N
|
|
NL = M
|
|
ELSE
|
|
ML = M
|
|
NL = N
|
|
END IF
|
|
IF( INCX.LT.0 )THEN
|
|
KX = NL
|
|
INCXL = -1
|
|
ELSE
|
|
KX = 1
|
|
INCXL = 1
|
|
END IF
|
|
IF( INCY.LT.0 )THEN
|
|
KY = ML
|
|
INCYL = -1
|
|
ELSE
|
|
KY = 1
|
|
INCYL = 1
|
|
END IF
|
|
*
|
|
* Compute expected result in YT using data in A, X and Y.
|
|
* Compute gauges in G.
|
|
*
|
|
IY = KY
|
|
DO 40 I = 1, ML
|
|
YT( IY ) = ZERO
|
|
G( IY ) = RZERO
|
|
JX = KX
|
|
IF( TRAN )THEN
|
|
DO 10 J = 1, NL
|
|
YT( IY ) = YT( IY ) + A( J, I )*X( JX )
|
|
G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) )
|
|
JX = JX + INCXL
|
|
10 CONTINUE
|
|
ELSE IF( CTRAN )THEN
|
|
DO 20 J = 1, NL
|
|
YT( IY ) = YT( IY ) + CONJG( A( J, I ) )*X( JX )
|
|
G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) )
|
|
JX = JX + INCXL
|
|
20 CONTINUE
|
|
ELSE
|
|
DO 30 J = 1, NL
|
|
YT( IY ) = YT( IY ) + A( I, J )*X( JX )
|
|
G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) )
|
|
JX = JX + INCXL
|
|
30 CONTINUE
|
|
END IF
|
|
YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
|
|
G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) )
|
|
IY = IY + INCYL
|
|
40 CONTINUE
|
|
*
|
|
* Compute the error ratio for this result.
|
|
*
|
|
ERR = ZERO
|
|
DO 50 I = 1, ML
|
|
ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS
|
|
IF( G( I ).NE.RZERO )
|
|
$ ERRI = ERRI/G( I )
|
|
ERR = MAX( ERR, ERRI )
|
|
IF( ERR*SQRT( EPS ).GE.RONE )
|
|
$ GO TO 60
|
|
50 CONTINUE
|
|
* If the loop completes, all results are at least half accurate.
|
|
GO TO 80
|
|
*
|
|
* Report fatal error.
|
|
*
|
|
60 FATAL = .TRUE.
|
|
WRITE( NOUT, FMT = 9999 )
|
|
DO 70 I = 1, ML
|
|
IF( MV )THEN
|
|
WRITE( NOUT, FMT = 9998 )I, YT( I ),
|
|
$ YY( 1 + ( I - 1 )*ABS( INCY ) )
|
|
ELSE
|
|
WRITE( NOUT, FMT = 9998 )I,
|
|
$ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I )
|
|
END IF
|
|
70 CONTINUE
|
|
*
|
|
80 CONTINUE
|
|
RETURN
|
|
*
|
|
9999 FORMAT(' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
|
|
$ 'F ACCURATE *******', /' EXPECTED RE',
|
|
$ 'SULT COMPUTED RESULT' )
|
|
9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) )
|
|
*
|
|
* End of CMVCH.
|
|
*
|
|
END
|
|
LOGICAL FUNCTION LCE( RI, RJ, LR )
|
|
*
|
|
* Tests if two arrays are identical.
|
|
*
|
|
* 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.
|
|
*
|
|
* .. Scalar Arguments ..
|
|
INTEGER LR
|
|
* .. Array Arguments ..
|
|
COMPLEX RI( * ), RJ( * )
|
|
* .. Local Scalars ..
|
|
INTEGER I
|
|
* .. Executable Statements ..
|
|
DO 10 I = 1, LR
|
|
IF( RI( I ).NE.RJ( I ) )
|
|
$ GO TO 20
|
|
10 CONTINUE
|
|
LCE = .TRUE.
|
|
GO TO 30
|
|
20 CONTINUE
|
|
LCE = .FALSE.
|
|
30 RETURN
|
|
*
|
|
* End of LCE.
|
|
*
|
|
END
|
|
LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA )
|
|
*
|
|
* Tests if selected elements in two arrays are equal.
|
|
*
|
|
* TYPE is 'ge', 'he' or 'hp'.
|
|
*
|
|
* 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.
|
|
*
|
|
* .. Scalar Arguments ..
|
|
INTEGER LDA, M, N
|
|
CHARACTER*1 UPLO
|
|
CHARACTER*2 TYPE
|
|
* .. Array Arguments ..
|
|
COMPLEX AA( LDA, * ), AS( LDA, * )
|
|
* .. Local Scalars ..
|
|
INTEGER I, IBEG, IEND, J
|
|
LOGICAL UPPER
|
|
* .. Executable Statements ..
|
|
UPPER = UPLO.EQ.'U'
|
|
IF( TYPE.EQ.'ge' )THEN
|
|
DO 20 J = 1, N
|
|
DO 10 I = M + 1, LDA
|
|
IF( AA( I, J ).NE.AS( I, J ) )
|
|
$ GO TO 70
|
|
10 CONTINUE
|
|
20 CONTINUE
|
|
ELSE IF( TYPE.EQ.'he' )THEN
|
|
DO 50 J = 1, N
|
|
IF( UPPER )THEN
|
|
IBEG = 1
|
|
IEND = J
|
|
ELSE
|
|
IBEG = J
|
|
IEND = N
|
|
END IF
|
|
DO 30 I = 1, IBEG - 1
|
|
IF( AA( I, J ).NE.AS( I, J ) )
|
|
$ GO TO 70
|
|
30 CONTINUE
|
|
DO 40 I = IEND + 1, LDA
|
|
IF( AA( I, J ).NE.AS( I, J ) )
|
|
$ GO TO 70
|
|
40 CONTINUE
|
|
50 CONTINUE
|
|
END IF
|
|
*
|
|
60 CONTINUE
|
|
LCERES = .TRUE.
|
|
GO TO 80
|
|
70 CONTINUE
|
|
LCERES = .FALSE.
|
|
80 RETURN
|
|
*
|
|
* End of LCERES.
|
|
*
|
|
END
|
|
COMPLEX FUNCTION CBEG( RESET )
|
|
*
|
|
* Generates complex numbers as pairs of random numbers uniformly
|
|
* distributed between -0.5 and 0.5.
|
|
*
|
|
* 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.
|
|
*
|
|
* .. Scalar Arguments ..
|
|
LOGICAL RESET
|
|
* .. Local Scalars ..
|
|
INTEGER I, IC, J, MI, MJ
|
|
* .. Save statement ..
|
|
SAVE I, IC, J, MI, MJ
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC CMPLX
|
|
* .. Executable Statements ..
|
|
IF( RESET )THEN
|
|
* Initialize local variables.
|
|
MI = 891
|
|
MJ = 457
|
|
I = 7
|
|
J = 7
|
|
IC = 0
|
|
RESET = .FALSE.
|
|
END IF
|
|
*
|
|
* The sequence of values of I or J is bounded between 1 and 999.
|
|
* If initial I or J = 1,2,3,6,7 or 9, the period will be 50.
|
|
* If initial I or J = 4 or 8, the period will be 25.
|
|
* If initial I or J = 5, the period will be 10.
|
|
* IC is used to break up the period by skipping 1 value of I or J
|
|
* in 6.
|
|
*
|
|
IC = IC + 1
|
|
10 I = I*MI
|
|
J = J*MJ
|
|
I = I - 1000*( I/1000 )
|
|
J = J - 1000*( J/1000 )
|
|
IF( IC.GE.5 )THEN
|
|
IC = 0
|
|
GO TO 10
|
|
END IF
|
|
CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 )
|
|
RETURN
|
|
*
|
|
* End of CBEG.
|
|
*
|
|
END
|
|
REAL FUNCTION SDIFF( X, Y )
|
|
*
|
|
* Auxiliary routine for test program for Level 2 Blas.
|
|
*
|
|
* -- Written on 10-August-1987.
|
|
* Richard Hanson, Sandia National Labs.
|
|
*
|
|
* .. Scalar Arguments ..
|
|
REAL X, Y
|
|
* .. Executable Statements ..
|
|
SDIFF = X - Y
|
|
RETURN
|
|
*
|
|
* End of SDIFF.
|
|
*
|
|
END
|
|
SUBROUTINE CMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
|
|
$ KU, RESET, TRANSL )
|
|
*
|
|
* Generates values for an M by N matrix A within the bandwidth
|
|
* defined by KL and KU.
|
|
* Stores the values in the array AA in the data structure required
|
|
* by the routine, with unwanted elements set to rogue value.
|
|
*
|
|
* TYPE is 'ge', 'gb', 'he', 'hb', 'hp', 'tr', 'tb' OR 'tp'.
|
|
*
|
|
* 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 ZERO, ONE
|
|
PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) )
|
|
COMPLEX ROGUE
|
|
PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) )
|
|
REAL RZERO
|
|
PARAMETER ( RZERO = 0.0 )
|
|
REAL RROGUE
|
|
PARAMETER ( RROGUE = -1.0E10 )
|
|
* .. Scalar Arguments ..
|
|
COMPLEX TRANSL
|
|
INTEGER KL, KU, LDA, M, N, NMAX
|
|
LOGICAL RESET
|
|
CHARACTER*1 DIAG, UPLO
|
|
CHARACTER*2 TYPE
|
|
* .. Array Arguments ..
|
|
COMPLEX A( NMAX, * ), AA( * )
|
|
* .. Local Scalars ..
|
|
INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK
|
|
LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
|
|
* .. External Functions ..
|
|
COMPLEX CBEG
|
|
EXTERNAL CBEG
|
|
* .. Intrinsic Functions ..
|
|
INTRINSIC CMPLX, CONJG, MAX, MIN, REAL
|
|
* .. Executable Statements ..
|
|
GEN = TYPE( 1: 1 ).EQ.'g'
|
|
SYM = TYPE( 1: 1 ).EQ.'h'
|
|
TRI = TYPE( 1: 1 ).EQ.'t'
|
|
UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
|
|
LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
|
|
UNIT = TRI.AND.DIAG.EQ.'U'
|
|
*
|
|
* Generate data in array A.
|
|
*
|
|
DO 20 J = 1, N
|
|
DO 10 I = 1, M
|
|
IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
|
|
$ THEN
|
|
IF( ( I.LE.J.AND.J - I.LE.KU ).OR.
|
|
$ ( I.GE.J.AND.I - J.LE.KL ) )THEN
|
|
A( I, J ) = CBEG( RESET ) + TRANSL
|
|
ELSE
|
|
A( I, J ) = ZERO
|
|
END IF
|
|
IF( I.NE.J )THEN
|
|
IF( SYM )THEN
|
|
A( J, I ) = CONJG( A( I, J ) )
|
|
ELSE IF( TRI )THEN
|
|
A( J, I ) = ZERO
|
|
END IF
|
|
END IF
|
|
END IF
|
|
10 CONTINUE
|
|
IF( SYM )
|
|
$ A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO )
|
|
IF( TRI )
|
|
$ A( J, J ) = A( J, J ) + ONE
|
|
IF( UNIT )
|
|
$ A( J, J ) = ONE
|
|
20 CONTINUE
|
|
*
|
|
* Store elements in array AS in data structure required by routine.
|
|
*
|
|
IF( TYPE.EQ.'ge' )THEN
|
|
DO 50 J = 1, N
|
|
DO 30 I = 1, M
|
|
AA( I + ( J - 1 )*LDA ) = A( I, J )
|
|
30 CONTINUE
|
|
DO 40 I = M + 1, LDA
|
|
AA( I + ( J - 1 )*LDA ) = ROGUE
|
|
40 CONTINUE
|
|
50 CONTINUE
|
|
ELSE IF( TYPE.EQ.'gb' )THEN
|
|
DO 90 J = 1, N
|
|
DO 60 I1 = 1, KU + 1 - J
|
|
AA( I1 + ( J - 1 )*LDA ) = ROGUE
|
|
60 CONTINUE
|
|
DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J )
|
|
AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J )
|
|
70 CONTINUE
|
|
DO 80 I3 = I2, LDA
|
|
AA( I3 + ( J - 1 )*LDA ) = ROGUE
|
|
80 CONTINUE
|
|
90 CONTINUE
|
|
ELSE IF( TYPE.EQ.'he'.OR.TYPE.EQ.'tr' )THEN
|
|
DO 130 J = 1, N
|
|
IF( UPPER )THEN
|
|
IBEG = 1
|
|
IF( UNIT )THEN
|
|
IEND = J - 1
|
|
ELSE
|
|
IEND = J
|
|
END IF
|
|
ELSE
|
|
IF( UNIT )THEN
|
|
IBEG = J + 1
|
|
ELSE
|
|
IBEG = J
|
|
END IF
|
|
IEND = N
|
|
END IF
|
|
DO 100 I = 1, IBEG - 1
|
|
AA( I + ( J - 1 )*LDA ) = ROGUE
|
|
100 CONTINUE
|
|
DO 110 I = IBEG, IEND
|
|
AA( I + ( J - 1 )*LDA ) = A( I, J )
|
|
110 CONTINUE
|
|
DO 120 I = IEND + 1, LDA
|
|
AA( I + ( J - 1 )*LDA ) = ROGUE
|
|
120 CONTINUE
|
|
IF( SYM )THEN
|
|
JJ = J + ( J - 1 )*LDA
|
|
AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE )
|
|
END IF
|
|
130 CONTINUE
|
|
ELSE IF( TYPE.EQ.'hb'.OR.TYPE.EQ.'tb' )THEN
|
|
DO 170 J = 1, N
|
|
IF( UPPER )THEN
|
|
KK = KL + 1
|
|
IBEG = MAX( 1, KL + 2 - J )
|
|
IF( UNIT )THEN
|
|
IEND = KL
|
|
ELSE
|
|
IEND = KL + 1
|
|
END IF
|
|
ELSE
|
|
KK = 1
|
|
IF( UNIT )THEN
|
|
IBEG = 2
|
|
ELSE
|
|
IBEG = 1
|
|
END IF
|
|
IEND = MIN( KL + 1, 1 + M - J )
|
|
END IF
|
|
DO 140 I = 1, IBEG - 1
|
|
AA( I + ( J - 1 )*LDA ) = ROGUE
|
|
140 CONTINUE
|
|
DO 150 I = IBEG, IEND
|
|
AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
|
|
150 CONTINUE
|
|
DO 160 I = IEND + 1, LDA
|
|
AA( I + ( J - 1 )*LDA ) = ROGUE
|
|
160 CONTINUE
|
|
IF( SYM )THEN
|
|
JJ = KK + ( J - 1 )*LDA
|
|
AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE )
|
|
END IF
|
|
170 CONTINUE
|
|
ELSE IF( TYPE.EQ.'hp'.OR.TYPE.EQ.'tp' )THEN
|
|
IOFF = 0
|
|
DO 190 J = 1, N
|
|
IF( UPPER )THEN
|
|
IBEG = 1
|
|
IEND = J
|
|
ELSE
|
|
IBEG = J
|
|
IEND = N
|
|
END IF
|
|
DO 180 I = IBEG, IEND
|
|
IOFF = IOFF + 1
|
|
AA( IOFF ) = A( I, J )
|
|
IF( I.EQ.J )THEN
|
|
IF( UNIT )
|
|
$ AA( IOFF ) = ROGUE
|
|
IF( SYM )
|
|
$ AA( IOFF ) = CMPLX( REAL( AA( IOFF ) ), RROGUE )
|
|
END IF
|
|
180 CONTINUE
|
|
190 CONTINUE
|
|
END IF
|
|
RETURN
|
|
*
|
|
* End of CMAKE.
|
|
*
|
|
END
|