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