1*bf2c3715SXin Li*> \brief \b CBLAT2 2*bf2c3715SXin Li* 3*bf2c3715SXin Li* =========== DOCUMENTATION =========== 4*bf2c3715SXin Li* 5*bf2c3715SXin Li* Online html documentation available at 6*bf2c3715SXin Li* http://www.netlib.org/lapack/explore-html/ 7*bf2c3715SXin Li* 8*bf2c3715SXin Li* Definition: 9*bf2c3715SXin Li* =========== 10*bf2c3715SXin Li* 11*bf2c3715SXin Li* PROGRAM CBLAT2 12*bf2c3715SXin Li* 13*bf2c3715SXin Li* 14*bf2c3715SXin Li*> \par Purpose: 15*bf2c3715SXin Li* ============= 16*bf2c3715SXin Li*> 17*bf2c3715SXin Li*> \verbatim 18*bf2c3715SXin Li*> 19*bf2c3715SXin Li*> Test program for the COMPLEX Level 2 Blas. 20*bf2c3715SXin Li*> 21*bf2c3715SXin Li*> The program must be driven by a short data file. The first 18 records 22*bf2c3715SXin Li*> of the file are read using list-directed input, the last 17 records 23*bf2c3715SXin Li*> are read using the format ( A6, L2 ). An annotated example of a data 24*bf2c3715SXin Li*> file can be obtained by deleting the first 3 characters from the 25*bf2c3715SXin Li*> following 35 lines: 26*bf2c3715SXin Li*> 'cblat2.out' NAME OF SUMMARY OUTPUT FILE 27*bf2c3715SXin Li*> 6 UNIT NUMBER OF SUMMARY FILE 28*bf2c3715SXin Li*> 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE 29*bf2c3715SXin Li*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) 30*bf2c3715SXin Li*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. 31*bf2c3715SXin Li*> F LOGICAL FLAG, T TO STOP ON FAILURES. 32*bf2c3715SXin Li*> T LOGICAL FLAG, T TO TEST ERROR EXITS. 33*bf2c3715SXin Li*> 16.0 THRESHOLD VALUE OF TEST RATIO 34*bf2c3715SXin Li*> 6 NUMBER OF VALUES OF N 35*bf2c3715SXin Li*> 0 1 2 3 5 9 VALUES OF N 36*bf2c3715SXin Li*> 4 NUMBER OF VALUES OF K 37*bf2c3715SXin Li*> 0 1 2 4 VALUES OF K 38*bf2c3715SXin Li*> 4 NUMBER OF VALUES OF INCX AND INCY 39*bf2c3715SXin Li*> 1 2 -1 -2 VALUES OF INCX AND INCY 40*bf2c3715SXin Li*> 3 NUMBER OF VALUES OF ALPHA 41*bf2c3715SXin Li*> (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA 42*bf2c3715SXin Li*> 3 NUMBER OF VALUES OF BETA 43*bf2c3715SXin Li*> (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA 44*bf2c3715SXin Li*> CGEMV T PUT F FOR NO TEST. SAME COLUMNS. 45*bf2c3715SXin Li*> CGBMV T PUT F FOR NO TEST. SAME COLUMNS. 46*bf2c3715SXin Li*> CHEMV T PUT F FOR NO TEST. SAME COLUMNS. 47*bf2c3715SXin Li*> CHBMV T PUT F FOR NO TEST. SAME COLUMNS. 48*bf2c3715SXin Li*> CHPMV T PUT F FOR NO TEST. SAME COLUMNS. 49*bf2c3715SXin Li*> CTRMV T PUT F FOR NO TEST. SAME COLUMNS. 50*bf2c3715SXin Li*> CTBMV T PUT F FOR NO TEST. SAME COLUMNS. 51*bf2c3715SXin Li*> CTPMV T PUT F FOR NO TEST. SAME COLUMNS. 52*bf2c3715SXin Li*> CTRSV T PUT F FOR NO TEST. SAME COLUMNS. 53*bf2c3715SXin Li*> CTBSV T PUT F FOR NO TEST. SAME COLUMNS. 54*bf2c3715SXin Li*> CTPSV T PUT F FOR NO TEST. SAME COLUMNS. 55*bf2c3715SXin Li*> CGERC T PUT F FOR NO TEST. SAME COLUMNS. 56*bf2c3715SXin Li*> CGERU T PUT F FOR NO TEST. SAME COLUMNS. 57*bf2c3715SXin Li*> CHER T PUT F FOR NO TEST. SAME COLUMNS. 58*bf2c3715SXin Li*> CHPR T PUT F FOR NO TEST. SAME COLUMNS. 59*bf2c3715SXin Li*> CHER2 T PUT F FOR NO TEST. SAME COLUMNS. 60*bf2c3715SXin Li*> CHPR2 T PUT F FOR NO TEST. SAME COLUMNS. 61*bf2c3715SXin Li*> 62*bf2c3715SXin Li*> Further Details 63*bf2c3715SXin Li*> =============== 64*bf2c3715SXin Li*> 65*bf2c3715SXin Li*> See: 66*bf2c3715SXin Li*> 67*bf2c3715SXin Li*> Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. 68*bf2c3715SXin Li*> An extended set of Fortran Basic Linear Algebra Subprograms. 69*bf2c3715SXin Li*> 70*bf2c3715SXin Li*> Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics 71*bf2c3715SXin Li*> and Computer Science Division, Argonne National Laboratory, 72*bf2c3715SXin Li*> 9700 South Cass Avenue, Argonne, Illinois 60439, US. 73*bf2c3715SXin Li*> 74*bf2c3715SXin Li*> Or 75*bf2c3715SXin Li*> 76*bf2c3715SXin Li*> NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms 77*bf2c3715SXin Li*> Group Ltd., NAG Central Office, 256 Banbury Road, Oxford 78*bf2c3715SXin Li*> OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st 79*bf2c3715SXin Li*> Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. 80*bf2c3715SXin Li*> 81*bf2c3715SXin Li*> 82*bf2c3715SXin Li*> -- Written on 10-August-1987. 83*bf2c3715SXin Li*> Richard Hanson, Sandia National Labs. 84*bf2c3715SXin Li*> Jeremy Du Croz, NAG Central Office. 85*bf2c3715SXin Li*> 86*bf2c3715SXin Li*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers 87*bf2c3715SXin Li*> can be run multiple times without deleting generated 88*bf2c3715SXin Li*> output files (susan) 89*bf2c3715SXin Li*> \endverbatim 90*bf2c3715SXin Li* 91*bf2c3715SXin Li* Authors: 92*bf2c3715SXin Li* ======== 93*bf2c3715SXin Li* 94*bf2c3715SXin Li*> \author Univ. of Tennessee 95*bf2c3715SXin Li*> \author Univ. of California Berkeley 96*bf2c3715SXin Li*> \author Univ. of Colorado Denver 97*bf2c3715SXin Li*> \author NAG Ltd. 98*bf2c3715SXin Li* 99*bf2c3715SXin Li*> \date April 2012 100*bf2c3715SXin Li* 101*bf2c3715SXin Li*> \ingroup complex_blas_testing 102*bf2c3715SXin Li* 103*bf2c3715SXin Li* ===================================================================== 104*bf2c3715SXin Li PROGRAM CBLAT2 105*bf2c3715SXin Li* 106*bf2c3715SXin Li* -- Reference BLAS test routine (version 3.4.1) -- 107*bf2c3715SXin Li* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 108*bf2c3715SXin Li* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 109*bf2c3715SXin Li* April 2012 110*bf2c3715SXin Li* 111*bf2c3715SXin Li* ===================================================================== 112*bf2c3715SXin Li* 113*bf2c3715SXin Li* .. Parameters .. 114*bf2c3715SXin Li INTEGER NIN 115*bf2c3715SXin Li PARAMETER ( NIN = 5 ) 116*bf2c3715SXin Li INTEGER NSUBS 117*bf2c3715SXin Li PARAMETER ( NSUBS = 17 ) 118*bf2c3715SXin Li COMPLEX ZERO, ONE 119*bf2c3715SXin Li PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) 120*bf2c3715SXin Li REAL RZERO 121*bf2c3715SXin Li PARAMETER ( RZERO = 0.0 ) 122*bf2c3715SXin Li INTEGER NMAX, INCMAX 123*bf2c3715SXin Li PARAMETER ( NMAX = 65, INCMAX = 2 ) 124*bf2c3715SXin Li INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX 125*bf2c3715SXin Li PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7, 126*bf2c3715SXin Li $ NALMAX = 7, NBEMAX = 7 ) 127*bf2c3715SXin Li* .. Local Scalars .. 128*bf2c3715SXin Li REAL EPS, ERR, THRESH 129*bf2c3715SXin Li INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB, 130*bf2c3715SXin Li $ NOUT, NTRA 131*bf2c3715SXin Li LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, 132*bf2c3715SXin Li $ TSTERR 133*bf2c3715SXin Li CHARACTER*1 TRANS 134*bf2c3715SXin Li CHARACTER*6 SNAMET 135*bf2c3715SXin Li CHARACTER*32 SNAPS, SUMMRY 136*bf2c3715SXin Li* .. Local Arrays .. 137*bf2c3715SXin Li COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), 138*bf2c3715SXin Li $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ), 139*bf2c3715SXin Li $ X( NMAX ), XS( NMAX*INCMAX ), 140*bf2c3715SXin Li $ XX( NMAX*INCMAX ), Y( NMAX ), 141*bf2c3715SXin Li $ YS( NMAX*INCMAX ), YT( NMAX ), 142*bf2c3715SXin Li $ YY( NMAX*INCMAX ), Z( 2*NMAX ) 143*bf2c3715SXin Li REAL G( NMAX ) 144*bf2c3715SXin Li INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX ) 145*bf2c3715SXin Li LOGICAL LTEST( NSUBS ) 146*bf2c3715SXin Li CHARACTER*6 SNAMES( NSUBS ) 147*bf2c3715SXin Li* .. External Functions .. 148*bf2c3715SXin Li REAL SDIFF 149*bf2c3715SXin Li LOGICAL LCE 150*bf2c3715SXin Li EXTERNAL SDIFF, LCE 151*bf2c3715SXin Li* .. External Subroutines .. 152*bf2c3715SXin Li EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6, 153*bf2c3715SXin Li $ CCHKE, CMVCH 154*bf2c3715SXin Li* .. Intrinsic Functions .. 155*bf2c3715SXin Li INTRINSIC ABS, MAX, MIN 156*bf2c3715SXin Li* .. Scalars in Common .. 157*bf2c3715SXin Li INTEGER INFOT, NOUTC 158*bf2c3715SXin Li LOGICAL LERR, OK 159*bf2c3715SXin Li CHARACTER*6 SRNAMT 160*bf2c3715SXin Li* .. Common blocks .. 161*bf2c3715SXin Li COMMON /INFOC/INFOT, NOUTC, OK, LERR 162*bf2c3715SXin Li COMMON /SRNAMC/SRNAMT 163*bf2c3715SXin Li* .. Data statements .. 164*bf2c3715SXin Li DATA SNAMES/'CGEMV ', 'CGBMV ', 'CHEMV ', 'CHBMV ', 165*bf2c3715SXin Li $ 'CHPMV ', 'CTRMV ', 'CTBMV ', 'CTPMV ', 166*bf2c3715SXin Li $ 'CTRSV ', 'CTBSV ', 'CTPSV ', 'CGERC ', 167*bf2c3715SXin Li $ 'CGERU ', 'CHER ', 'CHPR ', 'CHER2 ', 168*bf2c3715SXin Li $ 'CHPR2 '/ 169*bf2c3715SXin Li* .. Executable Statements .. 170*bf2c3715SXin Li* 171*bf2c3715SXin Li* Read name and unit number for summary output file and open file. 172*bf2c3715SXin Li* 173*bf2c3715SXin Li READ( NIN, FMT = * )SUMMRY 174*bf2c3715SXin Li READ( NIN, FMT = * )NOUT 175*bf2c3715SXin Li OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) 176*bf2c3715SXin Li NOUTC = NOUT 177*bf2c3715SXin Li* 178*bf2c3715SXin Li* Read name and unit number for snapshot output file and open file. 179*bf2c3715SXin Li* 180*bf2c3715SXin Li READ( NIN, FMT = * )SNAPS 181*bf2c3715SXin Li READ( NIN, FMT = * )NTRA 182*bf2c3715SXin Li TRACE = NTRA.GE.0 183*bf2c3715SXin Li IF( TRACE )THEN 184*bf2c3715SXin Li OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' ) 185*bf2c3715SXin Li END IF 186*bf2c3715SXin Li* Read the flag that directs rewinding of the snapshot file. 187*bf2c3715SXin Li READ( NIN, FMT = * )REWI 188*bf2c3715SXin Li REWI = REWI.AND.TRACE 189*bf2c3715SXin Li* Read the flag that directs stopping on any failure. 190*bf2c3715SXin Li READ( NIN, FMT = * )SFATAL 191*bf2c3715SXin Li* Read the flag that indicates whether error exits are to be tested. 192*bf2c3715SXin Li READ( NIN, FMT = * )TSTERR 193*bf2c3715SXin Li* Read the threshold value of the test ratio 194*bf2c3715SXin Li READ( NIN, FMT = * )THRESH 195*bf2c3715SXin Li* 196*bf2c3715SXin Li* Read and check the parameter values for the tests. 197*bf2c3715SXin Li* 198*bf2c3715SXin Li* Values of N 199*bf2c3715SXin Li READ( NIN, FMT = * )NIDIM 200*bf2c3715SXin Li IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN 201*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )'N', NIDMAX 202*bf2c3715SXin Li GO TO 230 203*bf2c3715SXin Li END IF 204*bf2c3715SXin Li READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) 205*bf2c3715SXin Li DO 10 I = 1, NIDIM 206*bf2c3715SXin Li IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN 207*bf2c3715SXin Li WRITE( NOUT, FMT = 9996 )NMAX 208*bf2c3715SXin Li GO TO 230 209*bf2c3715SXin Li END IF 210*bf2c3715SXin Li 10 CONTINUE 211*bf2c3715SXin Li* Values of K 212*bf2c3715SXin Li READ( NIN, FMT = * )NKB 213*bf2c3715SXin Li IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN 214*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )'K', NKBMAX 215*bf2c3715SXin Li GO TO 230 216*bf2c3715SXin Li END IF 217*bf2c3715SXin Li READ( NIN, FMT = * )( KB( I ), I = 1, NKB ) 218*bf2c3715SXin Li DO 20 I = 1, NKB 219*bf2c3715SXin Li IF( KB( I ).LT.0 )THEN 220*bf2c3715SXin Li WRITE( NOUT, FMT = 9995 ) 221*bf2c3715SXin Li GO TO 230 222*bf2c3715SXin Li END IF 223*bf2c3715SXin Li 20 CONTINUE 224*bf2c3715SXin Li* Values of INCX and INCY 225*bf2c3715SXin Li READ( NIN, FMT = * )NINC 226*bf2c3715SXin Li IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN 227*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX 228*bf2c3715SXin Li GO TO 230 229*bf2c3715SXin Li END IF 230*bf2c3715SXin Li READ( NIN, FMT = * )( INC( I ), I = 1, NINC ) 231*bf2c3715SXin Li DO 30 I = 1, NINC 232*bf2c3715SXin Li IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN 233*bf2c3715SXin Li WRITE( NOUT, FMT = 9994 )INCMAX 234*bf2c3715SXin Li GO TO 230 235*bf2c3715SXin Li END IF 236*bf2c3715SXin Li 30 CONTINUE 237*bf2c3715SXin Li* Values of ALPHA 238*bf2c3715SXin Li READ( NIN, FMT = * )NALF 239*bf2c3715SXin Li IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN 240*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX 241*bf2c3715SXin Li GO TO 230 242*bf2c3715SXin Li END IF 243*bf2c3715SXin Li READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) 244*bf2c3715SXin Li* Values of BETA 245*bf2c3715SXin Li READ( NIN, FMT = * )NBET 246*bf2c3715SXin Li IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN 247*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX 248*bf2c3715SXin Li GO TO 230 249*bf2c3715SXin Li END IF 250*bf2c3715SXin Li READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) 251*bf2c3715SXin Li* 252*bf2c3715SXin Li* Report values of parameters. 253*bf2c3715SXin Li* 254*bf2c3715SXin Li WRITE( NOUT, FMT = 9993 ) 255*bf2c3715SXin Li WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM ) 256*bf2c3715SXin Li WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB ) 257*bf2c3715SXin Li WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC ) 258*bf2c3715SXin Li WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF ) 259*bf2c3715SXin Li WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET ) 260*bf2c3715SXin Li IF( .NOT.TSTERR )THEN 261*bf2c3715SXin Li WRITE( NOUT, FMT = * ) 262*bf2c3715SXin Li WRITE( NOUT, FMT = 9980 ) 263*bf2c3715SXin Li END IF 264*bf2c3715SXin Li WRITE( NOUT, FMT = * ) 265*bf2c3715SXin Li WRITE( NOUT, FMT = 9999 )THRESH 266*bf2c3715SXin Li WRITE( NOUT, FMT = * ) 267*bf2c3715SXin Li* 268*bf2c3715SXin Li* Read names of subroutines and flags which indicate 269*bf2c3715SXin Li* whether they are to be tested. 270*bf2c3715SXin Li* 271*bf2c3715SXin Li DO 40 I = 1, NSUBS 272*bf2c3715SXin Li LTEST( I ) = .FALSE. 273*bf2c3715SXin Li 40 CONTINUE 274*bf2c3715SXin Li 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT 275*bf2c3715SXin Li DO 60 I = 1, NSUBS 276*bf2c3715SXin Li IF( SNAMET.EQ.SNAMES( I ) ) 277*bf2c3715SXin Li $ GO TO 70 278*bf2c3715SXin Li 60 CONTINUE 279*bf2c3715SXin Li WRITE( NOUT, FMT = 9986 )SNAMET 280*bf2c3715SXin Li STOP 281*bf2c3715SXin Li 70 LTEST( I ) = LTESTT 282*bf2c3715SXin Li GO TO 50 283*bf2c3715SXin Li* 284*bf2c3715SXin Li 80 CONTINUE 285*bf2c3715SXin Li CLOSE ( NIN ) 286*bf2c3715SXin Li* 287*bf2c3715SXin Li* Compute EPS (the machine precision). 288*bf2c3715SXin Li* 289*bf2c3715SXin Li EPS = EPSILON(RZERO) 290*bf2c3715SXin Li WRITE( NOUT, FMT = 9998 )EPS 291*bf2c3715SXin Li* 292*bf2c3715SXin Li* Check the reliability of CMVCH using exact data. 293*bf2c3715SXin Li* 294*bf2c3715SXin Li N = MIN( 32, NMAX ) 295*bf2c3715SXin Li DO 120 J = 1, N 296*bf2c3715SXin Li DO 110 I = 1, N 297*bf2c3715SXin Li A( I, J ) = MAX( I - J + 1, 0 ) 298*bf2c3715SXin Li 110 CONTINUE 299*bf2c3715SXin Li X( J ) = J 300*bf2c3715SXin Li Y( J ) = ZERO 301*bf2c3715SXin Li 120 CONTINUE 302*bf2c3715SXin Li DO 130 J = 1, N 303*bf2c3715SXin Li YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 304*bf2c3715SXin Li 130 CONTINUE 305*bf2c3715SXin Li* YY holds the exact result. On exit from CMVCH YT holds 306*bf2c3715SXin Li* the result computed by CMVCH. 307*bf2c3715SXin Li TRANS = 'N' 308*bf2c3715SXin Li CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, 309*bf2c3715SXin Li $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) 310*bf2c3715SXin Li SAME = LCE( YY, YT, N ) 311*bf2c3715SXin Li IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN 312*bf2c3715SXin Li WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR 313*bf2c3715SXin Li STOP 314*bf2c3715SXin Li END IF 315*bf2c3715SXin Li TRANS = 'T' 316*bf2c3715SXin Li CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, 317*bf2c3715SXin Li $ YY, EPS, ERR, FATAL, NOUT, .TRUE. ) 318*bf2c3715SXin Li SAME = LCE( YY, YT, N ) 319*bf2c3715SXin Li IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN 320*bf2c3715SXin Li WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR 321*bf2c3715SXin Li STOP 322*bf2c3715SXin Li END IF 323*bf2c3715SXin Li* 324*bf2c3715SXin Li* Test each subroutine in turn. 325*bf2c3715SXin Li* 326*bf2c3715SXin Li DO 210 ISNUM = 1, NSUBS 327*bf2c3715SXin Li WRITE( NOUT, FMT = * ) 328*bf2c3715SXin Li IF( .NOT.LTEST( ISNUM ) )THEN 329*bf2c3715SXin Li* Subprogram is not to be tested. 330*bf2c3715SXin Li WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM ) 331*bf2c3715SXin Li ELSE 332*bf2c3715SXin Li SRNAMT = SNAMES( ISNUM ) 333*bf2c3715SXin Li* Test error exits. 334*bf2c3715SXin Li IF( TSTERR )THEN 335*bf2c3715SXin Li CALL CCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) 336*bf2c3715SXin Li WRITE( NOUT, FMT = * ) 337*bf2c3715SXin Li END IF 338*bf2c3715SXin Li* Test computations. 339*bf2c3715SXin Li INFOT = 0 340*bf2c3715SXin Li OK = .TRUE. 341*bf2c3715SXin Li FATAL = .FALSE. 342*bf2c3715SXin Li GO TO ( 140, 140, 150, 150, 150, 160, 160, 343*bf2c3715SXin Li $ 160, 160, 160, 160, 170, 170, 180, 344*bf2c3715SXin Li $ 180, 190, 190 )ISNUM 345*bf2c3715SXin Li* Test CGEMV, 01, and CGBMV, 02. 346*bf2c3715SXin Li 140 CALL CCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 347*bf2c3715SXin Li $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, 348*bf2c3715SXin Li $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, 349*bf2c3715SXin Li $ X, XX, XS, Y, YY, YS, YT, G ) 350*bf2c3715SXin Li GO TO 200 351*bf2c3715SXin Li* Test CHEMV, 03, CHBMV, 04, and CHPMV, 05. 352*bf2c3715SXin Li 150 CALL CCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 353*bf2c3715SXin Li $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, 354*bf2c3715SXin Li $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, 355*bf2c3715SXin Li $ X, XX, XS, Y, YY, YS, YT, G ) 356*bf2c3715SXin Li GO TO 200 357*bf2c3715SXin Li* Test CTRMV, 06, CTBMV, 07, CTPMV, 08, 358*bf2c3715SXin Li* CTRSV, 09, CTBSV, 10, and CTPSV, 11. 359*bf2c3715SXin Li 160 CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 360*bf2c3715SXin Li $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, 361*bf2c3715SXin Li $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z ) 362*bf2c3715SXin Li GO TO 200 363*bf2c3715SXin Li* Test CGERC, 12, CGERU, 13. 364*bf2c3715SXin Li 170 CALL CCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 365*bf2c3715SXin Li $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, 366*bf2c3715SXin Li $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, 367*bf2c3715SXin Li $ YT, G, Z ) 368*bf2c3715SXin Li GO TO 200 369*bf2c3715SXin Li* Test CHER, 14, and CHPR, 15. 370*bf2c3715SXin Li 180 CALL CCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 371*bf2c3715SXin Li $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, 372*bf2c3715SXin Li $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, 373*bf2c3715SXin Li $ YT, G, Z ) 374*bf2c3715SXin Li GO TO 200 375*bf2c3715SXin Li* Test CHER2, 16, and CHPR2, 17. 376*bf2c3715SXin Li 190 CALL CCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, 377*bf2c3715SXin Li $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, 378*bf2c3715SXin Li $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, 379*bf2c3715SXin Li $ YT, G, Z ) 380*bf2c3715SXin Li* 381*bf2c3715SXin Li 200 IF( FATAL.AND.SFATAL ) 382*bf2c3715SXin Li $ GO TO 220 383*bf2c3715SXin Li END IF 384*bf2c3715SXin Li 210 CONTINUE 385*bf2c3715SXin Li WRITE( NOUT, FMT = 9982 ) 386*bf2c3715SXin Li GO TO 240 387*bf2c3715SXin Li* 388*bf2c3715SXin Li 220 CONTINUE 389*bf2c3715SXin Li WRITE( NOUT, FMT = 9981 ) 390*bf2c3715SXin Li GO TO 240 391*bf2c3715SXin Li* 392*bf2c3715SXin Li 230 CONTINUE 393*bf2c3715SXin Li WRITE( NOUT, FMT = 9987 ) 394*bf2c3715SXin Li* 395*bf2c3715SXin Li 240 CONTINUE 396*bf2c3715SXin Li IF( TRACE ) 397*bf2c3715SXin Li $ CLOSE ( NTRA ) 398*bf2c3715SXin Li CLOSE ( NOUT ) 399*bf2c3715SXin Li STOP 400*bf2c3715SXin Li* 401*bf2c3715SXin Li 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', 402*bf2c3715SXin Li $ 'S THAN', F8.2 ) 403*bf2c3715SXin Li 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) 404*bf2c3715SXin Li 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', 405*bf2c3715SXin Li $ 'THAN ', I2 ) 406*bf2c3715SXin Li 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) 407*bf2c3715SXin Li 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' ) 408*bf2c3715SXin Li 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ', 409*bf2c3715SXin Li $ I2 ) 410*bf2c3715SXin Li 9993 FORMAT( ' TESTS OF THE COMPLEX LEVEL 2 BLAS', //' THE F', 411*bf2c3715SXin Li $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 412*bf2c3715SXin Li 9992 FORMAT( ' FOR N ', 9I6 ) 413*bf2c3715SXin Li 9991 FORMAT( ' FOR K ', 7I6 ) 414*bf2c3715SXin Li 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 ) 415*bf2c3715SXin Li 9989 FORMAT( ' FOR ALPHA ', 416*bf2c3715SXin Li $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) 417*bf2c3715SXin Li 9988 FORMAT( ' FOR BETA ', 418*bf2c3715SXin Li $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) 419*bf2c3715SXin Li 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', 420*bf2c3715SXin Li $ /' ******* TESTS ABANDONED *******' ) 421*bf2c3715SXin Li 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', 422*bf2c3715SXin Li $ 'ESTS ABANDONED *******' ) 423*bf2c3715SXin Li 9985 FORMAT( ' ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', 424*bf2c3715SXin Li $ 'ATED WRONGLY.', /' CMVCH WAS CALLED WITH TRANS = ', A1, 425*bf2c3715SXin Li $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', / 426*bf2c3715SXin Li $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.' 427*bf2c3715SXin Li $ , /' ******* TESTS ABANDONED *******' ) 428*bf2c3715SXin Li 9984 FORMAT( A6, L2 ) 429*bf2c3715SXin Li 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' ) 430*bf2c3715SXin Li 9982 FORMAT( /' END OF TESTS' ) 431*bf2c3715SXin Li 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 432*bf2c3715SXin Li 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) 433*bf2c3715SXin Li* 434*bf2c3715SXin Li* End of CBLAT2. 435*bf2c3715SXin Li* 436*bf2c3715SXin Li END 437*bf2c3715SXin Li SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 438*bf2c3715SXin Li $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, 439*bf2c3715SXin Li $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, 440*bf2c3715SXin Li $ XS, Y, YY, YS, YT, G ) 441*bf2c3715SXin Li* 442*bf2c3715SXin Li* Tests CGEMV and CGBMV. 443*bf2c3715SXin Li* 444*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 445*bf2c3715SXin Li* 446*bf2c3715SXin Li* -- Written on 10-August-1987. 447*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 448*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 449*bf2c3715SXin Li* 450*bf2c3715SXin Li* .. Parameters .. 451*bf2c3715SXin Li COMPLEX ZERO, HALF 452*bf2c3715SXin Li PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) ) 453*bf2c3715SXin Li REAL RZERO 454*bf2c3715SXin Li PARAMETER ( RZERO = 0.0 ) 455*bf2c3715SXin Li* .. Scalar Arguments .. 456*bf2c3715SXin Li REAL EPS, THRESH 457*bf2c3715SXin Li INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, 458*bf2c3715SXin Li $ NOUT, NTRA 459*bf2c3715SXin Li LOGICAL FATAL, REWI, TRACE 460*bf2c3715SXin Li CHARACTER*6 SNAME 461*bf2c3715SXin Li* .. Array Arguments .. 462*bf2c3715SXin Li COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 463*bf2c3715SXin Li $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), 464*bf2c3715SXin Li $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), 465*bf2c3715SXin Li $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), 466*bf2c3715SXin Li $ YY( NMAX*INCMAX ) 467*bf2c3715SXin Li REAL G( NMAX ) 468*bf2c3715SXin Li INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) 469*bf2c3715SXin Li* .. Local Scalars .. 470*bf2c3715SXin Li COMPLEX ALPHA, ALS, BETA, BLS, TRANSL 471*bf2c3715SXin Li REAL ERR, ERRMAX 472*bf2c3715SXin Li INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY, 473*bf2c3715SXin Li $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA, 474*bf2c3715SXin Li $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK, 475*bf2c3715SXin Li $ NL, NS 476*bf2c3715SXin Li LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN 477*bf2c3715SXin Li CHARACTER*1 TRANS, TRANSS 478*bf2c3715SXin Li CHARACTER*3 ICH 479*bf2c3715SXin Li* .. Local Arrays .. 480*bf2c3715SXin Li LOGICAL ISAME( 13 ) 481*bf2c3715SXin Li* .. External Functions .. 482*bf2c3715SXin Li LOGICAL LCE, LCERES 483*bf2c3715SXin Li EXTERNAL LCE, LCERES 484*bf2c3715SXin Li* .. External Subroutines .. 485*bf2c3715SXin Li EXTERNAL CGBMV, CGEMV, CMAKE, CMVCH 486*bf2c3715SXin Li* .. Intrinsic Functions .. 487*bf2c3715SXin Li INTRINSIC ABS, MAX, MIN 488*bf2c3715SXin Li* .. Scalars in Common .. 489*bf2c3715SXin Li INTEGER INFOT, NOUTC 490*bf2c3715SXin Li LOGICAL LERR, OK 491*bf2c3715SXin Li* .. Common blocks .. 492*bf2c3715SXin Li COMMON /INFOC/INFOT, NOUTC, OK, LERR 493*bf2c3715SXin Li* .. Data statements .. 494*bf2c3715SXin Li DATA ICH/'NTC'/ 495*bf2c3715SXin Li* .. Executable Statements .. 496*bf2c3715SXin Li FULL = SNAME( 3: 3 ).EQ.'E' 497*bf2c3715SXin Li BANDED = SNAME( 3: 3 ).EQ.'B' 498*bf2c3715SXin Li* Define the number of arguments. 499*bf2c3715SXin Li IF( FULL )THEN 500*bf2c3715SXin Li NARGS = 11 501*bf2c3715SXin Li ELSE IF( BANDED )THEN 502*bf2c3715SXin Li NARGS = 13 503*bf2c3715SXin Li END IF 504*bf2c3715SXin Li* 505*bf2c3715SXin Li NC = 0 506*bf2c3715SXin Li RESET = .TRUE. 507*bf2c3715SXin Li ERRMAX = RZERO 508*bf2c3715SXin Li* 509*bf2c3715SXin Li DO 120 IN = 1, NIDIM 510*bf2c3715SXin Li N = IDIM( IN ) 511*bf2c3715SXin Li ND = N/2 + 1 512*bf2c3715SXin Li* 513*bf2c3715SXin Li DO 110 IM = 1, 2 514*bf2c3715SXin Li IF( IM.EQ.1 ) 515*bf2c3715SXin Li $ M = MAX( N - ND, 0 ) 516*bf2c3715SXin Li IF( IM.EQ.2 ) 517*bf2c3715SXin Li $ M = MIN( N + ND, NMAX ) 518*bf2c3715SXin Li* 519*bf2c3715SXin Li IF( BANDED )THEN 520*bf2c3715SXin Li NK = NKB 521*bf2c3715SXin Li ELSE 522*bf2c3715SXin Li NK = 1 523*bf2c3715SXin Li END IF 524*bf2c3715SXin Li DO 100 IKU = 1, NK 525*bf2c3715SXin Li IF( BANDED )THEN 526*bf2c3715SXin Li KU = KB( IKU ) 527*bf2c3715SXin Li KL = MAX( KU - 1, 0 ) 528*bf2c3715SXin Li ELSE 529*bf2c3715SXin Li KU = N - 1 530*bf2c3715SXin Li KL = M - 1 531*bf2c3715SXin Li END IF 532*bf2c3715SXin Li* Set LDA to 1 more than minimum value if room. 533*bf2c3715SXin Li IF( BANDED )THEN 534*bf2c3715SXin Li LDA = KL + KU + 1 535*bf2c3715SXin Li ELSE 536*bf2c3715SXin Li LDA = M 537*bf2c3715SXin Li END IF 538*bf2c3715SXin Li IF( LDA.LT.NMAX ) 539*bf2c3715SXin Li $ LDA = LDA + 1 540*bf2c3715SXin Li* Skip tests if not enough room. 541*bf2c3715SXin Li IF( LDA.GT.NMAX ) 542*bf2c3715SXin Li $ GO TO 100 543*bf2c3715SXin Li LAA = LDA*N 544*bf2c3715SXin Li NULL = N.LE.0.OR.M.LE.0 545*bf2c3715SXin Li* 546*bf2c3715SXin Li* Generate the matrix A. 547*bf2c3715SXin Li* 548*bf2c3715SXin Li TRANSL = ZERO 549*bf2c3715SXin Li CALL CMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA, 550*bf2c3715SXin Li $ LDA, KL, KU, RESET, TRANSL ) 551*bf2c3715SXin Li* 552*bf2c3715SXin Li DO 90 IC = 1, 3 553*bf2c3715SXin Li TRANS = ICH( IC: IC ) 554*bf2c3715SXin Li TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' 555*bf2c3715SXin Li* 556*bf2c3715SXin Li IF( TRAN )THEN 557*bf2c3715SXin Li ML = N 558*bf2c3715SXin Li NL = M 559*bf2c3715SXin Li ELSE 560*bf2c3715SXin Li ML = M 561*bf2c3715SXin Li NL = N 562*bf2c3715SXin Li END IF 563*bf2c3715SXin Li* 564*bf2c3715SXin Li DO 80 IX = 1, NINC 565*bf2c3715SXin Li INCX = INC( IX ) 566*bf2c3715SXin Li LX = ABS( INCX )*NL 567*bf2c3715SXin Li* 568*bf2c3715SXin Li* Generate the vector X. 569*bf2c3715SXin Li* 570*bf2c3715SXin Li TRANSL = HALF 571*bf2c3715SXin Li CALL CMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX, 572*bf2c3715SXin Li $ ABS( INCX ), 0, NL - 1, RESET, TRANSL ) 573*bf2c3715SXin Li IF( NL.GT.1 )THEN 574*bf2c3715SXin Li X( NL/2 ) = ZERO 575*bf2c3715SXin Li XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO 576*bf2c3715SXin Li END IF 577*bf2c3715SXin Li* 578*bf2c3715SXin Li DO 70 IY = 1, NINC 579*bf2c3715SXin Li INCY = INC( IY ) 580*bf2c3715SXin Li LY = ABS( INCY )*ML 581*bf2c3715SXin Li* 582*bf2c3715SXin Li DO 60 IA = 1, NALF 583*bf2c3715SXin Li ALPHA = ALF( IA ) 584*bf2c3715SXin Li* 585*bf2c3715SXin Li DO 50 IB = 1, NBET 586*bf2c3715SXin Li BETA = BET( IB ) 587*bf2c3715SXin Li* 588*bf2c3715SXin Li* Generate the vector Y. 589*bf2c3715SXin Li* 590*bf2c3715SXin Li TRANSL = ZERO 591*bf2c3715SXin Li CALL CMAKE( 'GE', ' ', ' ', 1, ML, Y, 1, 592*bf2c3715SXin Li $ YY, ABS( INCY ), 0, ML - 1, 593*bf2c3715SXin Li $ RESET, TRANSL ) 594*bf2c3715SXin Li* 595*bf2c3715SXin Li NC = NC + 1 596*bf2c3715SXin Li* 597*bf2c3715SXin Li* Save every datum before calling the 598*bf2c3715SXin Li* subroutine. 599*bf2c3715SXin Li* 600*bf2c3715SXin Li TRANSS = TRANS 601*bf2c3715SXin Li MS = M 602*bf2c3715SXin Li NS = N 603*bf2c3715SXin Li KLS = KL 604*bf2c3715SXin Li KUS = KU 605*bf2c3715SXin Li ALS = ALPHA 606*bf2c3715SXin Li DO 10 I = 1, LAA 607*bf2c3715SXin Li AS( I ) = AA( I ) 608*bf2c3715SXin Li 10 CONTINUE 609*bf2c3715SXin Li LDAS = LDA 610*bf2c3715SXin Li DO 20 I = 1, LX 611*bf2c3715SXin Li XS( I ) = XX( I ) 612*bf2c3715SXin Li 20 CONTINUE 613*bf2c3715SXin Li INCXS = INCX 614*bf2c3715SXin Li BLS = BETA 615*bf2c3715SXin Li DO 30 I = 1, LY 616*bf2c3715SXin Li YS( I ) = YY( I ) 617*bf2c3715SXin Li 30 CONTINUE 618*bf2c3715SXin Li INCYS = INCY 619*bf2c3715SXin Li* 620*bf2c3715SXin Li* Call the subroutine. 621*bf2c3715SXin Li* 622*bf2c3715SXin Li IF( FULL )THEN 623*bf2c3715SXin Li IF( TRACE ) 624*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 625*bf2c3715SXin Li $ TRANS, M, N, ALPHA, LDA, INCX, BETA, 626*bf2c3715SXin Li $ INCY 627*bf2c3715SXin Li IF( REWI ) 628*bf2c3715SXin Li $ REWIND NTRA 629*bf2c3715SXin Li CALL CGEMV( TRANS, M, N, ALPHA, AA, 630*bf2c3715SXin Li $ LDA, XX, INCX, BETA, YY, 631*bf2c3715SXin Li $ INCY ) 632*bf2c3715SXin Li ELSE IF( BANDED )THEN 633*bf2c3715SXin Li IF( TRACE ) 634*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 635*bf2c3715SXin Li $ TRANS, M, N, KL, KU, ALPHA, LDA, 636*bf2c3715SXin Li $ INCX, BETA, INCY 637*bf2c3715SXin Li IF( REWI ) 638*bf2c3715SXin Li $ REWIND NTRA 639*bf2c3715SXin Li CALL CGBMV( TRANS, M, N, KL, KU, ALPHA, 640*bf2c3715SXin Li $ AA, LDA, XX, INCX, BETA, 641*bf2c3715SXin Li $ YY, INCY ) 642*bf2c3715SXin Li END IF 643*bf2c3715SXin Li* 644*bf2c3715SXin Li* Check if error-exit was taken incorrectly. 645*bf2c3715SXin Li* 646*bf2c3715SXin Li IF( .NOT.OK )THEN 647*bf2c3715SXin Li WRITE( NOUT, FMT = 9993 ) 648*bf2c3715SXin Li FATAL = .TRUE. 649*bf2c3715SXin Li GO TO 130 650*bf2c3715SXin Li END IF 651*bf2c3715SXin Li* 652*bf2c3715SXin Li* See what data changed inside subroutines. 653*bf2c3715SXin Li* 654*bf2c3715SXin Li ISAME( 1 ) = TRANS.EQ.TRANSS 655*bf2c3715SXin Li ISAME( 2 ) = MS.EQ.M 656*bf2c3715SXin Li ISAME( 3 ) = NS.EQ.N 657*bf2c3715SXin Li IF( FULL )THEN 658*bf2c3715SXin Li ISAME( 4 ) = ALS.EQ.ALPHA 659*bf2c3715SXin Li ISAME( 5 ) = LCE( AS, AA, LAA ) 660*bf2c3715SXin Li ISAME( 6 ) = LDAS.EQ.LDA 661*bf2c3715SXin Li ISAME( 7 ) = LCE( XS, XX, LX ) 662*bf2c3715SXin Li ISAME( 8 ) = INCXS.EQ.INCX 663*bf2c3715SXin Li ISAME( 9 ) = BLS.EQ.BETA 664*bf2c3715SXin Li IF( NULL )THEN 665*bf2c3715SXin Li ISAME( 10 ) = LCE( YS, YY, LY ) 666*bf2c3715SXin Li ELSE 667*bf2c3715SXin Li ISAME( 10 ) = LCERES( 'GE', ' ', 1, 668*bf2c3715SXin Li $ ML, YS, YY, 669*bf2c3715SXin Li $ ABS( INCY ) ) 670*bf2c3715SXin Li END IF 671*bf2c3715SXin Li ISAME( 11 ) = INCYS.EQ.INCY 672*bf2c3715SXin Li ELSE IF( BANDED )THEN 673*bf2c3715SXin Li ISAME( 4 ) = KLS.EQ.KL 674*bf2c3715SXin Li ISAME( 5 ) = KUS.EQ.KU 675*bf2c3715SXin Li ISAME( 6 ) = ALS.EQ.ALPHA 676*bf2c3715SXin Li ISAME( 7 ) = LCE( AS, AA, LAA ) 677*bf2c3715SXin Li ISAME( 8 ) = LDAS.EQ.LDA 678*bf2c3715SXin Li ISAME( 9 ) = LCE( XS, XX, LX ) 679*bf2c3715SXin Li ISAME( 10 ) = INCXS.EQ.INCX 680*bf2c3715SXin Li ISAME( 11 ) = BLS.EQ.BETA 681*bf2c3715SXin Li IF( NULL )THEN 682*bf2c3715SXin Li ISAME( 12 ) = LCE( YS, YY, LY ) 683*bf2c3715SXin Li ELSE 684*bf2c3715SXin Li ISAME( 12 ) = LCERES( 'GE', ' ', 1, 685*bf2c3715SXin Li $ ML, YS, YY, 686*bf2c3715SXin Li $ ABS( INCY ) ) 687*bf2c3715SXin Li END IF 688*bf2c3715SXin Li ISAME( 13 ) = INCYS.EQ.INCY 689*bf2c3715SXin Li END IF 690*bf2c3715SXin Li* 691*bf2c3715SXin Li* If data was incorrectly changed, report 692*bf2c3715SXin Li* and return. 693*bf2c3715SXin Li* 694*bf2c3715SXin Li SAME = .TRUE. 695*bf2c3715SXin Li DO 40 I = 1, NARGS 696*bf2c3715SXin Li SAME = SAME.AND.ISAME( I ) 697*bf2c3715SXin Li IF( .NOT.ISAME( I ) ) 698*bf2c3715SXin Li $ WRITE( NOUT, FMT = 9998 )I 699*bf2c3715SXin Li 40 CONTINUE 700*bf2c3715SXin Li IF( .NOT.SAME )THEN 701*bf2c3715SXin Li FATAL = .TRUE. 702*bf2c3715SXin Li GO TO 130 703*bf2c3715SXin Li END IF 704*bf2c3715SXin Li* 705*bf2c3715SXin Li IF( .NOT.NULL )THEN 706*bf2c3715SXin Li* 707*bf2c3715SXin Li* Check the result. 708*bf2c3715SXin Li* 709*bf2c3715SXin Li CALL CMVCH( TRANS, M, N, ALPHA, A, 710*bf2c3715SXin Li $ NMAX, X, INCX, BETA, Y, 711*bf2c3715SXin Li $ INCY, YT, G, YY, EPS, ERR, 712*bf2c3715SXin Li $ FATAL, NOUT, .TRUE. ) 713*bf2c3715SXin Li ERRMAX = MAX( ERRMAX, ERR ) 714*bf2c3715SXin Li* If got really bad answer, report and 715*bf2c3715SXin Li* return. 716*bf2c3715SXin Li IF( FATAL ) 717*bf2c3715SXin Li $ GO TO 130 718*bf2c3715SXin Li ELSE 719*bf2c3715SXin Li* Avoid repeating tests with M.le.0 or 720*bf2c3715SXin Li* N.le.0. 721*bf2c3715SXin Li GO TO 110 722*bf2c3715SXin Li END IF 723*bf2c3715SXin Li* 724*bf2c3715SXin Li 50 CONTINUE 725*bf2c3715SXin Li* 726*bf2c3715SXin Li 60 CONTINUE 727*bf2c3715SXin Li* 728*bf2c3715SXin Li 70 CONTINUE 729*bf2c3715SXin Li* 730*bf2c3715SXin Li 80 CONTINUE 731*bf2c3715SXin Li* 732*bf2c3715SXin Li 90 CONTINUE 733*bf2c3715SXin Li* 734*bf2c3715SXin Li 100 CONTINUE 735*bf2c3715SXin Li* 736*bf2c3715SXin Li 110 CONTINUE 737*bf2c3715SXin Li* 738*bf2c3715SXin Li 120 CONTINUE 739*bf2c3715SXin Li* 740*bf2c3715SXin Li* Report result. 741*bf2c3715SXin Li* 742*bf2c3715SXin Li IF( ERRMAX.LT.THRESH )THEN 743*bf2c3715SXin Li WRITE( NOUT, FMT = 9999 )SNAME, NC 744*bf2c3715SXin Li ELSE 745*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 746*bf2c3715SXin Li END IF 747*bf2c3715SXin Li GO TO 140 748*bf2c3715SXin Li* 749*bf2c3715SXin Li 130 CONTINUE 750*bf2c3715SXin Li WRITE( NOUT, FMT = 9996 )SNAME 751*bf2c3715SXin Li IF( FULL )THEN 752*bf2c3715SXin Li WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA, 753*bf2c3715SXin Li $ INCX, BETA, INCY 754*bf2c3715SXin Li ELSE IF( BANDED )THEN 755*bf2c3715SXin Li WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU, 756*bf2c3715SXin Li $ ALPHA, LDA, INCX, BETA, INCY 757*bf2c3715SXin Li END IF 758*bf2c3715SXin Li* 759*bf2c3715SXin Li 140 CONTINUE 760*bf2c3715SXin Li RETURN 761*bf2c3715SXin Li* 762*bf2c3715SXin Li 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 763*bf2c3715SXin Li $ 'S)' ) 764*bf2c3715SXin Li 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 765*bf2c3715SXin Li $ 'ANGED INCORRECTLY *******' ) 766*bf2c3715SXin Li 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 767*bf2c3715SXin Li $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 768*bf2c3715SXin Li $ ' - SUSPECT *******' ) 769*bf2c3715SXin Li 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 770*bf2c3715SXin Li 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), '(', 771*bf2c3715SXin Li $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', 772*bf2c3715SXin Li $ F4.1, '), Y,', I2, ') .' ) 773*bf2c3715SXin Li 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', 774*bf2c3715SXin Li $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', 775*bf2c3715SXin Li $ F4.1, '), Y,', I2, ') .' ) 776*bf2c3715SXin Li 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 777*bf2c3715SXin Li $ '******' ) 778*bf2c3715SXin Li* 779*bf2c3715SXin Li* End of CCHK1. 780*bf2c3715SXin Li* 781*bf2c3715SXin Li END 782*bf2c3715SXin Li SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 783*bf2c3715SXin Li $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, 784*bf2c3715SXin Li $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, 785*bf2c3715SXin Li $ XS, Y, YY, YS, YT, G ) 786*bf2c3715SXin Li* 787*bf2c3715SXin Li* Tests CHEMV, CHBMV and CHPMV. 788*bf2c3715SXin Li* 789*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 790*bf2c3715SXin Li* 791*bf2c3715SXin Li* -- Written on 10-August-1987. 792*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 793*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 794*bf2c3715SXin Li* 795*bf2c3715SXin Li* .. Parameters .. 796*bf2c3715SXin Li COMPLEX ZERO, HALF 797*bf2c3715SXin Li PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ) ) 798*bf2c3715SXin Li REAL RZERO 799*bf2c3715SXin Li PARAMETER ( RZERO = 0.0 ) 800*bf2c3715SXin Li* .. Scalar Arguments .. 801*bf2c3715SXin Li REAL EPS, THRESH 802*bf2c3715SXin Li INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX, 803*bf2c3715SXin Li $ NOUT, NTRA 804*bf2c3715SXin Li LOGICAL FATAL, REWI, TRACE 805*bf2c3715SXin Li CHARACTER*6 SNAME 806*bf2c3715SXin Li* .. Array Arguments .. 807*bf2c3715SXin Li COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 808*bf2c3715SXin Li $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ), 809*bf2c3715SXin Li $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), 810*bf2c3715SXin Li $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), 811*bf2c3715SXin Li $ YY( NMAX*INCMAX ) 812*bf2c3715SXin Li REAL G( NMAX ) 813*bf2c3715SXin Li INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) 814*bf2c3715SXin Li* .. Local Scalars .. 815*bf2c3715SXin Li COMPLEX ALPHA, ALS, BETA, BLS, TRANSL 816*bf2c3715SXin Li REAL ERR, ERRMAX 817*bf2c3715SXin Li INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, 818*bf2c3715SXin Li $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, 819*bf2c3715SXin Li $ N, NARGS, NC, NK, NS 820*bf2c3715SXin Li LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME 821*bf2c3715SXin Li CHARACTER*1 UPLO, UPLOS 822*bf2c3715SXin Li CHARACTER*2 ICH 823*bf2c3715SXin Li* .. Local Arrays .. 824*bf2c3715SXin Li LOGICAL ISAME( 13 ) 825*bf2c3715SXin Li* .. External Functions .. 826*bf2c3715SXin Li LOGICAL LCE, LCERES 827*bf2c3715SXin Li EXTERNAL LCE, LCERES 828*bf2c3715SXin Li* .. External Subroutines .. 829*bf2c3715SXin Li EXTERNAL CHBMV, CHEMV, CHPMV, CMAKE, CMVCH 830*bf2c3715SXin Li* .. Intrinsic Functions .. 831*bf2c3715SXin Li INTRINSIC ABS, MAX 832*bf2c3715SXin Li* .. Scalars in Common .. 833*bf2c3715SXin Li INTEGER INFOT, NOUTC 834*bf2c3715SXin Li LOGICAL LERR, OK 835*bf2c3715SXin Li* .. Common blocks .. 836*bf2c3715SXin Li COMMON /INFOC/INFOT, NOUTC, OK, LERR 837*bf2c3715SXin Li* .. Data statements .. 838*bf2c3715SXin Li DATA ICH/'UL'/ 839*bf2c3715SXin Li* .. Executable Statements .. 840*bf2c3715SXin Li FULL = SNAME( 3: 3 ).EQ.'E' 841*bf2c3715SXin Li BANDED = SNAME( 3: 3 ).EQ.'B' 842*bf2c3715SXin Li PACKED = SNAME( 3: 3 ).EQ.'P' 843*bf2c3715SXin Li* Define the number of arguments. 844*bf2c3715SXin Li IF( FULL )THEN 845*bf2c3715SXin Li NARGS = 10 846*bf2c3715SXin Li ELSE IF( BANDED )THEN 847*bf2c3715SXin Li NARGS = 11 848*bf2c3715SXin Li ELSE IF( PACKED )THEN 849*bf2c3715SXin Li NARGS = 9 850*bf2c3715SXin Li END IF 851*bf2c3715SXin Li* 852*bf2c3715SXin Li NC = 0 853*bf2c3715SXin Li RESET = .TRUE. 854*bf2c3715SXin Li ERRMAX = RZERO 855*bf2c3715SXin Li* 856*bf2c3715SXin Li DO 110 IN = 1, NIDIM 857*bf2c3715SXin Li N = IDIM( IN ) 858*bf2c3715SXin Li* 859*bf2c3715SXin Li IF( BANDED )THEN 860*bf2c3715SXin Li NK = NKB 861*bf2c3715SXin Li ELSE 862*bf2c3715SXin Li NK = 1 863*bf2c3715SXin Li END IF 864*bf2c3715SXin Li DO 100 IK = 1, NK 865*bf2c3715SXin Li IF( BANDED )THEN 866*bf2c3715SXin Li K = KB( IK ) 867*bf2c3715SXin Li ELSE 868*bf2c3715SXin Li K = N - 1 869*bf2c3715SXin Li END IF 870*bf2c3715SXin Li* Set LDA to 1 more than minimum value if room. 871*bf2c3715SXin Li IF( BANDED )THEN 872*bf2c3715SXin Li LDA = K + 1 873*bf2c3715SXin Li ELSE 874*bf2c3715SXin Li LDA = N 875*bf2c3715SXin Li END IF 876*bf2c3715SXin Li IF( LDA.LT.NMAX ) 877*bf2c3715SXin Li $ LDA = LDA + 1 878*bf2c3715SXin Li* Skip tests if not enough room. 879*bf2c3715SXin Li IF( LDA.GT.NMAX ) 880*bf2c3715SXin Li $ GO TO 100 881*bf2c3715SXin Li IF( PACKED )THEN 882*bf2c3715SXin Li LAA = ( N*( N + 1 ) )/2 883*bf2c3715SXin Li ELSE 884*bf2c3715SXin Li LAA = LDA*N 885*bf2c3715SXin Li END IF 886*bf2c3715SXin Li NULL = N.LE.0 887*bf2c3715SXin Li* 888*bf2c3715SXin Li DO 90 IC = 1, 2 889*bf2c3715SXin Li UPLO = ICH( IC: IC ) 890*bf2c3715SXin Li* 891*bf2c3715SXin Li* Generate the matrix A. 892*bf2c3715SXin Li* 893*bf2c3715SXin Li TRANSL = ZERO 894*bf2c3715SXin Li CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, 895*bf2c3715SXin Li $ LDA, K, K, RESET, TRANSL ) 896*bf2c3715SXin Li* 897*bf2c3715SXin Li DO 80 IX = 1, NINC 898*bf2c3715SXin Li INCX = INC( IX ) 899*bf2c3715SXin Li LX = ABS( INCX )*N 900*bf2c3715SXin Li* 901*bf2c3715SXin Li* Generate the vector X. 902*bf2c3715SXin Li* 903*bf2c3715SXin Li TRANSL = HALF 904*bf2c3715SXin Li CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, 905*bf2c3715SXin Li $ ABS( INCX ), 0, N - 1, RESET, TRANSL ) 906*bf2c3715SXin Li IF( N.GT.1 )THEN 907*bf2c3715SXin Li X( N/2 ) = ZERO 908*bf2c3715SXin Li XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 909*bf2c3715SXin Li END IF 910*bf2c3715SXin Li* 911*bf2c3715SXin Li DO 70 IY = 1, NINC 912*bf2c3715SXin Li INCY = INC( IY ) 913*bf2c3715SXin Li LY = ABS( INCY )*N 914*bf2c3715SXin Li* 915*bf2c3715SXin Li DO 60 IA = 1, NALF 916*bf2c3715SXin Li ALPHA = ALF( IA ) 917*bf2c3715SXin Li* 918*bf2c3715SXin Li DO 50 IB = 1, NBET 919*bf2c3715SXin Li BETA = BET( IB ) 920*bf2c3715SXin Li* 921*bf2c3715SXin Li* Generate the vector Y. 922*bf2c3715SXin Li* 923*bf2c3715SXin Li TRANSL = ZERO 924*bf2c3715SXin Li CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, 925*bf2c3715SXin Li $ ABS( INCY ), 0, N - 1, RESET, 926*bf2c3715SXin Li $ TRANSL ) 927*bf2c3715SXin Li* 928*bf2c3715SXin Li NC = NC + 1 929*bf2c3715SXin Li* 930*bf2c3715SXin Li* Save every datum before calling the 931*bf2c3715SXin Li* subroutine. 932*bf2c3715SXin Li* 933*bf2c3715SXin Li UPLOS = UPLO 934*bf2c3715SXin Li NS = N 935*bf2c3715SXin Li KS = K 936*bf2c3715SXin Li ALS = ALPHA 937*bf2c3715SXin Li DO 10 I = 1, LAA 938*bf2c3715SXin Li AS( I ) = AA( I ) 939*bf2c3715SXin Li 10 CONTINUE 940*bf2c3715SXin Li LDAS = LDA 941*bf2c3715SXin Li DO 20 I = 1, LX 942*bf2c3715SXin Li XS( I ) = XX( I ) 943*bf2c3715SXin Li 20 CONTINUE 944*bf2c3715SXin Li INCXS = INCX 945*bf2c3715SXin Li BLS = BETA 946*bf2c3715SXin Li DO 30 I = 1, LY 947*bf2c3715SXin Li YS( I ) = YY( I ) 948*bf2c3715SXin Li 30 CONTINUE 949*bf2c3715SXin Li INCYS = INCY 950*bf2c3715SXin Li* 951*bf2c3715SXin Li* Call the subroutine. 952*bf2c3715SXin Li* 953*bf2c3715SXin Li IF( FULL )THEN 954*bf2c3715SXin Li IF( TRACE ) 955*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9993 )NC, SNAME, 956*bf2c3715SXin Li $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY 957*bf2c3715SXin Li IF( REWI ) 958*bf2c3715SXin Li $ REWIND NTRA 959*bf2c3715SXin Li CALL CHEMV( UPLO, N, ALPHA, AA, LDA, XX, 960*bf2c3715SXin Li $ INCX, BETA, YY, INCY ) 961*bf2c3715SXin Li ELSE IF( BANDED )THEN 962*bf2c3715SXin Li IF( TRACE ) 963*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 964*bf2c3715SXin Li $ UPLO, N, K, ALPHA, LDA, INCX, BETA, 965*bf2c3715SXin Li $ INCY 966*bf2c3715SXin Li IF( REWI ) 967*bf2c3715SXin Li $ REWIND NTRA 968*bf2c3715SXin Li CALL CHBMV( UPLO, N, K, ALPHA, AA, LDA, 969*bf2c3715SXin Li $ XX, INCX, BETA, YY, INCY ) 970*bf2c3715SXin Li ELSE IF( PACKED )THEN 971*bf2c3715SXin Li IF( TRACE ) 972*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 973*bf2c3715SXin Li $ UPLO, N, ALPHA, INCX, BETA, INCY 974*bf2c3715SXin Li IF( REWI ) 975*bf2c3715SXin Li $ REWIND NTRA 976*bf2c3715SXin Li CALL CHPMV( UPLO, N, ALPHA, AA, XX, INCX, 977*bf2c3715SXin Li $ BETA, YY, INCY ) 978*bf2c3715SXin Li END IF 979*bf2c3715SXin Li* 980*bf2c3715SXin Li* Check if error-exit was taken incorrectly. 981*bf2c3715SXin Li* 982*bf2c3715SXin Li IF( .NOT.OK )THEN 983*bf2c3715SXin Li WRITE( NOUT, FMT = 9992 ) 984*bf2c3715SXin Li FATAL = .TRUE. 985*bf2c3715SXin Li GO TO 120 986*bf2c3715SXin Li END IF 987*bf2c3715SXin Li* 988*bf2c3715SXin Li* See what data changed inside subroutines. 989*bf2c3715SXin Li* 990*bf2c3715SXin Li ISAME( 1 ) = UPLO.EQ.UPLOS 991*bf2c3715SXin Li ISAME( 2 ) = NS.EQ.N 992*bf2c3715SXin Li IF( FULL )THEN 993*bf2c3715SXin Li ISAME( 3 ) = ALS.EQ.ALPHA 994*bf2c3715SXin Li ISAME( 4 ) = LCE( AS, AA, LAA ) 995*bf2c3715SXin Li ISAME( 5 ) = LDAS.EQ.LDA 996*bf2c3715SXin Li ISAME( 6 ) = LCE( XS, XX, LX ) 997*bf2c3715SXin Li ISAME( 7 ) = INCXS.EQ.INCX 998*bf2c3715SXin Li ISAME( 8 ) = BLS.EQ.BETA 999*bf2c3715SXin Li IF( NULL )THEN 1000*bf2c3715SXin Li ISAME( 9 ) = LCE( YS, YY, LY ) 1001*bf2c3715SXin Li ELSE 1002*bf2c3715SXin Li ISAME( 9 ) = LCERES( 'GE', ' ', 1, N, 1003*bf2c3715SXin Li $ YS, YY, ABS( INCY ) ) 1004*bf2c3715SXin Li END IF 1005*bf2c3715SXin Li ISAME( 10 ) = INCYS.EQ.INCY 1006*bf2c3715SXin Li ELSE IF( BANDED )THEN 1007*bf2c3715SXin Li ISAME( 3 ) = KS.EQ.K 1008*bf2c3715SXin Li ISAME( 4 ) = ALS.EQ.ALPHA 1009*bf2c3715SXin Li ISAME( 5 ) = LCE( AS, AA, LAA ) 1010*bf2c3715SXin Li ISAME( 6 ) = LDAS.EQ.LDA 1011*bf2c3715SXin Li ISAME( 7 ) = LCE( XS, XX, LX ) 1012*bf2c3715SXin Li ISAME( 8 ) = INCXS.EQ.INCX 1013*bf2c3715SXin Li ISAME( 9 ) = BLS.EQ.BETA 1014*bf2c3715SXin Li IF( NULL )THEN 1015*bf2c3715SXin Li ISAME( 10 ) = LCE( YS, YY, LY ) 1016*bf2c3715SXin Li ELSE 1017*bf2c3715SXin Li ISAME( 10 ) = LCERES( 'GE', ' ', 1, N, 1018*bf2c3715SXin Li $ YS, YY, ABS( INCY ) ) 1019*bf2c3715SXin Li END IF 1020*bf2c3715SXin Li ISAME( 11 ) = INCYS.EQ.INCY 1021*bf2c3715SXin Li ELSE IF( PACKED )THEN 1022*bf2c3715SXin Li ISAME( 3 ) = ALS.EQ.ALPHA 1023*bf2c3715SXin Li ISAME( 4 ) = LCE( AS, AA, LAA ) 1024*bf2c3715SXin Li ISAME( 5 ) = LCE( XS, XX, LX ) 1025*bf2c3715SXin Li ISAME( 6 ) = INCXS.EQ.INCX 1026*bf2c3715SXin Li ISAME( 7 ) = BLS.EQ.BETA 1027*bf2c3715SXin Li IF( NULL )THEN 1028*bf2c3715SXin Li ISAME( 8 ) = LCE( YS, YY, LY ) 1029*bf2c3715SXin Li ELSE 1030*bf2c3715SXin Li ISAME( 8 ) = LCERES( 'GE', ' ', 1, N, 1031*bf2c3715SXin Li $ YS, YY, ABS( INCY ) ) 1032*bf2c3715SXin Li END IF 1033*bf2c3715SXin Li ISAME( 9 ) = INCYS.EQ.INCY 1034*bf2c3715SXin Li END IF 1035*bf2c3715SXin Li* 1036*bf2c3715SXin Li* If data was incorrectly changed, report and 1037*bf2c3715SXin Li* return. 1038*bf2c3715SXin Li* 1039*bf2c3715SXin Li SAME = .TRUE. 1040*bf2c3715SXin Li DO 40 I = 1, NARGS 1041*bf2c3715SXin Li SAME = SAME.AND.ISAME( I ) 1042*bf2c3715SXin Li IF( .NOT.ISAME( I ) ) 1043*bf2c3715SXin Li $ WRITE( NOUT, FMT = 9998 )I 1044*bf2c3715SXin Li 40 CONTINUE 1045*bf2c3715SXin Li IF( .NOT.SAME )THEN 1046*bf2c3715SXin Li FATAL = .TRUE. 1047*bf2c3715SXin Li GO TO 120 1048*bf2c3715SXin Li END IF 1049*bf2c3715SXin Li* 1050*bf2c3715SXin Li IF( .NOT.NULL )THEN 1051*bf2c3715SXin Li* 1052*bf2c3715SXin Li* Check the result. 1053*bf2c3715SXin Li* 1054*bf2c3715SXin Li CALL CMVCH( 'N', N, N, ALPHA, A, NMAX, X, 1055*bf2c3715SXin Li $ INCX, BETA, Y, INCY, YT, G, 1056*bf2c3715SXin Li $ YY, EPS, ERR, FATAL, NOUT, 1057*bf2c3715SXin Li $ .TRUE. ) 1058*bf2c3715SXin Li ERRMAX = MAX( ERRMAX, ERR ) 1059*bf2c3715SXin Li* If got really bad answer, report and 1060*bf2c3715SXin Li* return. 1061*bf2c3715SXin Li IF( FATAL ) 1062*bf2c3715SXin Li $ GO TO 120 1063*bf2c3715SXin Li ELSE 1064*bf2c3715SXin Li* Avoid repeating tests with N.le.0 1065*bf2c3715SXin Li GO TO 110 1066*bf2c3715SXin Li END IF 1067*bf2c3715SXin Li* 1068*bf2c3715SXin Li 50 CONTINUE 1069*bf2c3715SXin Li* 1070*bf2c3715SXin Li 60 CONTINUE 1071*bf2c3715SXin Li* 1072*bf2c3715SXin Li 70 CONTINUE 1073*bf2c3715SXin Li* 1074*bf2c3715SXin Li 80 CONTINUE 1075*bf2c3715SXin Li* 1076*bf2c3715SXin Li 90 CONTINUE 1077*bf2c3715SXin Li* 1078*bf2c3715SXin Li 100 CONTINUE 1079*bf2c3715SXin Li* 1080*bf2c3715SXin Li 110 CONTINUE 1081*bf2c3715SXin Li* 1082*bf2c3715SXin Li* Report result. 1083*bf2c3715SXin Li* 1084*bf2c3715SXin Li IF( ERRMAX.LT.THRESH )THEN 1085*bf2c3715SXin Li WRITE( NOUT, FMT = 9999 )SNAME, NC 1086*bf2c3715SXin Li ELSE 1087*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 1088*bf2c3715SXin Li END IF 1089*bf2c3715SXin Li GO TO 130 1090*bf2c3715SXin Li* 1091*bf2c3715SXin Li 120 CONTINUE 1092*bf2c3715SXin Li WRITE( NOUT, FMT = 9996 )SNAME 1093*bf2c3715SXin Li IF( FULL )THEN 1094*bf2c3715SXin Li WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX, 1095*bf2c3715SXin Li $ BETA, INCY 1096*bf2c3715SXin Li ELSE IF( BANDED )THEN 1097*bf2c3715SXin Li WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA, 1098*bf2c3715SXin Li $ INCX, BETA, INCY 1099*bf2c3715SXin Li ELSE IF( PACKED )THEN 1100*bf2c3715SXin Li WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX, 1101*bf2c3715SXin Li $ BETA, INCY 1102*bf2c3715SXin Li END IF 1103*bf2c3715SXin Li* 1104*bf2c3715SXin Li 130 CONTINUE 1105*bf2c3715SXin Li RETURN 1106*bf2c3715SXin Li* 1107*bf2c3715SXin Li 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 1108*bf2c3715SXin Li $ 'S)' ) 1109*bf2c3715SXin Li 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 1110*bf2c3715SXin Li $ 'ANGED INCORRECTLY *******' ) 1111*bf2c3715SXin Li 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 1112*bf2c3715SXin Li $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 1113*bf2c3715SXin Li $ ' - SUSPECT *******' ) 1114*bf2c3715SXin Li 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 1115*bf2c3715SXin Li 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', 1116*bf2c3715SXin Li $ F4.1, '), AP, X,', I2, ',(', F4.1, ',', F4.1, '), Y,', I2, 1117*bf2c3715SXin Li $ ') .' ) 1118*bf2c3715SXin Li 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), '(', 1119*bf2c3715SXin Li $ F4.1, ',', F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', 1120*bf2c3715SXin Li $ F4.1, '), Y,', I2, ') .' ) 1121*bf2c3715SXin Li 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', 1122*bf2c3715SXin Li $ F4.1, '), A,', I3, ', X,', I2, ',(', F4.1, ',', F4.1, '), ', 1123*bf2c3715SXin Li $ 'Y,', I2, ') .' ) 1124*bf2c3715SXin Li 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 1125*bf2c3715SXin Li $ '******' ) 1126*bf2c3715SXin Li* 1127*bf2c3715SXin Li* End of CCHK2. 1128*bf2c3715SXin Li* 1129*bf2c3715SXin Li END 1130*bf2c3715SXin Li SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 1131*bf2c3715SXin Li $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, 1132*bf2c3715SXin Li $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z ) 1133*bf2c3715SXin Li* 1134*bf2c3715SXin Li* Tests CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV. 1135*bf2c3715SXin Li* 1136*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 1137*bf2c3715SXin Li* 1138*bf2c3715SXin Li* -- Written on 10-August-1987. 1139*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 1140*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 1141*bf2c3715SXin Li* 1142*bf2c3715SXin Li* .. Parameters .. 1143*bf2c3715SXin Li COMPLEX ZERO, HALF, ONE 1144*bf2c3715SXin Li PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), 1145*bf2c3715SXin Li $ ONE = ( 1.0, 0.0 ) ) 1146*bf2c3715SXin Li REAL RZERO 1147*bf2c3715SXin Li PARAMETER ( RZERO = 0.0 ) 1148*bf2c3715SXin Li* .. Scalar Arguments .. 1149*bf2c3715SXin Li REAL EPS, THRESH 1150*bf2c3715SXin Li INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA 1151*bf2c3715SXin Li LOGICAL FATAL, REWI, TRACE 1152*bf2c3715SXin Li CHARACTER*6 SNAME 1153*bf2c3715SXin Li* .. Array Arguments .. 1154*bf2c3715SXin Li COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), 1155*bf2c3715SXin Li $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), 1156*bf2c3715SXin Li $ XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX ) 1157*bf2c3715SXin Li REAL G( NMAX ) 1158*bf2c3715SXin Li INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB ) 1159*bf2c3715SXin Li* .. Local Scalars .. 1160*bf2c3715SXin Li COMPLEX TRANSL 1161*bf2c3715SXin Li REAL ERR, ERRMAX 1162*bf2c3715SXin Li INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, 1163*bf2c3715SXin Li $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS 1164*bf2c3715SXin Li LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME 1165*bf2c3715SXin Li CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS 1166*bf2c3715SXin Li CHARACTER*2 ICHD, ICHU 1167*bf2c3715SXin Li CHARACTER*3 ICHT 1168*bf2c3715SXin Li* .. Local Arrays .. 1169*bf2c3715SXin Li LOGICAL ISAME( 13 ) 1170*bf2c3715SXin Li* .. External Functions .. 1171*bf2c3715SXin Li LOGICAL LCE, LCERES 1172*bf2c3715SXin Li EXTERNAL LCE, LCERES 1173*bf2c3715SXin Li* .. External Subroutines .. 1174*bf2c3715SXin Li EXTERNAL CMAKE, CMVCH, CTBMV, CTBSV, CTPMV, CTPSV, 1175*bf2c3715SXin Li $ CTRMV, CTRSV 1176*bf2c3715SXin Li* .. Intrinsic Functions .. 1177*bf2c3715SXin Li INTRINSIC ABS, MAX 1178*bf2c3715SXin Li* .. Scalars in Common .. 1179*bf2c3715SXin Li INTEGER INFOT, NOUTC 1180*bf2c3715SXin Li LOGICAL LERR, OK 1181*bf2c3715SXin Li* .. Common blocks .. 1182*bf2c3715SXin Li COMMON /INFOC/INFOT, NOUTC, OK, LERR 1183*bf2c3715SXin Li* .. Data statements .. 1184*bf2c3715SXin Li DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ 1185*bf2c3715SXin Li* .. Executable Statements .. 1186*bf2c3715SXin Li FULL = SNAME( 3: 3 ).EQ.'R' 1187*bf2c3715SXin Li BANDED = SNAME( 3: 3 ).EQ.'B' 1188*bf2c3715SXin Li PACKED = SNAME( 3: 3 ).EQ.'P' 1189*bf2c3715SXin Li* Define the number of arguments. 1190*bf2c3715SXin Li IF( FULL )THEN 1191*bf2c3715SXin Li NARGS = 8 1192*bf2c3715SXin Li ELSE IF( BANDED )THEN 1193*bf2c3715SXin Li NARGS = 9 1194*bf2c3715SXin Li ELSE IF( PACKED )THEN 1195*bf2c3715SXin Li NARGS = 7 1196*bf2c3715SXin Li END IF 1197*bf2c3715SXin Li* 1198*bf2c3715SXin Li NC = 0 1199*bf2c3715SXin Li RESET = .TRUE. 1200*bf2c3715SXin Li ERRMAX = RZERO 1201*bf2c3715SXin Li* Set up zero vector for CMVCH. 1202*bf2c3715SXin Li DO 10 I = 1, NMAX 1203*bf2c3715SXin Li Z( I ) = ZERO 1204*bf2c3715SXin Li 10 CONTINUE 1205*bf2c3715SXin Li* 1206*bf2c3715SXin Li DO 110 IN = 1, NIDIM 1207*bf2c3715SXin Li N = IDIM( IN ) 1208*bf2c3715SXin Li* 1209*bf2c3715SXin Li IF( BANDED )THEN 1210*bf2c3715SXin Li NK = NKB 1211*bf2c3715SXin Li ELSE 1212*bf2c3715SXin Li NK = 1 1213*bf2c3715SXin Li END IF 1214*bf2c3715SXin Li DO 100 IK = 1, NK 1215*bf2c3715SXin Li IF( BANDED )THEN 1216*bf2c3715SXin Li K = KB( IK ) 1217*bf2c3715SXin Li ELSE 1218*bf2c3715SXin Li K = N - 1 1219*bf2c3715SXin Li END IF 1220*bf2c3715SXin Li* Set LDA to 1 more than minimum value if room. 1221*bf2c3715SXin Li IF( BANDED )THEN 1222*bf2c3715SXin Li LDA = K + 1 1223*bf2c3715SXin Li ELSE 1224*bf2c3715SXin Li LDA = N 1225*bf2c3715SXin Li END IF 1226*bf2c3715SXin Li IF( LDA.LT.NMAX ) 1227*bf2c3715SXin Li $ LDA = LDA + 1 1228*bf2c3715SXin Li* Skip tests if not enough room. 1229*bf2c3715SXin Li IF( LDA.GT.NMAX ) 1230*bf2c3715SXin Li $ GO TO 100 1231*bf2c3715SXin Li IF( PACKED )THEN 1232*bf2c3715SXin Li LAA = ( N*( N + 1 ) )/2 1233*bf2c3715SXin Li ELSE 1234*bf2c3715SXin Li LAA = LDA*N 1235*bf2c3715SXin Li END IF 1236*bf2c3715SXin Li NULL = N.LE.0 1237*bf2c3715SXin Li* 1238*bf2c3715SXin Li DO 90 ICU = 1, 2 1239*bf2c3715SXin Li UPLO = ICHU( ICU: ICU ) 1240*bf2c3715SXin Li* 1241*bf2c3715SXin Li DO 80 ICT = 1, 3 1242*bf2c3715SXin Li TRANS = ICHT( ICT: ICT ) 1243*bf2c3715SXin Li* 1244*bf2c3715SXin Li DO 70 ICD = 1, 2 1245*bf2c3715SXin Li DIAG = ICHD( ICD: ICD ) 1246*bf2c3715SXin Li* 1247*bf2c3715SXin Li* Generate the matrix A. 1248*bf2c3715SXin Li* 1249*bf2c3715SXin Li TRANSL = ZERO 1250*bf2c3715SXin Li CALL CMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, 1251*bf2c3715SXin Li $ NMAX, AA, LDA, K, K, RESET, TRANSL ) 1252*bf2c3715SXin Li* 1253*bf2c3715SXin Li DO 60 IX = 1, NINC 1254*bf2c3715SXin Li INCX = INC( IX ) 1255*bf2c3715SXin Li LX = ABS( INCX )*N 1256*bf2c3715SXin Li* 1257*bf2c3715SXin Li* Generate the vector X. 1258*bf2c3715SXin Li* 1259*bf2c3715SXin Li TRANSL = HALF 1260*bf2c3715SXin Li CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, 1261*bf2c3715SXin Li $ ABS( INCX ), 0, N - 1, RESET, 1262*bf2c3715SXin Li $ TRANSL ) 1263*bf2c3715SXin Li IF( N.GT.1 )THEN 1264*bf2c3715SXin Li X( N/2 ) = ZERO 1265*bf2c3715SXin Li XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 1266*bf2c3715SXin Li END IF 1267*bf2c3715SXin Li* 1268*bf2c3715SXin Li NC = NC + 1 1269*bf2c3715SXin Li* 1270*bf2c3715SXin Li* Save every datum before calling the subroutine. 1271*bf2c3715SXin Li* 1272*bf2c3715SXin Li UPLOS = UPLO 1273*bf2c3715SXin Li TRANSS = TRANS 1274*bf2c3715SXin Li DIAGS = DIAG 1275*bf2c3715SXin Li NS = N 1276*bf2c3715SXin Li KS = K 1277*bf2c3715SXin Li DO 20 I = 1, LAA 1278*bf2c3715SXin Li AS( I ) = AA( I ) 1279*bf2c3715SXin Li 20 CONTINUE 1280*bf2c3715SXin Li LDAS = LDA 1281*bf2c3715SXin Li DO 30 I = 1, LX 1282*bf2c3715SXin Li XS( I ) = XX( I ) 1283*bf2c3715SXin Li 30 CONTINUE 1284*bf2c3715SXin Li INCXS = INCX 1285*bf2c3715SXin Li* 1286*bf2c3715SXin Li* Call the subroutine. 1287*bf2c3715SXin Li* 1288*bf2c3715SXin Li IF( SNAME( 4: 5 ).EQ.'MV' )THEN 1289*bf2c3715SXin Li IF( FULL )THEN 1290*bf2c3715SXin Li IF( TRACE ) 1291*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9993 )NC, SNAME, 1292*bf2c3715SXin Li $ UPLO, TRANS, DIAG, N, LDA, INCX 1293*bf2c3715SXin Li IF( REWI ) 1294*bf2c3715SXin Li $ REWIND NTRA 1295*bf2c3715SXin Li CALL CTRMV( UPLO, TRANS, DIAG, N, AA, LDA, 1296*bf2c3715SXin Li $ XX, INCX ) 1297*bf2c3715SXin Li ELSE IF( BANDED )THEN 1298*bf2c3715SXin Li IF( TRACE ) 1299*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 1300*bf2c3715SXin Li $ UPLO, TRANS, DIAG, N, K, LDA, INCX 1301*bf2c3715SXin Li IF( REWI ) 1302*bf2c3715SXin Li $ REWIND NTRA 1303*bf2c3715SXin Li CALL CTBMV( UPLO, TRANS, DIAG, N, K, AA, 1304*bf2c3715SXin Li $ LDA, XX, INCX ) 1305*bf2c3715SXin Li ELSE IF( PACKED )THEN 1306*bf2c3715SXin Li IF( TRACE ) 1307*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 1308*bf2c3715SXin Li $ UPLO, TRANS, DIAG, N, INCX 1309*bf2c3715SXin Li IF( REWI ) 1310*bf2c3715SXin Li $ REWIND NTRA 1311*bf2c3715SXin Li CALL CTPMV( UPLO, TRANS, DIAG, N, AA, XX, 1312*bf2c3715SXin Li $ INCX ) 1313*bf2c3715SXin Li END IF 1314*bf2c3715SXin Li ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN 1315*bf2c3715SXin Li IF( FULL )THEN 1316*bf2c3715SXin Li IF( TRACE ) 1317*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9993 )NC, SNAME, 1318*bf2c3715SXin Li $ UPLO, TRANS, DIAG, N, LDA, INCX 1319*bf2c3715SXin Li IF( REWI ) 1320*bf2c3715SXin Li $ REWIND NTRA 1321*bf2c3715SXin Li CALL CTRSV( UPLO, TRANS, DIAG, N, AA, LDA, 1322*bf2c3715SXin Li $ XX, INCX ) 1323*bf2c3715SXin Li ELSE IF( BANDED )THEN 1324*bf2c3715SXin Li IF( TRACE ) 1325*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9994 )NC, SNAME, 1326*bf2c3715SXin Li $ UPLO, TRANS, DIAG, N, K, LDA, INCX 1327*bf2c3715SXin Li IF( REWI ) 1328*bf2c3715SXin Li $ REWIND NTRA 1329*bf2c3715SXin Li CALL CTBSV( UPLO, TRANS, DIAG, N, K, AA, 1330*bf2c3715SXin Li $ LDA, XX, INCX ) 1331*bf2c3715SXin Li ELSE IF( PACKED )THEN 1332*bf2c3715SXin Li IF( TRACE ) 1333*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9995 )NC, SNAME, 1334*bf2c3715SXin Li $ UPLO, TRANS, DIAG, N, INCX 1335*bf2c3715SXin Li IF( REWI ) 1336*bf2c3715SXin Li $ REWIND NTRA 1337*bf2c3715SXin Li CALL CTPSV( UPLO, TRANS, DIAG, N, AA, XX, 1338*bf2c3715SXin Li $ INCX ) 1339*bf2c3715SXin Li END IF 1340*bf2c3715SXin Li END IF 1341*bf2c3715SXin Li* 1342*bf2c3715SXin Li* Check if error-exit was taken incorrectly. 1343*bf2c3715SXin Li* 1344*bf2c3715SXin Li IF( .NOT.OK )THEN 1345*bf2c3715SXin Li WRITE( NOUT, FMT = 9992 ) 1346*bf2c3715SXin Li FATAL = .TRUE. 1347*bf2c3715SXin Li GO TO 120 1348*bf2c3715SXin Li END IF 1349*bf2c3715SXin Li* 1350*bf2c3715SXin Li* See what data changed inside subroutines. 1351*bf2c3715SXin Li* 1352*bf2c3715SXin Li ISAME( 1 ) = UPLO.EQ.UPLOS 1353*bf2c3715SXin Li ISAME( 2 ) = TRANS.EQ.TRANSS 1354*bf2c3715SXin Li ISAME( 3 ) = DIAG.EQ.DIAGS 1355*bf2c3715SXin Li ISAME( 4 ) = NS.EQ.N 1356*bf2c3715SXin Li IF( FULL )THEN 1357*bf2c3715SXin Li ISAME( 5 ) = LCE( AS, AA, LAA ) 1358*bf2c3715SXin Li ISAME( 6 ) = LDAS.EQ.LDA 1359*bf2c3715SXin Li IF( NULL )THEN 1360*bf2c3715SXin Li ISAME( 7 ) = LCE( XS, XX, LX ) 1361*bf2c3715SXin Li ELSE 1362*bf2c3715SXin Li ISAME( 7 ) = LCERES( 'GE', ' ', 1, N, XS, 1363*bf2c3715SXin Li $ XX, ABS( INCX ) ) 1364*bf2c3715SXin Li END IF 1365*bf2c3715SXin Li ISAME( 8 ) = INCXS.EQ.INCX 1366*bf2c3715SXin Li ELSE IF( BANDED )THEN 1367*bf2c3715SXin Li ISAME( 5 ) = KS.EQ.K 1368*bf2c3715SXin Li ISAME( 6 ) = LCE( AS, AA, LAA ) 1369*bf2c3715SXin Li ISAME( 7 ) = LDAS.EQ.LDA 1370*bf2c3715SXin Li IF( NULL )THEN 1371*bf2c3715SXin Li ISAME( 8 ) = LCE( XS, XX, LX ) 1372*bf2c3715SXin Li ELSE 1373*bf2c3715SXin Li ISAME( 8 ) = LCERES( 'GE', ' ', 1, N, XS, 1374*bf2c3715SXin Li $ XX, ABS( INCX ) ) 1375*bf2c3715SXin Li END IF 1376*bf2c3715SXin Li ISAME( 9 ) = INCXS.EQ.INCX 1377*bf2c3715SXin Li ELSE IF( PACKED )THEN 1378*bf2c3715SXin Li ISAME( 5 ) = LCE( AS, AA, LAA ) 1379*bf2c3715SXin Li IF( NULL )THEN 1380*bf2c3715SXin Li ISAME( 6 ) = LCE( XS, XX, LX ) 1381*bf2c3715SXin Li ELSE 1382*bf2c3715SXin Li ISAME( 6 ) = LCERES( 'GE', ' ', 1, N, XS, 1383*bf2c3715SXin Li $ XX, ABS( INCX ) ) 1384*bf2c3715SXin Li END IF 1385*bf2c3715SXin Li ISAME( 7 ) = INCXS.EQ.INCX 1386*bf2c3715SXin Li END IF 1387*bf2c3715SXin Li* 1388*bf2c3715SXin Li* If data was incorrectly changed, report and 1389*bf2c3715SXin Li* return. 1390*bf2c3715SXin Li* 1391*bf2c3715SXin Li SAME = .TRUE. 1392*bf2c3715SXin Li DO 40 I = 1, NARGS 1393*bf2c3715SXin Li SAME = SAME.AND.ISAME( I ) 1394*bf2c3715SXin Li IF( .NOT.ISAME( I ) ) 1395*bf2c3715SXin Li $ WRITE( NOUT, FMT = 9998 )I 1396*bf2c3715SXin Li 40 CONTINUE 1397*bf2c3715SXin Li IF( .NOT.SAME )THEN 1398*bf2c3715SXin Li FATAL = .TRUE. 1399*bf2c3715SXin Li GO TO 120 1400*bf2c3715SXin Li END IF 1401*bf2c3715SXin Li* 1402*bf2c3715SXin Li IF( .NOT.NULL )THEN 1403*bf2c3715SXin Li IF( SNAME( 4: 5 ).EQ.'MV' )THEN 1404*bf2c3715SXin Li* 1405*bf2c3715SXin Li* Check the result. 1406*bf2c3715SXin Li* 1407*bf2c3715SXin Li CALL CMVCH( TRANS, N, N, ONE, A, NMAX, X, 1408*bf2c3715SXin Li $ INCX, ZERO, Z, INCX, XT, G, 1409*bf2c3715SXin Li $ XX, EPS, ERR, FATAL, NOUT, 1410*bf2c3715SXin Li $ .TRUE. ) 1411*bf2c3715SXin Li ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN 1412*bf2c3715SXin Li* 1413*bf2c3715SXin Li* Compute approximation to original vector. 1414*bf2c3715SXin Li* 1415*bf2c3715SXin Li DO 50 I = 1, N 1416*bf2c3715SXin Li Z( I ) = XX( 1 + ( I - 1 )* 1417*bf2c3715SXin Li $ ABS( INCX ) ) 1418*bf2c3715SXin Li XX( 1 + ( I - 1 )*ABS( INCX ) ) 1419*bf2c3715SXin Li $ = X( I ) 1420*bf2c3715SXin Li 50 CONTINUE 1421*bf2c3715SXin Li CALL CMVCH( TRANS, N, N, ONE, A, NMAX, Z, 1422*bf2c3715SXin Li $ INCX, ZERO, X, INCX, XT, G, 1423*bf2c3715SXin Li $ XX, EPS, ERR, FATAL, NOUT, 1424*bf2c3715SXin Li $ .FALSE. ) 1425*bf2c3715SXin Li END IF 1426*bf2c3715SXin Li ERRMAX = MAX( ERRMAX, ERR ) 1427*bf2c3715SXin Li* If got really bad answer, report and return. 1428*bf2c3715SXin Li IF( FATAL ) 1429*bf2c3715SXin Li $ GO TO 120 1430*bf2c3715SXin Li ELSE 1431*bf2c3715SXin Li* Avoid repeating tests with N.le.0. 1432*bf2c3715SXin Li GO TO 110 1433*bf2c3715SXin Li END IF 1434*bf2c3715SXin Li* 1435*bf2c3715SXin Li 60 CONTINUE 1436*bf2c3715SXin Li* 1437*bf2c3715SXin Li 70 CONTINUE 1438*bf2c3715SXin Li* 1439*bf2c3715SXin Li 80 CONTINUE 1440*bf2c3715SXin Li* 1441*bf2c3715SXin Li 90 CONTINUE 1442*bf2c3715SXin Li* 1443*bf2c3715SXin Li 100 CONTINUE 1444*bf2c3715SXin Li* 1445*bf2c3715SXin Li 110 CONTINUE 1446*bf2c3715SXin Li* 1447*bf2c3715SXin Li* Report result. 1448*bf2c3715SXin Li* 1449*bf2c3715SXin Li IF( ERRMAX.LT.THRESH )THEN 1450*bf2c3715SXin Li WRITE( NOUT, FMT = 9999 )SNAME, NC 1451*bf2c3715SXin Li ELSE 1452*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 1453*bf2c3715SXin Li END IF 1454*bf2c3715SXin Li GO TO 130 1455*bf2c3715SXin Li* 1456*bf2c3715SXin Li 120 CONTINUE 1457*bf2c3715SXin Li WRITE( NOUT, FMT = 9996 )SNAME 1458*bf2c3715SXin Li IF( FULL )THEN 1459*bf2c3715SXin Li WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA, 1460*bf2c3715SXin Li $ INCX 1461*bf2c3715SXin Li ELSE IF( BANDED )THEN 1462*bf2c3715SXin Li WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K, 1463*bf2c3715SXin Li $ LDA, INCX 1464*bf2c3715SXin Li ELSE IF( PACKED )THEN 1465*bf2c3715SXin Li WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX 1466*bf2c3715SXin Li END IF 1467*bf2c3715SXin Li* 1468*bf2c3715SXin Li 130 CONTINUE 1469*bf2c3715SXin Li RETURN 1470*bf2c3715SXin Li* 1471*bf2c3715SXin Li 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 1472*bf2c3715SXin Li $ 'S)' ) 1473*bf2c3715SXin Li 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 1474*bf2c3715SXin Li $ 'ANGED INCORRECTLY *******' ) 1475*bf2c3715SXin Li 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 1476*bf2c3715SXin Li $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 1477*bf2c3715SXin Li $ ' - SUSPECT *******' ) 1478*bf2c3715SXin Li 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 1479*bf2c3715SXin Li 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ', 1480*bf2c3715SXin Li $ 'X,', I2, ') .' ) 1481*bf2c3715SXin Li 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), 1482*bf2c3715SXin Li $ ' A,', I3, ', X,', I2, ') .' ) 1483*bf2c3715SXin Li 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', 1484*bf2c3715SXin Li $ I3, ', X,', I2, ') .' ) 1485*bf2c3715SXin Li 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 1486*bf2c3715SXin Li $ '******' ) 1487*bf2c3715SXin Li* 1488*bf2c3715SXin Li* End of CCHK3. 1489*bf2c3715SXin Li* 1490*bf2c3715SXin Li END 1491*bf2c3715SXin Li SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 1492*bf2c3715SXin Li $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, 1493*bf2c3715SXin Li $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, 1494*bf2c3715SXin Li $ Z ) 1495*bf2c3715SXin Li* 1496*bf2c3715SXin Li* Tests CGERC and CGERU. 1497*bf2c3715SXin Li* 1498*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 1499*bf2c3715SXin Li* 1500*bf2c3715SXin Li* -- Written on 10-August-1987. 1501*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 1502*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 1503*bf2c3715SXin Li* 1504*bf2c3715SXin Li* .. Parameters .. 1505*bf2c3715SXin Li COMPLEX ZERO, HALF, ONE 1506*bf2c3715SXin Li PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), 1507*bf2c3715SXin Li $ ONE = ( 1.0, 0.0 ) ) 1508*bf2c3715SXin Li REAL RZERO 1509*bf2c3715SXin Li PARAMETER ( RZERO = 0.0 ) 1510*bf2c3715SXin Li* .. Scalar Arguments .. 1511*bf2c3715SXin Li REAL EPS, THRESH 1512*bf2c3715SXin Li INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA 1513*bf2c3715SXin Li LOGICAL FATAL, REWI, TRACE 1514*bf2c3715SXin Li CHARACTER*6 SNAME 1515*bf2c3715SXin Li* .. Array Arguments .. 1516*bf2c3715SXin Li COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 1517*bf2c3715SXin Li $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), 1518*bf2c3715SXin Li $ XX( NMAX*INCMAX ), Y( NMAX ), 1519*bf2c3715SXin Li $ YS( NMAX*INCMAX ), YT( NMAX ), 1520*bf2c3715SXin Li $ YY( NMAX*INCMAX ), Z( NMAX ) 1521*bf2c3715SXin Li REAL G( NMAX ) 1522*bf2c3715SXin Li INTEGER IDIM( NIDIM ), INC( NINC ) 1523*bf2c3715SXin Li* .. Local Scalars .. 1524*bf2c3715SXin Li COMPLEX ALPHA, ALS, TRANSL 1525*bf2c3715SXin Li REAL ERR, ERRMAX 1526*bf2c3715SXin Li INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, 1527*bf2c3715SXin Li $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, 1528*bf2c3715SXin Li $ NC, ND, NS 1529*bf2c3715SXin Li LOGICAL CONJ, NULL, RESET, SAME 1530*bf2c3715SXin Li* .. Local Arrays .. 1531*bf2c3715SXin Li COMPLEX W( 1 ) 1532*bf2c3715SXin Li LOGICAL ISAME( 13 ) 1533*bf2c3715SXin Li* .. External Functions .. 1534*bf2c3715SXin Li LOGICAL LCE, LCERES 1535*bf2c3715SXin Li EXTERNAL LCE, LCERES 1536*bf2c3715SXin Li* .. External Subroutines .. 1537*bf2c3715SXin Li EXTERNAL CGERC, CGERU, CMAKE, CMVCH 1538*bf2c3715SXin Li* .. Intrinsic Functions .. 1539*bf2c3715SXin Li INTRINSIC ABS, CONJG, MAX, MIN 1540*bf2c3715SXin Li* .. Scalars in Common .. 1541*bf2c3715SXin Li INTEGER INFOT, NOUTC 1542*bf2c3715SXin Li LOGICAL LERR, OK 1543*bf2c3715SXin Li* .. Common blocks .. 1544*bf2c3715SXin Li COMMON /INFOC/INFOT, NOUTC, OK, LERR 1545*bf2c3715SXin Li* .. Executable Statements .. 1546*bf2c3715SXin Li CONJ = SNAME( 5: 5 ).EQ.'C' 1547*bf2c3715SXin Li* Define the number of arguments. 1548*bf2c3715SXin Li NARGS = 9 1549*bf2c3715SXin Li* 1550*bf2c3715SXin Li NC = 0 1551*bf2c3715SXin Li RESET = .TRUE. 1552*bf2c3715SXin Li ERRMAX = RZERO 1553*bf2c3715SXin Li* 1554*bf2c3715SXin Li DO 120 IN = 1, NIDIM 1555*bf2c3715SXin Li N = IDIM( IN ) 1556*bf2c3715SXin Li ND = N/2 + 1 1557*bf2c3715SXin Li* 1558*bf2c3715SXin Li DO 110 IM = 1, 2 1559*bf2c3715SXin Li IF( IM.EQ.1 ) 1560*bf2c3715SXin Li $ M = MAX( N - ND, 0 ) 1561*bf2c3715SXin Li IF( IM.EQ.2 ) 1562*bf2c3715SXin Li $ M = MIN( N + ND, NMAX ) 1563*bf2c3715SXin Li* 1564*bf2c3715SXin Li* Set LDA to 1 more than minimum value if room. 1565*bf2c3715SXin Li LDA = M 1566*bf2c3715SXin Li IF( LDA.LT.NMAX ) 1567*bf2c3715SXin Li $ LDA = LDA + 1 1568*bf2c3715SXin Li* Skip tests if not enough room. 1569*bf2c3715SXin Li IF( LDA.GT.NMAX ) 1570*bf2c3715SXin Li $ GO TO 110 1571*bf2c3715SXin Li LAA = LDA*N 1572*bf2c3715SXin Li NULL = N.LE.0.OR.M.LE.0 1573*bf2c3715SXin Li* 1574*bf2c3715SXin Li DO 100 IX = 1, NINC 1575*bf2c3715SXin Li INCX = INC( IX ) 1576*bf2c3715SXin Li LX = ABS( INCX )*M 1577*bf2c3715SXin Li* 1578*bf2c3715SXin Li* Generate the vector X. 1579*bf2c3715SXin Li* 1580*bf2c3715SXin Li TRANSL = HALF 1581*bf2c3715SXin Li CALL CMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), 1582*bf2c3715SXin Li $ 0, M - 1, RESET, TRANSL ) 1583*bf2c3715SXin Li IF( M.GT.1 )THEN 1584*bf2c3715SXin Li X( M/2 ) = ZERO 1585*bf2c3715SXin Li XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO 1586*bf2c3715SXin Li END IF 1587*bf2c3715SXin Li* 1588*bf2c3715SXin Li DO 90 IY = 1, NINC 1589*bf2c3715SXin Li INCY = INC( IY ) 1590*bf2c3715SXin Li LY = ABS( INCY )*N 1591*bf2c3715SXin Li* 1592*bf2c3715SXin Li* Generate the vector Y. 1593*bf2c3715SXin Li* 1594*bf2c3715SXin Li TRANSL = ZERO 1595*bf2c3715SXin Li CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, 1596*bf2c3715SXin Li $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) 1597*bf2c3715SXin Li IF( N.GT.1 )THEN 1598*bf2c3715SXin Li Y( N/2 ) = ZERO 1599*bf2c3715SXin Li YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO 1600*bf2c3715SXin Li END IF 1601*bf2c3715SXin Li* 1602*bf2c3715SXin Li DO 80 IA = 1, NALF 1603*bf2c3715SXin Li ALPHA = ALF( IA ) 1604*bf2c3715SXin Li* 1605*bf2c3715SXin Li* Generate the matrix A. 1606*bf2c3715SXin Li* 1607*bf2c3715SXin Li TRANSL = ZERO 1608*bf2c3715SXin Li CALL CMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, 1609*bf2c3715SXin Li $ AA, LDA, M - 1, N - 1, RESET, TRANSL ) 1610*bf2c3715SXin Li* 1611*bf2c3715SXin Li NC = NC + 1 1612*bf2c3715SXin Li* 1613*bf2c3715SXin Li* Save every datum before calling the subroutine. 1614*bf2c3715SXin Li* 1615*bf2c3715SXin Li MS = M 1616*bf2c3715SXin Li NS = N 1617*bf2c3715SXin Li ALS = ALPHA 1618*bf2c3715SXin Li DO 10 I = 1, LAA 1619*bf2c3715SXin Li AS( I ) = AA( I ) 1620*bf2c3715SXin Li 10 CONTINUE 1621*bf2c3715SXin Li LDAS = LDA 1622*bf2c3715SXin Li DO 20 I = 1, LX 1623*bf2c3715SXin Li XS( I ) = XX( I ) 1624*bf2c3715SXin Li 20 CONTINUE 1625*bf2c3715SXin Li INCXS = INCX 1626*bf2c3715SXin Li DO 30 I = 1, LY 1627*bf2c3715SXin Li YS( I ) = YY( I ) 1628*bf2c3715SXin Li 30 CONTINUE 1629*bf2c3715SXin Li INCYS = INCY 1630*bf2c3715SXin Li* 1631*bf2c3715SXin Li* Call the subroutine. 1632*bf2c3715SXin Li* 1633*bf2c3715SXin Li IF( TRACE ) 1634*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, 1635*bf2c3715SXin Li $ ALPHA, INCX, INCY, LDA 1636*bf2c3715SXin Li IF( CONJ )THEN 1637*bf2c3715SXin Li IF( REWI ) 1638*bf2c3715SXin Li $ REWIND NTRA 1639*bf2c3715SXin Li CALL CGERC( M, N, ALPHA, XX, INCX, YY, INCY, AA, 1640*bf2c3715SXin Li $ LDA ) 1641*bf2c3715SXin Li ELSE 1642*bf2c3715SXin Li IF( REWI ) 1643*bf2c3715SXin Li $ REWIND NTRA 1644*bf2c3715SXin Li CALL CGERU( M, N, ALPHA, XX, INCX, YY, INCY, AA, 1645*bf2c3715SXin Li $ LDA ) 1646*bf2c3715SXin Li END IF 1647*bf2c3715SXin Li* 1648*bf2c3715SXin Li* Check if error-exit was taken incorrectly. 1649*bf2c3715SXin Li* 1650*bf2c3715SXin Li IF( .NOT.OK )THEN 1651*bf2c3715SXin Li WRITE( NOUT, FMT = 9993 ) 1652*bf2c3715SXin Li FATAL = .TRUE. 1653*bf2c3715SXin Li GO TO 140 1654*bf2c3715SXin Li END IF 1655*bf2c3715SXin Li* 1656*bf2c3715SXin Li* See what data changed inside subroutine. 1657*bf2c3715SXin Li* 1658*bf2c3715SXin Li ISAME( 1 ) = MS.EQ.M 1659*bf2c3715SXin Li ISAME( 2 ) = NS.EQ.N 1660*bf2c3715SXin Li ISAME( 3 ) = ALS.EQ.ALPHA 1661*bf2c3715SXin Li ISAME( 4 ) = LCE( XS, XX, LX ) 1662*bf2c3715SXin Li ISAME( 5 ) = INCXS.EQ.INCX 1663*bf2c3715SXin Li ISAME( 6 ) = LCE( YS, YY, LY ) 1664*bf2c3715SXin Li ISAME( 7 ) = INCYS.EQ.INCY 1665*bf2c3715SXin Li IF( NULL )THEN 1666*bf2c3715SXin Li ISAME( 8 ) = LCE( AS, AA, LAA ) 1667*bf2c3715SXin Li ELSE 1668*bf2c3715SXin Li ISAME( 8 ) = LCERES( 'GE', ' ', M, N, AS, AA, 1669*bf2c3715SXin Li $ LDA ) 1670*bf2c3715SXin Li END IF 1671*bf2c3715SXin Li ISAME( 9 ) = LDAS.EQ.LDA 1672*bf2c3715SXin Li* 1673*bf2c3715SXin Li* If data was incorrectly changed, report and return. 1674*bf2c3715SXin Li* 1675*bf2c3715SXin Li SAME = .TRUE. 1676*bf2c3715SXin Li DO 40 I = 1, NARGS 1677*bf2c3715SXin Li SAME = SAME.AND.ISAME( I ) 1678*bf2c3715SXin Li IF( .NOT.ISAME( I ) ) 1679*bf2c3715SXin Li $ WRITE( NOUT, FMT = 9998 )I 1680*bf2c3715SXin Li 40 CONTINUE 1681*bf2c3715SXin Li IF( .NOT.SAME )THEN 1682*bf2c3715SXin Li FATAL = .TRUE. 1683*bf2c3715SXin Li GO TO 140 1684*bf2c3715SXin Li END IF 1685*bf2c3715SXin Li* 1686*bf2c3715SXin Li IF( .NOT.NULL )THEN 1687*bf2c3715SXin Li* 1688*bf2c3715SXin Li* Check the result column by column. 1689*bf2c3715SXin Li* 1690*bf2c3715SXin Li IF( INCX.GT.0 )THEN 1691*bf2c3715SXin Li DO 50 I = 1, M 1692*bf2c3715SXin Li Z( I ) = X( I ) 1693*bf2c3715SXin Li 50 CONTINUE 1694*bf2c3715SXin Li ELSE 1695*bf2c3715SXin Li DO 60 I = 1, M 1696*bf2c3715SXin Li Z( I ) = X( M - I + 1 ) 1697*bf2c3715SXin Li 60 CONTINUE 1698*bf2c3715SXin Li END IF 1699*bf2c3715SXin Li DO 70 J = 1, N 1700*bf2c3715SXin Li IF( INCY.GT.0 )THEN 1701*bf2c3715SXin Li W( 1 ) = Y( J ) 1702*bf2c3715SXin Li ELSE 1703*bf2c3715SXin Li W( 1 ) = Y( N - J + 1 ) 1704*bf2c3715SXin Li END IF 1705*bf2c3715SXin Li IF( CONJ ) 1706*bf2c3715SXin Li $ W( 1 ) = CONJG( W( 1 ) ) 1707*bf2c3715SXin Li CALL CMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, 1708*bf2c3715SXin Li $ ONE, A( 1, J ), 1, YT, G, 1709*bf2c3715SXin Li $ AA( 1 + ( J - 1 )*LDA ), EPS, 1710*bf2c3715SXin Li $ ERR, FATAL, NOUT, .TRUE. ) 1711*bf2c3715SXin Li ERRMAX = MAX( ERRMAX, ERR ) 1712*bf2c3715SXin Li* If got really bad answer, report and return. 1713*bf2c3715SXin Li IF( FATAL ) 1714*bf2c3715SXin Li $ GO TO 130 1715*bf2c3715SXin Li 70 CONTINUE 1716*bf2c3715SXin Li ELSE 1717*bf2c3715SXin Li* Avoid repeating tests with M.le.0 or N.le.0. 1718*bf2c3715SXin Li GO TO 110 1719*bf2c3715SXin Li END IF 1720*bf2c3715SXin Li* 1721*bf2c3715SXin Li 80 CONTINUE 1722*bf2c3715SXin Li* 1723*bf2c3715SXin Li 90 CONTINUE 1724*bf2c3715SXin Li* 1725*bf2c3715SXin Li 100 CONTINUE 1726*bf2c3715SXin Li* 1727*bf2c3715SXin Li 110 CONTINUE 1728*bf2c3715SXin Li* 1729*bf2c3715SXin Li 120 CONTINUE 1730*bf2c3715SXin Li* 1731*bf2c3715SXin Li* Report result. 1732*bf2c3715SXin Li* 1733*bf2c3715SXin Li IF( ERRMAX.LT.THRESH )THEN 1734*bf2c3715SXin Li WRITE( NOUT, FMT = 9999 )SNAME, NC 1735*bf2c3715SXin Li ELSE 1736*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 1737*bf2c3715SXin Li END IF 1738*bf2c3715SXin Li GO TO 150 1739*bf2c3715SXin Li* 1740*bf2c3715SXin Li 130 CONTINUE 1741*bf2c3715SXin Li WRITE( NOUT, FMT = 9995 )J 1742*bf2c3715SXin Li* 1743*bf2c3715SXin Li 140 CONTINUE 1744*bf2c3715SXin Li WRITE( NOUT, FMT = 9996 )SNAME 1745*bf2c3715SXin Li WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA 1746*bf2c3715SXin Li* 1747*bf2c3715SXin Li 150 CONTINUE 1748*bf2c3715SXin Li RETURN 1749*bf2c3715SXin Li* 1750*bf2c3715SXin Li 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 1751*bf2c3715SXin Li $ 'S)' ) 1752*bf2c3715SXin Li 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 1753*bf2c3715SXin Li $ 'ANGED INCORRECTLY *******' ) 1754*bf2c3715SXin Li 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 1755*bf2c3715SXin Li $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 1756*bf2c3715SXin Li $ ' - SUSPECT *******' ) 1757*bf2c3715SXin Li 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 1758*bf2c3715SXin Li 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 1759*bf2c3715SXin Li 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1, 1760*bf2c3715SXin Li $ '), X,', I2, ', Y,', I2, ', A,', I3, ') ', 1761*bf2c3715SXin Li $ ' .' ) 1762*bf2c3715SXin Li 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 1763*bf2c3715SXin Li $ '******' ) 1764*bf2c3715SXin Li* 1765*bf2c3715SXin Li* End of CCHK4. 1766*bf2c3715SXin Li* 1767*bf2c3715SXin Li END 1768*bf2c3715SXin Li SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 1769*bf2c3715SXin Li $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, 1770*bf2c3715SXin Li $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, 1771*bf2c3715SXin Li $ Z ) 1772*bf2c3715SXin Li* 1773*bf2c3715SXin Li* Tests CHER and CHPR. 1774*bf2c3715SXin Li* 1775*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 1776*bf2c3715SXin Li* 1777*bf2c3715SXin Li* -- Written on 10-August-1987. 1778*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 1779*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 1780*bf2c3715SXin Li* 1781*bf2c3715SXin Li* .. Parameters .. 1782*bf2c3715SXin Li COMPLEX ZERO, HALF, ONE 1783*bf2c3715SXin Li PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), 1784*bf2c3715SXin Li $ ONE = ( 1.0, 0.0 ) ) 1785*bf2c3715SXin Li REAL RZERO 1786*bf2c3715SXin Li PARAMETER ( RZERO = 0.0 ) 1787*bf2c3715SXin Li* .. Scalar Arguments .. 1788*bf2c3715SXin Li REAL EPS, THRESH 1789*bf2c3715SXin Li INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA 1790*bf2c3715SXin Li LOGICAL FATAL, REWI, TRACE 1791*bf2c3715SXin Li CHARACTER*6 SNAME 1792*bf2c3715SXin Li* .. Array Arguments .. 1793*bf2c3715SXin Li COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 1794*bf2c3715SXin Li $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), 1795*bf2c3715SXin Li $ XX( NMAX*INCMAX ), Y( NMAX ), 1796*bf2c3715SXin Li $ YS( NMAX*INCMAX ), YT( NMAX ), 1797*bf2c3715SXin Li $ YY( NMAX*INCMAX ), Z( NMAX ) 1798*bf2c3715SXin Li REAL G( NMAX ) 1799*bf2c3715SXin Li INTEGER IDIM( NIDIM ), INC( NINC ) 1800*bf2c3715SXin Li* .. Local Scalars .. 1801*bf2c3715SXin Li COMPLEX ALPHA, TRANSL 1802*bf2c3715SXin Li REAL ERR, ERRMAX, RALPHA, RALS 1803*bf2c3715SXin Li INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, 1804*bf2c3715SXin Li $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS 1805*bf2c3715SXin Li LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER 1806*bf2c3715SXin Li CHARACTER*1 UPLO, UPLOS 1807*bf2c3715SXin Li CHARACTER*2 ICH 1808*bf2c3715SXin Li* .. Local Arrays .. 1809*bf2c3715SXin Li COMPLEX W( 1 ) 1810*bf2c3715SXin Li LOGICAL ISAME( 13 ) 1811*bf2c3715SXin Li* .. External Functions .. 1812*bf2c3715SXin Li LOGICAL LCE, LCERES 1813*bf2c3715SXin Li EXTERNAL LCE, LCERES 1814*bf2c3715SXin Li* .. External Subroutines .. 1815*bf2c3715SXin Li EXTERNAL CHER, CHPR, CMAKE, CMVCH 1816*bf2c3715SXin Li* .. Intrinsic Functions .. 1817*bf2c3715SXin Li INTRINSIC ABS, CMPLX, CONJG, MAX, REAL 1818*bf2c3715SXin Li* .. Scalars in Common .. 1819*bf2c3715SXin Li INTEGER INFOT, NOUTC 1820*bf2c3715SXin Li LOGICAL LERR, OK 1821*bf2c3715SXin Li* .. Common blocks .. 1822*bf2c3715SXin Li COMMON /INFOC/INFOT, NOUTC, OK, LERR 1823*bf2c3715SXin Li* .. Data statements .. 1824*bf2c3715SXin Li DATA ICH/'UL'/ 1825*bf2c3715SXin Li* .. Executable Statements .. 1826*bf2c3715SXin Li FULL = SNAME( 3: 3 ).EQ.'E' 1827*bf2c3715SXin Li PACKED = SNAME( 3: 3 ).EQ.'P' 1828*bf2c3715SXin Li* Define the number of arguments. 1829*bf2c3715SXin Li IF( FULL )THEN 1830*bf2c3715SXin Li NARGS = 7 1831*bf2c3715SXin Li ELSE IF( PACKED )THEN 1832*bf2c3715SXin Li NARGS = 6 1833*bf2c3715SXin Li END IF 1834*bf2c3715SXin Li* 1835*bf2c3715SXin Li NC = 0 1836*bf2c3715SXin Li RESET = .TRUE. 1837*bf2c3715SXin Li ERRMAX = RZERO 1838*bf2c3715SXin Li* 1839*bf2c3715SXin Li DO 100 IN = 1, NIDIM 1840*bf2c3715SXin Li N = IDIM( IN ) 1841*bf2c3715SXin Li* Set LDA to 1 more than minimum value if room. 1842*bf2c3715SXin Li LDA = N 1843*bf2c3715SXin Li IF( LDA.LT.NMAX ) 1844*bf2c3715SXin Li $ LDA = LDA + 1 1845*bf2c3715SXin Li* Skip tests if not enough room. 1846*bf2c3715SXin Li IF( LDA.GT.NMAX ) 1847*bf2c3715SXin Li $ GO TO 100 1848*bf2c3715SXin Li IF( PACKED )THEN 1849*bf2c3715SXin Li LAA = ( N*( N + 1 ) )/2 1850*bf2c3715SXin Li ELSE 1851*bf2c3715SXin Li LAA = LDA*N 1852*bf2c3715SXin Li END IF 1853*bf2c3715SXin Li* 1854*bf2c3715SXin Li DO 90 IC = 1, 2 1855*bf2c3715SXin Li UPLO = ICH( IC: IC ) 1856*bf2c3715SXin Li UPPER = UPLO.EQ.'U' 1857*bf2c3715SXin Li* 1858*bf2c3715SXin Li DO 80 IX = 1, NINC 1859*bf2c3715SXin Li INCX = INC( IX ) 1860*bf2c3715SXin Li LX = ABS( INCX )*N 1861*bf2c3715SXin Li* 1862*bf2c3715SXin Li* Generate the vector X. 1863*bf2c3715SXin Li* 1864*bf2c3715SXin Li TRANSL = HALF 1865*bf2c3715SXin Li CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), 1866*bf2c3715SXin Li $ 0, N - 1, RESET, TRANSL ) 1867*bf2c3715SXin Li IF( N.GT.1 )THEN 1868*bf2c3715SXin Li X( N/2 ) = ZERO 1869*bf2c3715SXin Li XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 1870*bf2c3715SXin Li END IF 1871*bf2c3715SXin Li* 1872*bf2c3715SXin Li DO 70 IA = 1, NALF 1873*bf2c3715SXin Li RALPHA = REAL( ALF( IA ) ) 1874*bf2c3715SXin Li ALPHA = CMPLX( RALPHA, RZERO ) 1875*bf2c3715SXin Li NULL = N.LE.0.OR.RALPHA.EQ.RZERO 1876*bf2c3715SXin Li* 1877*bf2c3715SXin Li* Generate the matrix A. 1878*bf2c3715SXin Li* 1879*bf2c3715SXin Li TRANSL = ZERO 1880*bf2c3715SXin Li CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, 1881*bf2c3715SXin Li $ AA, LDA, N - 1, N - 1, RESET, TRANSL ) 1882*bf2c3715SXin Li* 1883*bf2c3715SXin Li NC = NC + 1 1884*bf2c3715SXin Li* 1885*bf2c3715SXin Li* Save every datum before calling the subroutine. 1886*bf2c3715SXin Li* 1887*bf2c3715SXin Li UPLOS = UPLO 1888*bf2c3715SXin Li NS = N 1889*bf2c3715SXin Li RALS = RALPHA 1890*bf2c3715SXin Li DO 10 I = 1, LAA 1891*bf2c3715SXin Li AS( I ) = AA( I ) 1892*bf2c3715SXin Li 10 CONTINUE 1893*bf2c3715SXin Li LDAS = LDA 1894*bf2c3715SXin Li DO 20 I = 1, LX 1895*bf2c3715SXin Li XS( I ) = XX( I ) 1896*bf2c3715SXin Li 20 CONTINUE 1897*bf2c3715SXin Li INCXS = INCX 1898*bf2c3715SXin Li* 1899*bf2c3715SXin Li* Call the subroutine. 1900*bf2c3715SXin Li* 1901*bf2c3715SXin Li IF( FULL )THEN 1902*bf2c3715SXin Li IF( TRACE ) 1903*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, 1904*bf2c3715SXin Li $ RALPHA, INCX, LDA 1905*bf2c3715SXin Li IF( REWI ) 1906*bf2c3715SXin Li $ REWIND NTRA 1907*bf2c3715SXin Li CALL CHER( UPLO, N, RALPHA, XX, INCX, AA, LDA ) 1908*bf2c3715SXin Li ELSE IF( PACKED )THEN 1909*bf2c3715SXin Li IF( TRACE ) 1910*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, 1911*bf2c3715SXin Li $ RALPHA, INCX 1912*bf2c3715SXin Li IF( REWI ) 1913*bf2c3715SXin Li $ REWIND NTRA 1914*bf2c3715SXin Li CALL CHPR( UPLO, N, RALPHA, XX, INCX, AA ) 1915*bf2c3715SXin Li END IF 1916*bf2c3715SXin Li* 1917*bf2c3715SXin Li* Check if error-exit was taken incorrectly. 1918*bf2c3715SXin Li* 1919*bf2c3715SXin Li IF( .NOT.OK )THEN 1920*bf2c3715SXin Li WRITE( NOUT, FMT = 9992 ) 1921*bf2c3715SXin Li FATAL = .TRUE. 1922*bf2c3715SXin Li GO TO 120 1923*bf2c3715SXin Li END IF 1924*bf2c3715SXin Li* 1925*bf2c3715SXin Li* See what data changed inside subroutines. 1926*bf2c3715SXin Li* 1927*bf2c3715SXin Li ISAME( 1 ) = UPLO.EQ.UPLOS 1928*bf2c3715SXin Li ISAME( 2 ) = NS.EQ.N 1929*bf2c3715SXin Li ISAME( 3 ) = RALS.EQ.RALPHA 1930*bf2c3715SXin Li ISAME( 4 ) = LCE( XS, XX, LX ) 1931*bf2c3715SXin Li ISAME( 5 ) = INCXS.EQ.INCX 1932*bf2c3715SXin Li IF( NULL )THEN 1933*bf2c3715SXin Li ISAME( 6 ) = LCE( AS, AA, LAA ) 1934*bf2c3715SXin Li ELSE 1935*bf2c3715SXin Li ISAME( 6 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N, AS, 1936*bf2c3715SXin Li $ AA, LDA ) 1937*bf2c3715SXin Li END IF 1938*bf2c3715SXin Li IF( .NOT.PACKED )THEN 1939*bf2c3715SXin Li ISAME( 7 ) = LDAS.EQ.LDA 1940*bf2c3715SXin Li END IF 1941*bf2c3715SXin Li* 1942*bf2c3715SXin Li* If data was incorrectly changed, report and return. 1943*bf2c3715SXin Li* 1944*bf2c3715SXin Li SAME = .TRUE. 1945*bf2c3715SXin Li DO 30 I = 1, NARGS 1946*bf2c3715SXin Li SAME = SAME.AND.ISAME( I ) 1947*bf2c3715SXin Li IF( .NOT.ISAME( I ) ) 1948*bf2c3715SXin Li $ WRITE( NOUT, FMT = 9998 )I 1949*bf2c3715SXin Li 30 CONTINUE 1950*bf2c3715SXin Li IF( .NOT.SAME )THEN 1951*bf2c3715SXin Li FATAL = .TRUE. 1952*bf2c3715SXin Li GO TO 120 1953*bf2c3715SXin Li END IF 1954*bf2c3715SXin Li* 1955*bf2c3715SXin Li IF( .NOT.NULL )THEN 1956*bf2c3715SXin Li* 1957*bf2c3715SXin Li* Check the result column by column. 1958*bf2c3715SXin Li* 1959*bf2c3715SXin Li IF( INCX.GT.0 )THEN 1960*bf2c3715SXin Li DO 40 I = 1, N 1961*bf2c3715SXin Li Z( I ) = X( I ) 1962*bf2c3715SXin Li 40 CONTINUE 1963*bf2c3715SXin Li ELSE 1964*bf2c3715SXin Li DO 50 I = 1, N 1965*bf2c3715SXin Li Z( I ) = X( N - I + 1 ) 1966*bf2c3715SXin Li 50 CONTINUE 1967*bf2c3715SXin Li END IF 1968*bf2c3715SXin Li JA = 1 1969*bf2c3715SXin Li DO 60 J = 1, N 1970*bf2c3715SXin Li W( 1 ) = CONJG( Z( J ) ) 1971*bf2c3715SXin Li IF( UPPER )THEN 1972*bf2c3715SXin Li JJ = 1 1973*bf2c3715SXin Li LJ = J 1974*bf2c3715SXin Li ELSE 1975*bf2c3715SXin Li JJ = J 1976*bf2c3715SXin Li LJ = N - J + 1 1977*bf2c3715SXin Li END IF 1978*bf2c3715SXin Li CALL CMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, 1979*bf2c3715SXin Li $ 1, ONE, A( JJ, J ), 1, YT, G, 1980*bf2c3715SXin Li $ AA( JA ), EPS, ERR, FATAL, NOUT, 1981*bf2c3715SXin Li $ .TRUE. ) 1982*bf2c3715SXin Li IF( FULL )THEN 1983*bf2c3715SXin Li IF( UPPER )THEN 1984*bf2c3715SXin Li JA = JA + LDA 1985*bf2c3715SXin Li ELSE 1986*bf2c3715SXin Li JA = JA + LDA + 1 1987*bf2c3715SXin Li END IF 1988*bf2c3715SXin Li ELSE 1989*bf2c3715SXin Li JA = JA + LJ 1990*bf2c3715SXin Li END IF 1991*bf2c3715SXin Li ERRMAX = MAX( ERRMAX, ERR ) 1992*bf2c3715SXin Li* If got really bad answer, report and return. 1993*bf2c3715SXin Li IF( FATAL ) 1994*bf2c3715SXin Li $ GO TO 110 1995*bf2c3715SXin Li 60 CONTINUE 1996*bf2c3715SXin Li ELSE 1997*bf2c3715SXin Li* Avoid repeating tests if N.le.0. 1998*bf2c3715SXin Li IF( N.LE.0 ) 1999*bf2c3715SXin Li $ GO TO 100 2000*bf2c3715SXin Li END IF 2001*bf2c3715SXin Li* 2002*bf2c3715SXin Li 70 CONTINUE 2003*bf2c3715SXin Li* 2004*bf2c3715SXin Li 80 CONTINUE 2005*bf2c3715SXin Li* 2006*bf2c3715SXin Li 90 CONTINUE 2007*bf2c3715SXin Li* 2008*bf2c3715SXin Li 100 CONTINUE 2009*bf2c3715SXin Li* 2010*bf2c3715SXin Li* Report result. 2011*bf2c3715SXin Li* 2012*bf2c3715SXin Li IF( ERRMAX.LT.THRESH )THEN 2013*bf2c3715SXin Li WRITE( NOUT, FMT = 9999 )SNAME, NC 2014*bf2c3715SXin Li ELSE 2015*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 2016*bf2c3715SXin Li END IF 2017*bf2c3715SXin Li GO TO 130 2018*bf2c3715SXin Li* 2019*bf2c3715SXin Li 110 CONTINUE 2020*bf2c3715SXin Li WRITE( NOUT, FMT = 9995 )J 2021*bf2c3715SXin Li* 2022*bf2c3715SXin Li 120 CONTINUE 2023*bf2c3715SXin Li WRITE( NOUT, FMT = 9996 )SNAME 2024*bf2c3715SXin Li IF( FULL )THEN 2025*bf2c3715SXin Li WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, RALPHA, INCX, LDA 2026*bf2c3715SXin Li ELSE IF( PACKED )THEN 2027*bf2c3715SXin Li WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, RALPHA, INCX 2028*bf2c3715SXin Li END IF 2029*bf2c3715SXin Li* 2030*bf2c3715SXin Li 130 CONTINUE 2031*bf2c3715SXin Li RETURN 2032*bf2c3715SXin Li* 2033*bf2c3715SXin Li 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 2034*bf2c3715SXin Li $ 'S)' ) 2035*bf2c3715SXin Li 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 2036*bf2c3715SXin Li $ 'ANGED INCORRECTLY *******' ) 2037*bf2c3715SXin Li 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 2038*bf2c3715SXin Li $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 2039*bf2c3715SXin Li $ ' - SUSPECT *******' ) 2040*bf2c3715SXin Li 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 2041*bf2c3715SXin Li 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 2042*bf2c3715SXin Li 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', 2043*bf2c3715SXin Li $ I2, ', AP) .' ) 2044*bf2c3715SXin Li 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', 2045*bf2c3715SXin Li $ I2, ', A,', I3, ') .' ) 2046*bf2c3715SXin Li 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 2047*bf2c3715SXin Li $ '******' ) 2048*bf2c3715SXin Li* 2049*bf2c3715SXin Li* End of CCHK5. 2050*bf2c3715SXin Li* 2051*bf2c3715SXin Li END 2052*bf2c3715SXin Li SUBROUTINE CCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, 2053*bf2c3715SXin Li $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, 2054*bf2c3715SXin Li $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, 2055*bf2c3715SXin Li $ Z ) 2056*bf2c3715SXin Li* 2057*bf2c3715SXin Li* Tests CHER2 and CHPR2. 2058*bf2c3715SXin Li* 2059*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 2060*bf2c3715SXin Li* 2061*bf2c3715SXin Li* -- Written on 10-August-1987. 2062*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 2063*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 2064*bf2c3715SXin Li* 2065*bf2c3715SXin Li* .. Parameters .. 2066*bf2c3715SXin Li COMPLEX ZERO, HALF, ONE 2067*bf2c3715SXin Li PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), 2068*bf2c3715SXin Li $ ONE = ( 1.0, 0.0 ) ) 2069*bf2c3715SXin Li REAL RZERO 2070*bf2c3715SXin Li PARAMETER ( RZERO = 0.0 ) 2071*bf2c3715SXin Li* .. Scalar Arguments .. 2072*bf2c3715SXin Li REAL EPS, THRESH 2073*bf2c3715SXin Li INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA 2074*bf2c3715SXin Li LOGICAL FATAL, REWI, TRACE 2075*bf2c3715SXin Li CHARACTER*6 SNAME 2076*bf2c3715SXin Li* .. Array Arguments .. 2077*bf2c3715SXin Li COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), 2078*bf2c3715SXin Li $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), 2079*bf2c3715SXin Li $ XX( NMAX*INCMAX ), Y( NMAX ), 2080*bf2c3715SXin Li $ YS( NMAX*INCMAX ), YT( NMAX ), 2081*bf2c3715SXin Li $ YY( NMAX*INCMAX ), Z( NMAX, 2 ) 2082*bf2c3715SXin Li REAL G( NMAX ) 2083*bf2c3715SXin Li INTEGER IDIM( NIDIM ), INC( NINC ) 2084*bf2c3715SXin Li* .. Local Scalars .. 2085*bf2c3715SXin Li COMPLEX ALPHA, ALS, TRANSL 2086*bf2c3715SXin Li REAL ERR, ERRMAX 2087*bf2c3715SXin Li INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, 2088*bf2c3715SXin Li $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, 2089*bf2c3715SXin Li $ NARGS, NC, NS 2090*bf2c3715SXin Li LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER 2091*bf2c3715SXin Li CHARACTER*1 UPLO, UPLOS 2092*bf2c3715SXin Li CHARACTER*2 ICH 2093*bf2c3715SXin Li* .. Local Arrays .. 2094*bf2c3715SXin Li COMPLEX W( 2 ) 2095*bf2c3715SXin Li LOGICAL ISAME( 13 ) 2096*bf2c3715SXin Li* .. External Functions .. 2097*bf2c3715SXin Li LOGICAL LCE, LCERES 2098*bf2c3715SXin Li EXTERNAL LCE, LCERES 2099*bf2c3715SXin Li* .. External Subroutines .. 2100*bf2c3715SXin Li EXTERNAL CHER2, CHPR2, CMAKE, CMVCH 2101*bf2c3715SXin Li* .. Intrinsic Functions .. 2102*bf2c3715SXin Li INTRINSIC ABS, CONJG, MAX 2103*bf2c3715SXin Li* .. Scalars in Common .. 2104*bf2c3715SXin Li INTEGER INFOT, NOUTC 2105*bf2c3715SXin Li LOGICAL LERR, OK 2106*bf2c3715SXin Li* .. Common blocks .. 2107*bf2c3715SXin Li COMMON /INFOC/INFOT, NOUTC, OK, LERR 2108*bf2c3715SXin Li* .. Data statements .. 2109*bf2c3715SXin Li DATA ICH/'UL'/ 2110*bf2c3715SXin Li* .. Executable Statements .. 2111*bf2c3715SXin Li FULL = SNAME( 3: 3 ).EQ.'E' 2112*bf2c3715SXin Li PACKED = SNAME( 3: 3 ).EQ.'P' 2113*bf2c3715SXin Li* Define the number of arguments. 2114*bf2c3715SXin Li IF( FULL )THEN 2115*bf2c3715SXin Li NARGS = 9 2116*bf2c3715SXin Li ELSE IF( PACKED )THEN 2117*bf2c3715SXin Li NARGS = 8 2118*bf2c3715SXin Li END IF 2119*bf2c3715SXin Li* 2120*bf2c3715SXin Li NC = 0 2121*bf2c3715SXin Li RESET = .TRUE. 2122*bf2c3715SXin Li ERRMAX = RZERO 2123*bf2c3715SXin Li* 2124*bf2c3715SXin Li DO 140 IN = 1, NIDIM 2125*bf2c3715SXin Li N = IDIM( IN ) 2126*bf2c3715SXin Li* Set LDA to 1 more than minimum value if room. 2127*bf2c3715SXin Li LDA = N 2128*bf2c3715SXin Li IF( LDA.LT.NMAX ) 2129*bf2c3715SXin Li $ LDA = LDA + 1 2130*bf2c3715SXin Li* Skip tests if not enough room. 2131*bf2c3715SXin Li IF( LDA.GT.NMAX ) 2132*bf2c3715SXin Li $ GO TO 140 2133*bf2c3715SXin Li IF( PACKED )THEN 2134*bf2c3715SXin Li LAA = ( N*( N + 1 ) )/2 2135*bf2c3715SXin Li ELSE 2136*bf2c3715SXin Li LAA = LDA*N 2137*bf2c3715SXin Li END IF 2138*bf2c3715SXin Li* 2139*bf2c3715SXin Li DO 130 IC = 1, 2 2140*bf2c3715SXin Li UPLO = ICH( IC: IC ) 2141*bf2c3715SXin Li UPPER = UPLO.EQ.'U' 2142*bf2c3715SXin Li* 2143*bf2c3715SXin Li DO 120 IX = 1, NINC 2144*bf2c3715SXin Li INCX = INC( IX ) 2145*bf2c3715SXin Li LX = ABS( INCX )*N 2146*bf2c3715SXin Li* 2147*bf2c3715SXin Li* Generate the vector X. 2148*bf2c3715SXin Li* 2149*bf2c3715SXin Li TRANSL = HALF 2150*bf2c3715SXin Li CALL CMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), 2151*bf2c3715SXin Li $ 0, N - 1, RESET, TRANSL ) 2152*bf2c3715SXin Li IF( N.GT.1 )THEN 2153*bf2c3715SXin Li X( N/2 ) = ZERO 2154*bf2c3715SXin Li XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO 2155*bf2c3715SXin Li END IF 2156*bf2c3715SXin Li* 2157*bf2c3715SXin Li DO 110 IY = 1, NINC 2158*bf2c3715SXin Li INCY = INC( IY ) 2159*bf2c3715SXin Li LY = ABS( INCY )*N 2160*bf2c3715SXin Li* 2161*bf2c3715SXin Li* Generate the vector Y. 2162*bf2c3715SXin Li* 2163*bf2c3715SXin Li TRANSL = ZERO 2164*bf2c3715SXin Li CALL CMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY, 2165*bf2c3715SXin Li $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) 2166*bf2c3715SXin Li IF( N.GT.1 )THEN 2167*bf2c3715SXin Li Y( N/2 ) = ZERO 2168*bf2c3715SXin Li YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO 2169*bf2c3715SXin Li END IF 2170*bf2c3715SXin Li* 2171*bf2c3715SXin Li DO 100 IA = 1, NALF 2172*bf2c3715SXin Li ALPHA = ALF( IA ) 2173*bf2c3715SXin Li NULL = N.LE.0.OR.ALPHA.EQ.ZERO 2174*bf2c3715SXin Li* 2175*bf2c3715SXin Li* Generate the matrix A. 2176*bf2c3715SXin Li* 2177*bf2c3715SXin Li TRANSL = ZERO 2178*bf2c3715SXin Li CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, 2179*bf2c3715SXin Li $ NMAX, AA, LDA, N - 1, N - 1, RESET, 2180*bf2c3715SXin Li $ TRANSL ) 2181*bf2c3715SXin Li* 2182*bf2c3715SXin Li NC = NC + 1 2183*bf2c3715SXin Li* 2184*bf2c3715SXin Li* Save every datum before calling the subroutine. 2185*bf2c3715SXin Li* 2186*bf2c3715SXin Li UPLOS = UPLO 2187*bf2c3715SXin Li NS = N 2188*bf2c3715SXin Li ALS = ALPHA 2189*bf2c3715SXin Li DO 10 I = 1, LAA 2190*bf2c3715SXin Li AS( I ) = AA( I ) 2191*bf2c3715SXin Li 10 CONTINUE 2192*bf2c3715SXin Li LDAS = LDA 2193*bf2c3715SXin Li DO 20 I = 1, LX 2194*bf2c3715SXin Li XS( I ) = XX( I ) 2195*bf2c3715SXin Li 20 CONTINUE 2196*bf2c3715SXin Li INCXS = INCX 2197*bf2c3715SXin Li DO 30 I = 1, LY 2198*bf2c3715SXin Li YS( I ) = YY( I ) 2199*bf2c3715SXin Li 30 CONTINUE 2200*bf2c3715SXin Li INCYS = INCY 2201*bf2c3715SXin Li* 2202*bf2c3715SXin Li* Call the subroutine. 2203*bf2c3715SXin Li* 2204*bf2c3715SXin Li IF( FULL )THEN 2205*bf2c3715SXin Li IF( TRACE ) 2206*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N, 2207*bf2c3715SXin Li $ ALPHA, INCX, INCY, LDA 2208*bf2c3715SXin Li IF( REWI ) 2209*bf2c3715SXin Li $ REWIND NTRA 2210*bf2c3715SXin Li CALL CHER2( UPLO, N, ALPHA, XX, INCX, YY, INCY, 2211*bf2c3715SXin Li $ AA, LDA ) 2212*bf2c3715SXin Li ELSE IF( PACKED )THEN 2213*bf2c3715SXin Li IF( TRACE ) 2214*bf2c3715SXin Li $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N, 2215*bf2c3715SXin Li $ ALPHA, INCX, INCY 2216*bf2c3715SXin Li IF( REWI ) 2217*bf2c3715SXin Li $ REWIND NTRA 2218*bf2c3715SXin Li CALL CHPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, 2219*bf2c3715SXin Li $ AA ) 2220*bf2c3715SXin Li END IF 2221*bf2c3715SXin Li* 2222*bf2c3715SXin Li* Check if error-exit was taken incorrectly. 2223*bf2c3715SXin Li* 2224*bf2c3715SXin Li IF( .NOT.OK )THEN 2225*bf2c3715SXin Li WRITE( NOUT, FMT = 9992 ) 2226*bf2c3715SXin Li FATAL = .TRUE. 2227*bf2c3715SXin Li GO TO 160 2228*bf2c3715SXin Li END IF 2229*bf2c3715SXin Li* 2230*bf2c3715SXin Li* See what data changed inside subroutines. 2231*bf2c3715SXin Li* 2232*bf2c3715SXin Li ISAME( 1 ) = UPLO.EQ.UPLOS 2233*bf2c3715SXin Li ISAME( 2 ) = NS.EQ.N 2234*bf2c3715SXin Li ISAME( 3 ) = ALS.EQ.ALPHA 2235*bf2c3715SXin Li ISAME( 4 ) = LCE( XS, XX, LX ) 2236*bf2c3715SXin Li ISAME( 5 ) = INCXS.EQ.INCX 2237*bf2c3715SXin Li ISAME( 6 ) = LCE( YS, YY, LY ) 2238*bf2c3715SXin Li ISAME( 7 ) = INCYS.EQ.INCY 2239*bf2c3715SXin Li IF( NULL )THEN 2240*bf2c3715SXin Li ISAME( 8 ) = LCE( AS, AA, LAA ) 2241*bf2c3715SXin Li ELSE 2242*bf2c3715SXin Li ISAME( 8 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N, 2243*bf2c3715SXin Li $ AS, AA, LDA ) 2244*bf2c3715SXin Li END IF 2245*bf2c3715SXin Li IF( .NOT.PACKED )THEN 2246*bf2c3715SXin Li ISAME( 9 ) = LDAS.EQ.LDA 2247*bf2c3715SXin Li END IF 2248*bf2c3715SXin Li* 2249*bf2c3715SXin Li* If data was incorrectly changed, report and return. 2250*bf2c3715SXin Li* 2251*bf2c3715SXin Li SAME = .TRUE. 2252*bf2c3715SXin Li DO 40 I = 1, NARGS 2253*bf2c3715SXin Li SAME = SAME.AND.ISAME( I ) 2254*bf2c3715SXin Li IF( .NOT.ISAME( I ) ) 2255*bf2c3715SXin Li $ WRITE( NOUT, FMT = 9998 )I 2256*bf2c3715SXin Li 40 CONTINUE 2257*bf2c3715SXin Li IF( .NOT.SAME )THEN 2258*bf2c3715SXin Li FATAL = .TRUE. 2259*bf2c3715SXin Li GO TO 160 2260*bf2c3715SXin Li END IF 2261*bf2c3715SXin Li* 2262*bf2c3715SXin Li IF( .NOT.NULL )THEN 2263*bf2c3715SXin Li* 2264*bf2c3715SXin Li* Check the result column by column. 2265*bf2c3715SXin Li* 2266*bf2c3715SXin Li IF( INCX.GT.0 )THEN 2267*bf2c3715SXin Li DO 50 I = 1, N 2268*bf2c3715SXin Li Z( I, 1 ) = X( I ) 2269*bf2c3715SXin Li 50 CONTINUE 2270*bf2c3715SXin Li ELSE 2271*bf2c3715SXin Li DO 60 I = 1, N 2272*bf2c3715SXin Li Z( I, 1 ) = X( N - I + 1 ) 2273*bf2c3715SXin Li 60 CONTINUE 2274*bf2c3715SXin Li END IF 2275*bf2c3715SXin Li IF( INCY.GT.0 )THEN 2276*bf2c3715SXin Li DO 70 I = 1, N 2277*bf2c3715SXin Li Z( I, 2 ) = Y( I ) 2278*bf2c3715SXin Li 70 CONTINUE 2279*bf2c3715SXin Li ELSE 2280*bf2c3715SXin Li DO 80 I = 1, N 2281*bf2c3715SXin Li Z( I, 2 ) = Y( N - I + 1 ) 2282*bf2c3715SXin Li 80 CONTINUE 2283*bf2c3715SXin Li END IF 2284*bf2c3715SXin Li JA = 1 2285*bf2c3715SXin Li DO 90 J = 1, N 2286*bf2c3715SXin Li W( 1 ) = ALPHA*CONJG( Z( J, 2 ) ) 2287*bf2c3715SXin Li W( 2 ) = CONJG( ALPHA )*CONJG( Z( J, 1 ) ) 2288*bf2c3715SXin Li IF( UPPER )THEN 2289*bf2c3715SXin Li JJ = 1 2290*bf2c3715SXin Li LJ = J 2291*bf2c3715SXin Li ELSE 2292*bf2c3715SXin Li JJ = J 2293*bf2c3715SXin Li LJ = N - J + 1 2294*bf2c3715SXin Li END IF 2295*bf2c3715SXin Li CALL CMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ), 2296*bf2c3715SXin Li $ NMAX, W, 1, ONE, A( JJ, J ), 1, 2297*bf2c3715SXin Li $ YT, G, AA( JA ), EPS, ERR, FATAL, 2298*bf2c3715SXin Li $ NOUT, .TRUE. ) 2299*bf2c3715SXin Li IF( FULL )THEN 2300*bf2c3715SXin Li IF( UPPER )THEN 2301*bf2c3715SXin Li JA = JA + LDA 2302*bf2c3715SXin Li ELSE 2303*bf2c3715SXin Li JA = JA + LDA + 1 2304*bf2c3715SXin Li END IF 2305*bf2c3715SXin Li ELSE 2306*bf2c3715SXin Li JA = JA + LJ 2307*bf2c3715SXin Li END IF 2308*bf2c3715SXin Li ERRMAX = MAX( ERRMAX, ERR ) 2309*bf2c3715SXin Li* If got really bad answer, report and return. 2310*bf2c3715SXin Li IF( FATAL ) 2311*bf2c3715SXin Li $ GO TO 150 2312*bf2c3715SXin Li 90 CONTINUE 2313*bf2c3715SXin Li ELSE 2314*bf2c3715SXin Li* Avoid repeating tests with N.le.0. 2315*bf2c3715SXin Li IF( N.LE.0 ) 2316*bf2c3715SXin Li $ GO TO 140 2317*bf2c3715SXin Li END IF 2318*bf2c3715SXin Li* 2319*bf2c3715SXin Li 100 CONTINUE 2320*bf2c3715SXin Li* 2321*bf2c3715SXin Li 110 CONTINUE 2322*bf2c3715SXin Li* 2323*bf2c3715SXin Li 120 CONTINUE 2324*bf2c3715SXin Li* 2325*bf2c3715SXin Li 130 CONTINUE 2326*bf2c3715SXin Li* 2327*bf2c3715SXin Li 140 CONTINUE 2328*bf2c3715SXin Li* 2329*bf2c3715SXin Li* Report result. 2330*bf2c3715SXin Li* 2331*bf2c3715SXin Li IF( ERRMAX.LT.THRESH )THEN 2332*bf2c3715SXin Li WRITE( NOUT, FMT = 9999 )SNAME, NC 2333*bf2c3715SXin Li ELSE 2334*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX 2335*bf2c3715SXin Li END IF 2336*bf2c3715SXin Li GO TO 170 2337*bf2c3715SXin Li* 2338*bf2c3715SXin Li 150 CONTINUE 2339*bf2c3715SXin Li WRITE( NOUT, FMT = 9995 )J 2340*bf2c3715SXin Li* 2341*bf2c3715SXin Li 160 CONTINUE 2342*bf2c3715SXin Li WRITE( NOUT, FMT = 9996 )SNAME 2343*bf2c3715SXin Li IF( FULL )THEN 2344*bf2c3715SXin Li WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, 2345*bf2c3715SXin Li $ INCY, LDA 2346*bf2c3715SXin Li ELSE IF( PACKED )THEN 2347*bf2c3715SXin Li WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY 2348*bf2c3715SXin Li END IF 2349*bf2c3715SXin Li* 2350*bf2c3715SXin Li 170 CONTINUE 2351*bf2c3715SXin Li RETURN 2352*bf2c3715SXin Li* 2353*bf2c3715SXin Li 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', 2354*bf2c3715SXin Li $ 'S)' ) 2355*bf2c3715SXin Li 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', 2356*bf2c3715SXin Li $ 'ANGED INCORRECTLY *******' ) 2357*bf2c3715SXin Li 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', 2358*bf2c3715SXin Li $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, 2359*bf2c3715SXin Li $ ' - SUSPECT *******' ) 2360*bf2c3715SXin Li 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 2361*bf2c3715SXin Li 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 2362*bf2c3715SXin Li 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', 2363*bf2c3715SXin Li $ F4.1, '), X,', I2, ', Y,', I2, ', AP) ', 2364*bf2c3715SXin Li $ ' .' ) 2365*bf2c3715SXin Li 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', 2366*bf2c3715SXin Li $ F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ') ', 2367*bf2c3715SXin Li $ ' .' ) 2368*bf2c3715SXin Li 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', 2369*bf2c3715SXin Li $ '******' ) 2370*bf2c3715SXin Li* 2371*bf2c3715SXin Li* End of CCHK6. 2372*bf2c3715SXin Li* 2373*bf2c3715SXin Li END 2374*bf2c3715SXin Li SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) 2375*bf2c3715SXin Li* 2376*bf2c3715SXin Li* Tests the error exits from the Level 2 Blas. 2377*bf2c3715SXin Li* Requires a special version of the error-handling routine XERBLA. 2378*bf2c3715SXin Li* ALPHA, RALPHA, BETA, A, X and Y should not need to be defined. 2379*bf2c3715SXin Li* 2380*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 2381*bf2c3715SXin Li* 2382*bf2c3715SXin Li* -- Written on 10-August-1987. 2383*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 2384*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 2385*bf2c3715SXin Li* 2386*bf2c3715SXin Li* .. Scalar Arguments .. 2387*bf2c3715SXin Li INTEGER ISNUM, NOUT 2388*bf2c3715SXin Li CHARACTER*6 SRNAMT 2389*bf2c3715SXin Li* .. Scalars in Common .. 2390*bf2c3715SXin Li INTEGER INFOT, NOUTC 2391*bf2c3715SXin Li LOGICAL LERR, OK 2392*bf2c3715SXin Li* .. Local Scalars .. 2393*bf2c3715SXin Li COMPLEX ALPHA, BETA 2394*bf2c3715SXin Li REAL RALPHA 2395*bf2c3715SXin Li* .. Local Arrays .. 2396*bf2c3715SXin Li COMPLEX A( 1, 1 ), X( 1 ), Y( 1 ) 2397*bf2c3715SXin Li* .. External Subroutines .. 2398*bf2c3715SXin Li EXTERNAL CGBMV, CGEMV, CGERC, CGERU, CHBMV, CHEMV, CHER, 2399*bf2c3715SXin Li $ CHER2, CHKXER, CHPMV, CHPR, CHPR2, CTBMV, 2400*bf2c3715SXin Li $ CTBSV, CTPMV, CTPSV, CTRMV, CTRSV 2401*bf2c3715SXin Li* .. Common blocks .. 2402*bf2c3715SXin Li COMMON /INFOC/INFOT, NOUTC, OK, LERR 2403*bf2c3715SXin Li* .. Executable Statements .. 2404*bf2c3715SXin Li* OK is set to .FALSE. by the special version of XERBLA or by CHKXER 2405*bf2c3715SXin Li* if anything is wrong. 2406*bf2c3715SXin Li OK = .TRUE. 2407*bf2c3715SXin Li* LERR is set to .TRUE. by the special version of XERBLA each time 2408*bf2c3715SXin Li* it is called, and is then tested and re-set by CHKXER. 2409*bf2c3715SXin Li LERR = .FALSE. 2410*bf2c3715SXin Li GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, 2411*bf2c3715SXin Li $ 90, 100, 110, 120, 130, 140, 150, 160, 2412*bf2c3715SXin Li $ 170 )ISNUM 2413*bf2c3715SXin Li 10 INFOT = 1 2414*bf2c3715SXin Li CALL CGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2415*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2416*bf2c3715SXin Li INFOT = 2 2417*bf2c3715SXin Li CALL CGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2418*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2419*bf2c3715SXin Li INFOT = 3 2420*bf2c3715SXin Li CALL CGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2421*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2422*bf2c3715SXin Li INFOT = 6 2423*bf2c3715SXin Li CALL CGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2424*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2425*bf2c3715SXin Li INFOT = 8 2426*bf2c3715SXin Li CALL CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 2427*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2428*bf2c3715SXin Li INFOT = 11 2429*bf2c3715SXin Li CALL CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 2430*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2431*bf2c3715SXin Li GO TO 180 2432*bf2c3715SXin Li 20 INFOT = 1 2433*bf2c3715SXin Li CALL CGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2434*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2435*bf2c3715SXin Li INFOT = 2 2436*bf2c3715SXin Li CALL CGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2437*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2438*bf2c3715SXin Li INFOT = 3 2439*bf2c3715SXin Li CALL CGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2440*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2441*bf2c3715SXin Li INFOT = 4 2442*bf2c3715SXin Li CALL CGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2443*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2444*bf2c3715SXin Li INFOT = 5 2445*bf2c3715SXin Li CALL CGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2446*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2447*bf2c3715SXin Li INFOT = 8 2448*bf2c3715SXin Li CALL CGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2449*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2450*bf2c3715SXin Li INFOT = 10 2451*bf2c3715SXin Li CALL CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 2452*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2453*bf2c3715SXin Li INFOT = 13 2454*bf2c3715SXin Li CALL CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 2455*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2456*bf2c3715SXin Li GO TO 180 2457*bf2c3715SXin Li 30 INFOT = 1 2458*bf2c3715SXin Li CALL CHEMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2459*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2460*bf2c3715SXin Li INFOT = 2 2461*bf2c3715SXin Li CALL CHEMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2462*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2463*bf2c3715SXin Li INFOT = 5 2464*bf2c3715SXin Li CALL CHEMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2465*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2466*bf2c3715SXin Li INFOT = 7 2467*bf2c3715SXin Li CALL CHEMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 2468*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2469*bf2c3715SXin Li INFOT = 10 2470*bf2c3715SXin Li CALL CHEMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 2471*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2472*bf2c3715SXin Li GO TO 180 2473*bf2c3715SXin Li 40 INFOT = 1 2474*bf2c3715SXin Li CALL CHBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2475*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2476*bf2c3715SXin Li INFOT = 2 2477*bf2c3715SXin Li CALL CHBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2478*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2479*bf2c3715SXin Li INFOT = 3 2480*bf2c3715SXin Li CALL CHBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2481*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2482*bf2c3715SXin Li INFOT = 6 2483*bf2c3715SXin Li CALL CHBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) 2484*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2485*bf2c3715SXin Li INFOT = 8 2486*bf2c3715SXin Li CALL CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) 2487*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2488*bf2c3715SXin Li INFOT = 11 2489*bf2c3715SXin Li CALL CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) 2490*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2491*bf2c3715SXin Li GO TO 180 2492*bf2c3715SXin Li 50 INFOT = 1 2493*bf2c3715SXin Li CALL CHPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) 2494*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2495*bf2c3715SXin Li INFOT = 2 2496*bf2c3715SXin Li CALL CHPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) 2497*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2498*bf2c3715SXin Li INFOT = 6 2499*bf2c3715SXin Li CALL CHPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) 2500*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2501*bf2c3715SXin Li INFOT = 9 2502*bf2c3715SXin Li CALL CHPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) 2503*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2504*bf2c3715SXin Li GO TO 180 2505*bf2c3715SXin Li 60 INFOT = 1 2506*bf2c3715SXin Li CALL CTRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) 2507*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2508*bf2c3715SXin Li INFOT = 2 2509*bf2c3715SXin Li CALL CTRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) 2510*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2511*bf2c3715SXin Li INFOT = 3 2512*bf2c3715SXin Li CALL CTRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) 2513*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2514*bf2c3715SXin Li INFOT = 4 2515*bf2c3715SXin Li CALL CTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) 2516*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2517*bf2c3715SXin Li INFOT = 6 2518*bf2c3715SXin Li CALL CTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) 2519*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2520*bf2c3715SXin Li INFOT = 8 2521*bf2c3715SXin Li CALL CTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) 2522*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2523*bf2c3715SXin Li GO TO 180 2524*bf2c3715SXin Li 70 INFOT = 1 2525*bf2c3715SXin Li CALL CTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) 2526*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2527*bf2c3715SXin Li INFOT = 2 2528*bf2c3715SXin Li CALL CTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) 2529*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2530*bf2c3715SXin Li INFOT = 3 2531*bf2c3715SXin Li CALL CTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) 2532*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2533*bf2c3715SXin Li INFOT = 4 2534*bf2c3715SXin Li CALL CTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) 2535*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2536*bf2c3715SXin Li INFOT = 5 2537*bf2c3715SXin Li CALL CTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) 2538*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2539*bf2c3715SXin Li INFOT = 7 2540*bf2c3715SXin Li CALL CTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) 2541*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2542*bf2c3715SXin Li INFOT = 9 2543*bf2c3715SXin Li CALL CTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) 2544*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2545*bf2c3715SXin Li GO TO 180 2546*bf2c3715SXin Li 80 INFOT = 1 2547*bf2c3715SXin Li CALL CTPMV( '/', 'N', 'N', 0, A, X, 1 ) 2548*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2549*bf2c3715SXin Li INFOT = 2 2550*bf2c3715SXin Li CALL CTPMV( 'U', '/', 'N', 0, A, X, 1 ) 2551*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2552*bf2c3715SXin Li INFOT = 3 2553*bf2c3715SXin Li CALL CTPMV( 'U', 'N', '/', 0, A, X, 1 ) 2554*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2555*bf2c3715SXin Li INFOT = 4 2556*bf2c3715SXin Li CALL CTPMV( 'U', 'N', 'N', -1, A, X, 1 ) 2557*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2558*bf2c3715SXin Li INFOT = 7 2559*bf2c3715SXin Li CALL CTPMV( 'U', 'N', 'N', 0, A, X, 0 ) 2560*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2561*bf2c3715SXin Li GO TO 180 2562*bf2c3715SXin Li 90 INFOT = 1 2563*bf2c3715SXin Li CALL CTRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) 2564*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2565*bf2c3715SXin Li INFOT = 2 2566*bf2c3715SXin Li CALL CTRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) 2567*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2568*bf2c3715SXin Li INFOT = 3 2569*bf2c3715SXin Li CALL CTRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) 2570*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2571*bf2c3715SXin Li INFOT = 4 2572*bf2c3715SXin Li CALL CTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) 2573*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2574*bf2c3715SXin Li INFOT = 6 2575*bf2c3715SXin Li CALL CTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) 2576*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2577*bf2c3715SXin Li INFOT = 8 2578*bf2c3715SXin Li CALL CTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) 2579*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2580*bf2c3715SXin Li GO TO 180 2581*bf2c3715SXin Li 100 INFOT = 1 2582*bf2c3715SXin Li CALL CTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) 2583*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2584*bf2c3715SXin Li INFOT = 2 2585*bf2c3715SXin Li CALL CTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) 2586*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2587*bf2c3715SXin Li INFOT = 3 2588*bf2c3715SXin Li CALL CTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) 2589*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2590*bf2c3715SXin Li INFOT = 4 2591*bf2c3715SXin Li CALL CTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) 2592*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2593*bf2c3715SXin Li INFOT = 5 2594*bf2c3715SXin Li CALL CTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) 2595*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2596*bf2c3715SXin Li INFOT = 7 2597*bf2c3715SXin Li CALL CTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) 2598*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2599*bf2c3715SXin Li INFOT = 9 2600*bf2c3715SXin Li CALL CTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) 2601*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2602*bf2c3715SXin Li GO TO 180 2603*bf2c3715SXin Li 110 INFOT = 1 2604*bf2c3715SXin Li CALL CTPSV( '/', 'N', 'N', 0, A, X, 1 ) 2605*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2606*bf2c3715SXin Li INFOT = 2 2607*bf2c3715SXin Li CALL CTPSV( 'U', '/', 'N', 0, A, X, 1 ) 2608*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2609*bf2c3715SXin Li INFOT = 3 2610*bf2c3715SXin Li CALL CTPSV( 'U', 'N', '/', 0, A, X, 1 ) 2611*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2612*bf2c3715SXin Li INFOT = 4 2613*bf2c3715SXin Li CALL CTPSV( 'U', 'N', 'N', -1, A, X, 1 ) 2614*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2615*bf2c3715SXin Li INFOT = 7 2616*bf2c3715SXin Li CALL CTPSV( 'U', 'N', 'N', 0, A, X, 0 ) 2617*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2618*bf2c3715SXin Li GO TO 180 2619*bf2c3715SXin Li 120 INFOT = 1 2620*bf2c3715SXin Li CALL CGERC( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) 2621*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2622*bf2c3715SXin Li INFOT = 2 2623*bf2c3715SXin Li CALL CGERC( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) 2624*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2625*bf2c3715SXin Li INFOT = 5 2626*bf2c3715SXin Li CALL CGERC( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) 2627*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2628*bf2c3715SXin Li INFOT = 7 2629*bf2c3715SXin Li CALL CGERC( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) 2630*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2631*bf2c3715SXin Li INFOT = 9 2632*bf2c3715SXin Li CALL CGERC( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) 2633*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2634*bf2c3715SXin Li GO TO 180 2635*bf2c3715SXin Li 130 INFOT = 1 2636*bf2c3715SXin Li CALL CGERU( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) 2637*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2638*bf2c3715SXin Li INFOT = 2 2639*bf2c3715SXin Li CALL CGERU( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) 2640*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2641*bf2c3715SXin Li INFOT = 5 2642*bf2c3715SXin Li CALL CGERU( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) 2643*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2644*bf2c3715SXin Li INFOT = 7 2645*bf2c3715SXin Li CALL CGERU( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) 2646*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2647*bf2c3715SXin Li INFOT = 9 2648*bf2c3715SXin Li CALL CGERU( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) 2649*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2650*bf2c3715SXin Li GO TO 180 2651*bf2c3715SXin Li 140 INFOT = 1 2652*bf2c3715SXin Li CALL CHER( '/', 0, RALPHA, X, 1, A, 1 ) 2653*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2654*bf2c3715SXin Li INFOT = 2 2655*bf2c3715SXin Li CALL CHER( 'U', -1, RALPHA, X, 1, A, 1 ) 2656*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2657*bf2c3715SXin Li INFOT = 5 2658*bf2c3715SXin Li CALL CHER( 'U', 0, RALPHA, X, 0, A, 1 ) 2659*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2660*bf2c3715SXin Li INFOT = 7 2661*bf2c3715SXin Li CALL CHER( 'U', 2, RALPHA, X, 1, A, 1 ) 2662*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2663*bf2c3715SXin Li GO TO 180 2664*bf2c3715SXin Li 150 INFOT = 1 2665*bf2c3715SXin Li CALL CHPR( '/', 0, RALPHA, X, 1, A ) 2666*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2667*bf2c3715SXin Li INFOT = 2 2668*bf2c3715SXin Li CALL CHPR( 'U', -1, RALPHA, X, 1, A ) 2669*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2670*bf2c3715SXin Li INFOT = 5 2671*bf2c3715SXin Li CALL CHPR( 'U', 0, RALPHA, X, 0, A ) 2672*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2673*bf2c3715SXin Li GO TO 180 2674*bf2c3715SXin Li 160 INFOT = 1 2675*bf2c3715SXin Li CALL CHER2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) 2676*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2677*bf2c3715SXin Li INFOT = 2 2678*bf2c3715SXin Li CALL CHER2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) 2679*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2680*bf2c3715SXin Li INFOT = 5 2681*bf2c3715SXin Li CALL CHER2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) 2682*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2683*bf2c3715SXin Li INFOT = 7 2684*bf2c3715SXin Li CALL CHER2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) 2685*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2686*bf2c3715SXin Li INFOT = 9 2687*bf2c3715SXin Li CALL CHER2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) 2688*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2689*bf2c3715SXin Li GO TO 180 2690*bf2c3715SXin Li 170 INFOT = 1 2691*bf2c3715SXin Li CALL CHPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) 2692*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2693*bf2c3715SXin Li INFOT = 2 2694*bf2c3715SXin Li CALL CHPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) 2695*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2696*bf2c3715SXin Li INFOT = 5 2697*bf2c3715SXin Li CALL CHPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) 2698*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2699*bf2c3715SXin Li INFOT = 7 2700*bf2c3715SXin Li CALL CHPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) 2701*bf2c3715SXin Li CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 2702*bf2c3715SXin Li* 2703*bf2c3715SXin Li 180 IF( OK )THEN 2704*bf2c3715SXin Li WRITE( NOUT, FMT = 9999 )SRNAMT 2705*bf2c3715SXin Li ELSE 2706*bf2c3715SXin Li WRITE( NOUT, FMT = 9998 )SRNAMT 2707*bf2c3715SXin Li END IF 2708*bf2c3715SXin Li RETURN 2709*bf2c3715SXin Li* 2710*bf2c3715SXin Li 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 2711*bf2c3715SXin Li 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', 2712*bf2c3715SXin Li $ '**' ) 2713*bf2c3715SXin Li* 2714*bf2c3715SXin Li* End of CCHKE. 2715*bf2c3715SXin Li* 2716*bf2c3715SXin Li END 2717*bf2c3715SXin Li SUBROUTINE CMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, 2718*bf2c3715SXin Li $ KU, RESET, TRANSL ) 2719*bf2c3715SXin Li* 2720*bf2c3715SXin Li* Generates values for an M by N matrix A within the bandwidth 2721*bf2c3715SXin Li* defined by KL and KU. 2722*bf2c3715SXin Li* Stores the values in the array AA in the data structure required 2723*bf2c3715SXin Li* by the routine, with unwanted elements set to rogue value. 2724*bf2c3715SXin Li* 2725*bf2c3715SXin Li* TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'. 2726*bf2c3715SXin Li* 2727*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 2728*bf2c3715SXin Li* 2729*bf2c3715SXin Li* -- Written on 10-August-1987. 2730*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 2731*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 2732*bf2c3715SXin Li* 2733*bf2c3715SXin Li* .. Parameters .. 2734*bf2c3715SXin Li COMPLEX ZERO, ONE 2735*bf2c3715SXin Li PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) 2736*bf2c3715SXin Li COMPLEX ROGUE 2737*bf2c3715SXin Li PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) 2738*bf2c3715SXin Li REAL RZERO 2739*bf2c3715SXin Li PARAMETER ( RZERO = 0.0 ) 2740*bf2c3715SXin Li REAL RROGUE 2741*bf2c3715SXin Li PARAMETER ( RROGUE = -1.0E10 ) 2742*bf2c3715SXin Li* .. Scalar Arguments .. 2743*bf2c3715SXin Li COMPLEX TRANSL 2744*bf2c3715SXin Li INTEGER KL, KU, LDA, M, N, NMAX 2745*bf2c3715SXin Li LOGICAL RESET 2746*bf2c3715SXin Li CHARACTER*1 DIAG, UPLO 2747*bf2c3715SXin Li CHARACTER*2 TYPE 2748*bf2c3715SXin Li* .. Array Arguments .. 2749*bf2c3715SXin Li COMPLEX A( NMAX, * ), AA( * ) 2750*bf2c3715SXin Li* .. Local Scalars .. 2751*bf2c3715SXin Li INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK 2752*bf2c3715SXin Li LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER 2753*bf2c3715SXin Li* .. External Functions .. 2754*bf2c3715SXin Li COMPLEX CBEG 2755*bf2c3715SXin Li EXTERNAL CBEG 2756*bf2c3715SXin Li* .. Intrinsic Functions .. 2757*bf2c3715SXin Li INTRINSIC CMPLX, CONJG, MAX, MIN, REAL 2758*bf2c3715SXin Li* .. Executable Statements .. 2759*bf2c3715SXin Li GEN = TYPE( 1: 1 ).EQ.'G' 2760*bf2c3715SXin Li SYM = TYPE( 1: 1 ).EQ.'H' 2761*bf2c3715SXin Li TRI = TYPE( 1: 1 ).EQ.'T' 2762*bf2c3715SXin Li UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' 2763*bf2c3715SXin Li LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' 2764*bf2c3715SXin Li UNIT = TRI.AND.DIAG.EQ.'U' 2765*bf2c3715SXin Li* 2766*bf2c3715SXin Li* Generate data in array A. 2767*bf2c3715SXin Li* 2768*bf2c3715SXin Li DO 20 J = 1, N 2769*bf2c3715SXin Li DO 10 I = 1, M 2770*bf2c3715SXin Li IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) 2771*bf2c3715SXin Li $ THEN 2772*bf2c3715SXin Li IF( ( I.LE.J.AND.J - I.LE.KU ).OR. 2773*bf2c3715SXin Li $ ( I.GE.J.AND.I - J.LE.KL ) )THEN 2774*bf2c3715SXin Li A( I, J ) = CBEG( RESET ) + TRANSL 2775*bf2c3715SXin Li ELSE 2776*bf2c3715SXin Li A( I, J ) = ZERO 2777*bf2c3715SXin Li END IF 2778*bf2c3715SXin Li IF( I.NE.J )THEN 2779*bf2c3715SXin Li IF( SYM )THEN 2780*bf2c3715SXin Li A( J, I ) = CONJG( A( I, J ) ) 2781*bf2c3715SXin Li ELSE IF( TRI )THEN 2782*bf2c3715SXin Li A( J, I ) = ZERO 2783*bf2c3715SXin Li END IF 2784*bf2c3715SXin Li END IF 2785*bf2c3715SXin Li END IF 2786*bf2c3715SXin Li 10 CONTINUE 2787*bf2c3715SXin Li IF( SYM ) 2788*bf2c3715SXin Li $ A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) 2789*bf2c3715SXin Li IF( TRI ) 2790*bf2c3715SXin Li $ A( J, J ) = A( J, J ) + ONE 2791*bf2c3715SXin Li IF( UNIT ) 2792*bf2c3715SXin Li $ A( J, J ) = ONE 2793*bf2c3715SXin Li 20 CONTINUE 2794*bf2c3715SXin Li* 2795*bf2c3715SXin Li* Store elements in array AS in data structure required by routine. 2796*bf2c3715SXin Li* 2797*bf2c3715SXin Li IF( TYPE.EQ.'GE' )THEN 2798*bf2c3715SXin Li DO 50 J = 1, N 2799*bf2c3715SXin Li DO 30 I = 1, M 2800*bf2c3715SXin Li AA( I + ( J - 1 )*LDA ) = A( I, J ) 2801*bf2c3715SXin Li 30 CONTINUE 2802*bf2c3715SXin Li DO 40 I = M + 1, LDA 2803*bf2c3715SXin Li AA( I + ( J - 1 )*LDA ) = ROGUE 2804*bf2c3715SXin Li 40 CONTINUE 2805*bf2c3715SXin Li 50 CONTINUE 2806*bf2c3715SXin Li ELSE IF( TYPE.EQ.'GB' )THEN 2807*bf2c3715SXin Li DO 90 J = 1, N 2808*bf2c3715SXin Li DO 60 I1 = 1, KU + 1 - J 2809*bf2c3715SXin Li AA( I1 + ( J - 1 )*LDA ) = ROGUE 2810*bf2c3715SXin Li 60 CONTINUE 2811*bf2c3715SXin Li DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J ) 2812*bf2c3715SXin Li AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) 2813*bf2c3715SXin Li 70 CONTINUE 2814*bf2c3715SXin Li DO 80 I3 = I2, LDA 2815*bf2c3715SXin Li AA( I3 + ( J - 1 )*LDA ) = ROGUE 2816*bf2c3715SXin Li 80 CONTINUE 2817*bf2c3715SXin Li 90 CONTINUE 2818*bf2c3715SXin Li ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'TR' )THEN 2819*bf2c3715SXin Li DO 130 J = 1, N 2820*bf2c3715SXin Li IF( UPPER )THEN 2821*bf2c3715SXin Li IBEG = 1 2822*bf2c3715SXin Li IF( UNIT )THEN 2823*bf2c3715SXin Li IEND = J - 1 2824*bf2c3715SXin Li ELSE 2825*bf2c3715SXin Li IEND = J 2826*bf2c3715SXin Li END IF 2827*bf2c3715SXin Li ELSE 2828*bf2c3715SXin Li IF( UNIT )THEN 2829*bf2c3715SXin Li IBEG = J + 1 2830*bf2c3715SXin Li ELSE 2831*bf2c3715SXin Li IBEG = J 2832*bf2c3715SXin Li END IF 2833*bf2c3715SXin Li IEND = N 2834*bf2c3715SXin Li END IF 2835*bf2c3715SXin Li DO 100 I = 1, IBEG - 1 2836*bf2c3715SXin Li AA( I + ( J - 1 )*LDA ) = ROGUE 2837*bf2c3715SXin Li 100 CONTINUE 2838*bf2c3715SXin Li DO 110 I = IBEG, IEND 2839*bf2c3715SXin Li AA( I + ( J - 1 )*LDA ) = A( I, J ) 2840*bf2c3715SXin Li 110 CONTINUE 2841*bf2c3715SXin Li DO 120 I = IEND + 1, LDA 2842*bf2c3715SXin Li AA( I + ( J - 1 )*LDA ) = ROGUE 2843*bf2c3715SXin Li 120 CONTINUE 2844*bf2c3715SXin Li IF( SYM )THEN 2845*bf2c3715SXin Li JJ = J + ( J - 1 )*LDA 2846*bf2c3715SXin Li AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) 2847*bf2c3715SXin Li END IF 2848*bf2c3715SXin Li 130 CONTINUE 2849*bf2c3715SXin Li ELSE IF( TYPE.EQ.'HB'.OR.TYPE.EQ.'TB' )THEN 2850*bf2c3715SXin Li DO 170 J = 1, N 2851*bf2c3715SXin Li IF( UPPER )THEN 2852*bf2c3715SXin Li KK = KL + 1 2853*bf2c3715SXin Li IBEG = MAX( 1, KL + 2 - J ) 2854*bf2c3715SXin Li IF( UNIT )THEN 2855*bf2c3715SXin Li IEND = KL 2856*bf2c3715SXin Li ELSE 2857*bf2c3715SXin Li IEND = KL + 1 2858*bf2c3715SXin Li END IF 2859*bf2c3715SXin Li ELSE 2860*bf2c3715SXin Li KK = 1 2861*bf2c3715SXin Li IF( UNIT )THEN 2862*bf2c3715SXin Li IBEG = 2 2863*bf2c3715SXin Li ELSE 2864*bf2c3715SXin Li IBEG = 1 2865*bf2c3715SXin Li END IF 2866*bf2c3715SXin Li IEND = MIN( KL + 1, 1 + M - J ) 2867*bf2c3715SXin Li END IF 2868*bf2c3715SXin Li DO 140 I = 1, IBEG - 1 2869*bf2c3715SXin Li AA( I + ( J - 1 )*LDA ) = ROGUE 2870*bf2c3715SXin Li 140 CONTINUE 2871*bf2c3715SXin Li DO 150 I = IBEG, IEND 2872*bf2c3715SXin Li AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) 2873*bf2c3715SXin Li 150 CONTINUE 2874*bf2c3715SXin Li DO 160 I = IEND + 1, LDA 2875*bf2c3715SXin Li AA( I + ( J - 1 )*LDA ) = ROGUE 2876*bf2c3715SXin Li 160 CONTINUE 2877*bf2c3715SXin Li IF( SYM )THEN 2878*bf2c3715SXin Li JJ = KK + ( J - 1 )*LDA 2879*bf2c3715SXin Li AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) 2880*bf2c3715SXin Li END IF 2881*bf2c3715SXin Li 170 CONTINUE 2882*bf2c3715SXin Li ELSE IF( TYPE.EQ.'HP'.OR.TYPE.EQ.'TP' )THEN 2883*bf2c3715SXin Li IOFF = 0 2884*bf2c3715SXin Li DO 190 J = 1, N 2885*bf2c3715SXin Li IF( UPPER )THEN 2886*bf2c3715SXin Li IBEG = 1 2887*bf2c3715SXin Li IEND = J 2888*bf2c3715SXin Li ELSE 2889*bf2c3715SXin Li IBEG = J 2890*bf2c3715SXin Li IEND = N 2891*bf2c3715SXin Li END IF 2892*bf2c3715SXin Li DO 180 I = IBEG, IEND 2893*bf2c3715SXin Li IOFF = IOFF + 1 2894*bf2c3715SXin Li AA( IOFF ) = A( I, J ) 2895*bf2c3715SXin Li IF( I.EQ.J )THEN 2896*bf2c3715SXin Li IF( UNIT ) 2897*bf2c3715SXin Li $ AA( IOFF ) = ROGUE 2898*bf2c3715SXin Li IF( SYM ) 2899*bf2c3715SXin Li $ AA( IOFF ) = CMPLX( REAL( AA( IOFF ) ), RROGUE ) 2900*bf2c3715SXin Li END IF 2901*bf2c3715SXin Li 180 CONTINUE 2902*bf2c3715SXin Li 190 CONTINUE 2903*bf2c3715SXin Li END IF 2904*bf2c3715SXin Li RETURN 2905*bf2c3715SXin Li* 2906*bf2c3715SXin Li* End of CMAKE. 2907*bf2c3715SXin Li* 2908*bf2c3715SXin Li END 2909*bf2c3715SXin Li SUBROUTINE CMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, 2910*bf2c3715SXin Li $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV ) 2911*bf2c3715SXin Li* 2912*bf2c3715SXin Li* Checks the results of the computational tests. 2913*bf2c3715SXin Li* 2914*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 2915*bf2c3715SXin Li* 2916*bf2c3715SXin Li* -- Written on 10-August-1987. 2917*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 2918*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 2919*bf2c3715SXin Li* 2920*bf2c3715SXin Li* .. Parameters .. 2921*bf2c3715SXin Li COMPLEX ZERO 2922*bf2c3715SXin Li PARAMETER ( ZERO = ( 0.0, 0.0 ) ) 2923*bf2c3715SXin Li REAL RZERO, RONE 2924*bf2c3715SXin Li PARAMETER ( RZERO = 0.0, RONE = 1.0 ) 2925*bf2c3715SXin Li* .. Scalar Arguments .. 2926*bf2c3715SXin Li COMPLEX ALPHA, BETA 2927*bf2c3715SXin Li REAL EPS, ERR 2928*bf2c3715SXin Li INTEGER INCX, INCY, M, N, NMAX, NOUT 2929*bf2c3715SXin Li LOGICAL FATAL, MV 2930*bf2c3715SXin Li CHARACTER*1 TRANS 2931*bf2c3715SXin Li* .. Array Arguments .. 2932*bf2c3715SXin Li COMPLEX A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * ) 2933*bf2c3715SXin Li REAL G( * ) 2934*bf2c3715SXin Li* .. Local Scalars .. 2935*bf2c3715SXin Li COMPLEX C 2936*bf2c3715SXin Li REAL ERRI 2937*bf2c3715SXin Li INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL 2938*bf2c3715SXin Li LOGICAL CTRAN, TRAN 2939*bf2c3715SXin Li* .. Intrinsic Functions .. 2940*bf2c3715SXin Li INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT 2941*bf2c3715SXin Li* .. Statement Functions .. 2942*bf2c3715SXin Li REAL ABS1 2943*bf2c3715SXin Li* .. Statement Function definitions .. 2944*bf2c3715SXin Li ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) ) 2945*bf2c3715SXin Li* .. Executable Statements .. 2946*bf2c3715SXin Li TRAN = TRANS.EQ.'T' 2947*bf2c3715SXin Li CTRAN = TRANS.EQ.'C' 2948*bf2c3715SXin Li IF( TRAN.OR.CTRAN )THEN 2949*bf2c3715SXin Li ML = N 2950*bf2c3715SXin Li NL = M 2951*bf2c3715SXin Li ELSE 2952*bf2c3715SXin Li ML = M 2953*bf2c3715SXin Li NL = N 2954*bf2c3715SXin Li END IF 2955*bf2c3715SXin Li IF( INCX.LT.0 )THEN 2956*bf2c3715SXin Li KX = NL 2957*bf2c3715SXin Li INCXL = -1 2958*bf2c3715SXin Li ELSE 2959*bf2c3715SXin Li KX = 1 2960*bf2c3715SXin Li INCXL = 1 2961*bf2c3715SXin Li END IF 2962*bf2c3715SXin Li IF( INCY.LT.0 )THEN 2963*bf2c3715SXin Li KY = ML 2964*bf2c3715SXin Li INCYL = -1 2965*bf2c3715SXin Li ELSE 2966*bf2c3715SXin Li KY = 1 2967*bf2c3715SXin Li INCYL = 1 2968*bf2c3715SXin Li END IF 2969*bf2c3715SXin Li* 2970*bf2c3715SXin Li* Compute expected result in YT using data in A, X and Y. 2971*bf2c3715SXin Li* Compute gauges in G. 2972*bf2c3715SXin Li* 2973*bf2c3715SXin Li IY = KY 2974*bf2c3715SXin Li DO 40 I = 1, ML 2975*bf2c3715SXin Li YT( IY ) = ZERO 2976*bf2c3715SXin Li G( IY ) = RZERO 2977*bf2c3715SXin Li JX = KX 2978*bf2c3715SXin Li IF( TRAN )THEN 2979*bf2c3715SXin Li DO 10 J = 1, NL 2980*bf2c3715SXin Li YT( IY ) = YT( IY ) + A( J, I )*X( JX ) 2981*bf2c3715SXin Li G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) 2982*bf2c3715SXin Li JX = JX + INCXL 2983*bf2c3715SXin Li 10 CONTINUE 2984*bf2c3715SXin Li ELSE IF( CTRAN )THEN 2985*bf2c3715SXin Li DO 20 J = 1, NL 2986*bf2c3715SXin Li YT( IY ) = YT( IY ) + CONJG( A( J, I ) )*X( JX ) 2987*bf2c3715SXin Li G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) 2988*bf2c3715SXin Li JX = JX + INCXL 2989*bf2c3715SXin Li 20 CONTINUE 2990*bf2c3715SXin Li ELSE 2991*bf2c3715SXin Li DO 30 J = 1, NL 2992*bf2c3715SXin Li YT( IY ) = YT( IY ) + A( I, J )*X( JX ) 2993*bf2c3715SXin Li G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) ) 2994*bf2c3715SXin Li JX = JX + INCXL 2995*bf2c3715SXin Li 30 CONTINUE 2996*bf2c3715SXin Li END IF 2997*bf2c3715SXin Li YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) 2998*bf2c3715SXin Li G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) ) 2999*bf2c3715SXin Li IY = IY + INCYL 3000*bf2c3715SXin Li 40 CONTINUE 3001*bf2c3715SXin Li* 3002*bf2c3715SXin Li* Compute the error ratio for this result. 3003*bf2c3715SXin Li* 3004*bf2c3715SXin Li ERR = ZERO 3005*bf2c3715SXin Li DO 50 I = 1, ML 3006*bf2c3715SXin Li ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS 3007*bf2c3715SXin Li IF( G( I ).NE.RZERO ) 3008*bf2c3715SXin Li $ ERRI = ERRI/G( I ) 3009*bf2c3715SXin Li ERR = MAX( ERR, ERRI ) 3010*bf2c3715SXin Li IF( ERR*SQRT( EPS ).GE.RONE ) 3011*bf2c3715SXin Li $ GO TO 60 3012*bf2c3715SXin Li 50 CONTINUE 3013*bf2c3715SXin Li* If the loop completes, all results are at least half accurate. 3014*bf2c3715SXin Li GO TO 80 3015*bf2c3715SXin Li* 3016*bf2c3715SXin Li* Report fatal error. 3017*bf2c3715SXin Li* 3018*bf2c3715SXin Li 60 FATAL = .TRUE. 3019*bf2c3715SXin Li WRITE( NOUT, FMT = 9999 ) 3020*bf2c3715SXin Li DO 70 I = 1, ML 3021*bf2c3715SXin Li IF( MV )THEN 3022*bf2c3715SXin Li WRITE( NOUT, FMT = 9998 )I, YT( I ), 3023*bf2c3715SXin Li $ YY( 1 + ( I - 1 )*ABS( INCY ) ) 3024*bf2c3715SXin Li ELSE 3025*bf2c3715SXin Li WRITE( NOUT, FMT = 9998 )I, 3026*bf2c3715SXin Li $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I ) 3027*bf2c3715SXin Li END IF 3028*bf2c3715SXin Li 70 CONTINUE 3029*bf2c3715SXin Li* 3030*bf2c3715SXin Li 80 CONTINUE 3031*bf2c3715SXin Li RETURN 3032*bf2c3715SXin Li* 3033*bf2c3715SXin Li 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', 3034*bf2c3715SXin Li $ 'F ACCURATE *******', /' EXPECTED RE', 3035*bf2c3715SXin Li $ 'SULT COMPUTED RESULT' ) 3036*bf2c3715SXin Li 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) 3037*bf2c3715SXin Li* 3038*bf2c3715SXin Li* End of CMVCH. 3039*bf2c3715SXin Li* 3040*bf2c3715SXin Li END 3041*bf2c3715SXin Li LOGICAL FUNCTION LCE( RI, RJ, LR ) 3042*bf2c3715SXin Li* 3043*bf2c3715SXin Li* Tests if two arrays are identical. 3044*bf2c3715SXin Li* 3045*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 3046*bf2c3715SXin Li* 3047*bf2c3715SXin Li* -- Written on 10-August-1987. 3048*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 3049*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 3050*bf2c3715SXin Li* 3051*bf2c3715SXin Li* .. Scalar Arguments .. 3052*bf2c3715SXin Li INTEGER LR 3053*bf2c3715SXin Li* .. Array Arguments .. 3054*bf2c3715SXin Li COMPLEX RI( * ), RJ( * ) 3055*bf2c3715SXin Li* .. Local Scalars .. 3056*bf2c3715SXin Li INTEGER I 3057*bf2c3715SXin Li* .. Executable Statements .. 3058*bf2c3715SXin Li DO 10 I = 1, LR 3059*bf2c3715SXin Li IF( RI( I ).NE.RJ( I ) ) 3060*bf2c3715SXin Li $ GO TO 20 3061*bf2c3715SXin Li 10 CONTINUE 3062*bf2c3715SXin Li LCE = .TRUE. 3063*bf2c3715SXin Li GO TO 30 3064*bf2c3715SXin Li 20 CONTINUE 3065*bf2c3715SXin Li LCE = .FALSE. 3066*bf2c3715SXin Li 30 RETURN 3067*bf2c3715SXin Li* 3068*bf2c3715SXin Li* End of LCE. 3069*bf2c3715SXin Li* 3070*bf2c3715SXin Li END 3071*bf2c3715SXin Li LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA ) 3072*bf2c3715SXin Li* 3073*bf2c3715SXin Li* Tests if selected elements in two arrays are equal. 3074*bf2c3715SXin Li* 3075*bf2c3715SXin Li* TYPE is 'GE', 'HE' or 'HP'. 3076*bf2c3715SXin Li* 3077*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 3078*bf2c3715SXin Li* 3079*bf2c3715SXin Li* -- Written on 10-August-1987. 3080*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 3081*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 3082*bf2c3715SXin Li* 3083*bf2c3715SXin Li* .. Scalar Arguments .. 3084*bf2c3715SXin Li INTEGER LDA, M, N 3085*bf2c3715SXin Li CHARACTER*1 UPLO 3086*bf2c3715SXin Li CHARACTER*2 TYPE 3087*bf2c3715SXin Li* .. Array Arguments .. 3088*bf2c3715SXin Li COMPLEX AA( LDA, * ), AS( LDA, * ) 3089*bf2c3715SXin Li* .. Local Scalars .. 3090*bf2c3715SXin Li INTEGER I, IBEG, IEND, J 3091*bf2c3715SXin Li LOGICAL UPPER 3092*bf2c3715SXin Li* .. Executable Statements .. 3093*bf2c3715SXin Li UPPER = UPLO.EQ.'U' 3094*bf2c3715SXin Li IF( TYPE.EQ.'GE' )THEN 3095*bf2c3715SXin Li DO 20 J = 1, N 3096*bf2c3715SXin Li DO 10 I = M + 1, LDA 3097*bf2c3715SXin Li IF( AA( I, J ).NE.AS( I, J ) ) 3098*bf2c3715SXin Li $ GO TO 70 3099*bf2c3715SXin Li 10 CONTINUE 3100*bf2c3715SXin Li 20 CONTINUE 3101*bf2c3715SXin Li ELSE IF( TYPE.EQ.'HE' )THEN 3102*bf2c3715SXin Li DO 50 J = 1, N 3103*bf2c3715SXin Li IF( UPPER )THEN 3104*bf2c3715SXin Li IBEG = 1 3105*bf2c3715SXin Li IEND = J 3106*bf2c3715SXin Li ELSE 3107*bf2c3715SXin Li IBEG = J 3108*bf2c3715SXin Li IEND = N 3109*bf2c3715SXin Li END IF 3110*bf2c3715SXin Li DO 30 I = 1, IBEG - 1 3111*bf2c3715SXin Li IF( AA( I, J ).NE.AS( I, J ) ) 3112*bf2c3715SXin Li $ GO TO 70 3113*bf2c3715SXin Li 30 CONTINUE 3114*bf2c3715SXin Li DO 40 I = IEND + 1, LDA 3115*bf2c3715SXin Li IF( AA( I, J ).NE.AS( I, J ) ) 3116*bf2c3715SXin Li $ GO TO 70 3117*bf2c3715SXin Li 40 CONTINUE 3118*bf2c3715SXin Li 50 CONTINUE 3119*bf2c3715SXin Li END IF 3120*bf2c3715SXin Li* 3121*bf2c3715SXin Li LCERES = .TRUE. 3122*bf2c3715SXin Li GO TO 80 3123*bf2c3715SXin Li 70 CONTINUE 3124*bf2c3715SXin Li LCERES = .FALSE. 3125*bf2c3715SXin Li 80 RETURN 3126*bf2c3715SXin Li* 3127*bf2c3715SXin Li* End of LCERES. 3128*bf2c3715SXin Li* 3129*bf2c3715SXin Li END 3130*bf2c3715SXin Li COMPLEX FUNCTION CBEG( RESET ) 3131*bf2c3715SXin Li* 3132*bf2c3715SXin Li* Generates complex numbers as pairs of random numbers uniformly 3133*bf2c3715SXin Li* distributed between -0.5 and 0.5. 3134*bf2c3715SXin Li* 3135*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 3136*bf2c3715SXin Li* 3137*bf2c3715SXin Li* -- Written on 10-August-1987. 3138*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 3139*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 3140*bf2c3715SXin Li* 3141*bf2c3715SXin Li* .. Scalar Arguments .. 3142*bf2c3715SXin Li LOGICAL RESET 3143*bf2c3715SXin Li* .. Local Scalars .. 3144*bf2c3715SXin Li INTEGER I, IC, J, MI, MJ 3145*bf2c3715SXin Li* .. Save statement .. 3146*bf2c3715SXin Li SAVE I, IC, J, MI, MJ 3147*bf2c3715SXin Li* .. Intrinsic Functions .. 3148*bf2c3715SXin Li INTRINSIC CMPLX 3149*bf2c3715SXin Li* .. Executable Statements .. 3150*bf2c3715SXin Li IF( RESET )THEN 3151*bf2c3715SXin Li* Initialize local variables. 3152*bf2c3715SXin Li MI = 891 3153*bf2c3715SXin Li MJ = 457 3154*bf2c3715SXin Li I = 7 3155*bf2c3715SXin Li J = 7 3156*bf2c3715SXin Li IC = 0 3157*bf2c3715SXin Li RESET = .FALSE. 3158*bf2c3715SXin Li END IF 3159*bf2c3715SXin Li* 3160*bf2c3715SXin Li* The sequence of values of I or J is bounded between 1 and 999. 3161*bf2c3715SXin Li* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. 3162*bf2c3715SXin Li* If initial I or J = 4 or 8, the period will be 25. 3163*bf2c3715SXin Li* If initial I or J = 5, the period will be 10. 3164*bf2c3715SXin Li* IC is used to break up the period by skipping 1 value of I or J 3165*bf2c3715SXin Li* in 6. 3166*bf2c3715SXin Li* 3167*bf2c3715SXin Li IC = IC + 1 3168*bf2c3715SXin Li 10 I = I*MI 3169*bf2c3715SXin Li J = J*MJ 3170*bf2c3715SXin Li I = I - 1000*( I/1000 ) 3171*bf2c3715SXin Li J = J - 1000*( J/1000 ) 3172*bf2c3715SXin Li IF( IC.GE.5 )THEN 3173*bf2c3715SXin Li IC = 0 3174*bf2c3715SXin Li GO TO 10 3175*bf2c3715SXin Li END IF 3176*bf2c3715SXin Li CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) 3177*bf2c3715SXin Li RETURN 3178*bf2c3715SXin Li* 3179*bf2c3715SXin Li* End of CBEG. 3180*bf2c3715SXin Li* 3181*bf2c3715SXin Li END 3182*bf2c3715SXin Li REAL FUNCTION SDIFF( X, Y ) 3183*bf2c3715SXin Li* 3184*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 3185*bf2c3715SXin Li* 3186*bf2c3715SXin Li* -- Written on 10-August-1987. 3187*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 3188*bf2c3715SXin Li* 3189*bf2c3715SXin Li* .. Scalar Arguments .. 3190*bf2c3715SXin Li REAL X, Y 3191*bf2c3715SXin Li* .. Executable Statements .. 3192*bf2c3715SXin Li SDIFF = X - Y 3193*bf2c3715SXin Li RETURN 3194*bf2c3715SXin Li* 3195*bf2c3715SXin Li* End of SDIFF. 3196*bf2c3715SXin Li* 3197*bf2c3715SXin Li END 3198*bf2c3715SXin Li SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) 3199*bf2c3715SXin Li* 3200*bf2c3715SXin Li* Tests whether XERBLA has detected an error when it should. 3201*bf2c3715SXin Li* 3202*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 3203*bf2c3715SXin Li* 3204*bf2c3715SXin Li* -- Written on 10-August-1987. 3205*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 3206*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 3207*bf2c3715SXin Li* 3208*bf2c3715SXin Li* .. Scalar Arguments .. 3209*bf2c3715SXin Li INTEGER INFOT, NOUT 3210*bf2c3715SXin Li LOGICAL LERR, OK 3211*bf2c3715SXin Li CHARACTER*6 SRNAMT 3212*bf2c3715SXin Li* .. Executable Statements .. 3213*bf2c3715SXin Li IF( .NOT.LERR )THEN 3214*bf2c3715SXin Li WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT 3215*bf2c3715SXin Li OK = .FALSE. 3216*bf2c3715SXin Li END IF 3217*bf2c3715SXin Li LERR = .FALSE. 3218*bf2c3715SXin Li RETURN 3219*bf2c3715SXin Li* 3220*bf2c3715SXin Li 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', 3221*bf2c3715SXin Li $ 'ETECTED BY ', A6, ' *****' ) 3222*bf2c3715SXin Li* 3223*bf2c3715SXin Li* End of CHKXER. 3224*bf2c3715SXin Li* 3225*bf2c3715SXin Li END 3226*bf2c3715SXin Li SUBROUTINE XERBLA( SRNAME, INFO ) 3227*bf2c3715SXin Li* 3228*bf2c3715SXin Li* This is a special version of XERBLA to be used only as part of 3229*bf2c3715SXin Li* the test program for testing error exits from the Level 2 BLAS 3230*bf2c3715SXin Li* routines. 3231*bf2c3715SXin Li* 3232*bf2c3715SXin Li* XERBLA is an error handler for the Level 2 BLAS routines. 3233*bf2c3715SXin Li* 3234*bf2c3715SXin Li* It is called by the Level 2 BLAS routines if an input parameter is 3235*bf2c3715SXin Li* invalid. 3236*bf2c3715SXin Li* 3237*bf2c3715SXin Li* Auxiliary routine for test program for Level 2 Blas. 3238*bf2c3715SXin Li* 3239*bf2c3715SXin Li* -- Written on 10-August-1987. 3240*bf2c3715SXin Li* Richard Hanson, Sandia National Labs. 3241*bf2c3715SXin Li* Jeremy Du Croz, NAG Central Office. 3242*bf2c3715SXin Li* 3243*bf2c3715SXin Li* .. Scalar Arguments .. 3244*bf2c3715SXin Li INTEGER INFO 3245*bf2c3715SXin Li CHARACTER*6 SRNAME 3246*bf2c3715SXin Li* .. Scalars in Common .. 3247*bf2c3715SXin Li INTEGER INFOT, NOUT 3248*bf2c3715SXin Li LOGICAL LERR, OK 3249*bf2c3715SXin Li CHARACTER*6 SRNAMT 3250*bf2c3715SXin Li* .. Common blocks .. 3251*bf2c3715SXin Li COMMON /INFOC/INFOT, NOUT, OK, LERR 3252*bf2c3715SXin Li COMMON /SRNAMC/SRNAMT 3253*bf2c3715SXin Li* .. Executable Statements .. 3254*bf2c3715SXin Li LERR = .TRUE. 3255*bf2c3715SXin Li IF( INFO.NE.INFOT )THEN 3256*bf2c3715SXin Li IF( INFOT.NE.0 )THEN 3257*bf2c3715SXin Li WRITE( NOUT, FMT = 9999 )INFO, INFOT 3258*bf2c3715SXin Li ELSE 3259*bf2c3715SXin Li WRITE( NOUT, FMT = 9997 )INFO 3260*bf2c3715SXin Li END IF 3261*bf2c3715SXin Li OK = .FALSE. 3262*bf2c3715SXin Li END IF 3263*bf2c3715SXin Li IF( SRNAME.NE.SRNAMT )THEN 3264*bf2c3715SXin Li WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT 3265*bf2c3715SXin Li OK = .FALSE. 3266*bf2c3715SXin Li END IF 3267*bf2c3715SXin Li RETURN 3268*bf2c3715SXin Li* 3269*bf2c3715SXin Li 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', 3270*bf2c3715SXin Li $ ' OF ', I2, ' *******' ) 3271*bf2c3715SXin Li 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', 3272*bf2c3715SXin Li $ 'AD OF ', A6, ' *******' ) 3273*bf2c3715SXin Li 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, 3274*bf2c3715SXin Li $ ' *******' ) 3275*bf2c3715SXin Li* 3276*bf2c3715SXin Li* End of XERBLA 3277*bf2c3715SXin Li* 3278*bf2c3715SXin Li END 3279*bf2c3715SXin Li 3280